Coercion Quantification
[ghc.git] / compiler / basicTypes / ConLike.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[ConLike]{@ConLike@: Constructor-like things}
6 -}
7
8 {-# LANGUAGE CPP #-}
9
10 module ConLike (
11 ConLike(..)
12 , conLikeArity
13 , conLikeFieldLabels
14 , conLikeInstOrigArgTys
15 , conLikeExTyCoVars
16 , conLikeName
17 , conLikeStupidTheta
18 , conLikeWrapId_maybe
19 , conLikeImplBangs
20 , conLikeFullSig
21 , conLikeResTy
22 , conLikeFieldType
23 , conLikesWithFields
24 , conLikeIsInfix
25 ) where
26
27 #include "HsVersions.h"
28
29 import GhcPrelude
30
31 import DataCon
32 import PatSyn
33 import Outputable
34 import Unique
35 import Util
36 import Name
37 import BasicTypes
38 import TyCoRep (Type, ThetaType)
39 import Var
40 import Type (mkTyConApp)
41
42 import qualified Data.Data as Data
43
44 {-
45 ************************************************************************
46 * *
47 \subsection{Constructor-like things}
48 * *
49 ************************************************************************
50 -}
51
52 -- | A constructor-like thing
53 data ConLike = RealDataCon DataCon
54 | PatSynCon PatSyn
55
56 {-
57 ************************************************************************
58 * *
59 \subsection{Instances}
60 * *
61 ************************************************************************
62 -}
63
64 instance Eq ConLike where
65 (==) = eqConLike
66
67 eqConLike :: ConLike -> ConLike -> Bool
68 eqConLike x y = getUnique x == getUnique y
69
70 -- There used to be an Ord ConLike instance here that used Unique for ordering.
71 -- It was intentionally removed to prevent determinism problems.
72 -- See Note [Unique Determinism] in Unique.
73
74 instance Uniquable ConLike where
75 getUnique (RealDataCon dc) = getUnique dc
76 getUnique (PatSynCon ps) = getUnique ps
77
78 instance NamedThing ConLike where
79 getName (RealDataCon dc) = getName dc
80 getName (PatSynCon ps) = getName ps
81
82 instance Outputable ConLike where
83 ppr (RealDataCon dc) = ppr dc
84 ppr (PatSynCon ps) = ppr ps
85
86 instance OutputableBndr ConLike where
87 pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
88 pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
89 pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
90 pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
91
92 instance Data.Data ConLike where
93 -- don't traverse?
94 toConstr _ = abstractConstr "ConLike"
95 gunfold _ _ = error "gunfold"
96 dataTypeOf _ = mkNoRepType "ConLike"
97
98 -- | Number of arguments
99 conLikeArity :: ConLike -> Arity
100 conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
101 conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn
102
103 -- | Names of fields used for selectors
104 conLikeFieldLabels :: ConLike -> [FieldLabel]
105 conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
106 conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn
107
108 -- | Returns just the instantiated /value/ argument types of a 'ConLike',
109 -- (excluding dictionary args)
110 conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
111 conLikeInstOrigArgTys (RealDataCon data_con) tys =
112 dataConInstOrigArgTys data_con tys
113 conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
114 patSynInstArgTys pat_syn tys
115
116 -- | Existentially quantified type/coercion variables
117 conLikeExTyCoVars :: ConLike -> [TyCoVar]
118 conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
119 conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1
120
121 conLikeName :: ConLike -> Name
122 conLikeName (RealDataCon data_con) = dataConName data_con
123 conLikeName (PatSynCon pat_syn) = patSynName pat_syn
124
125 -- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:
126 --
127 -- > data Eq a => T a = ...
128 -- It is empty for `PatSynCon` as they do not allow such contexts.
129 conLikeStupidTheta :: ConLike -> ThetaType
130 conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
131 conLikeStupidTheta (PatSynCon {}) = []
132
133 -- | Returns the `Id` of the wrapper. This is also known as the builder in
134 -- some contexts. The value is Nothing only in the case of unidirectional
135 -- pattern synonyms.
136 conLikeWrapId_maybe :: ConLike -> Maybe Id
137 conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con
138 conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn
139
140 -- | Returns the strictness information for each constructor
141 conLikeImplBangs :: ConLike -> [HsImplBang]
142 conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con
143 conLikeImplBangs (PatSynCon pat_syn) =
144 replicate (patSynArity pat_syn) HsLazy
145
146 -- | Returns the type of the whole pattern
147 conLikeResTy :: ConLike -> [Type] -> Type
148 conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
149 conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
150
151 -- | The \"full signature\" of the 'ConLike' returns, in order:
152 --
153 -- 1) The universally quantified type variables
154 --
155 -- 2) The existentially quantified type/coercion variables
156 --
157 -- 3) The equality specification
158 --
159 -- 4) The provided theta (the constraints provided by a match)
160 --
161 -- 5) The required theta (the constraints required for a match)
162 --
163 -- 6) The original argument types (i.e. before
164 -- any change of the representation of the type)
165 --
166 -- 7) The original result type
167 conLikeFullSig :: ConLike
168 -> ([TyVar], [TyCoVar], [EqSpec]
169 -- Why tyvars for universal but tycovars for existential?
170 -- See Note [Existential coercion variables] in DataCon
171 , ThetaType, ThetaType, [Type], Type)
172 conLikeFullSig (RealDataCon con) =
173 let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
174 -- Required theta is empty as normal data cons require no additional
175 -- constraints for a match
176 in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)
177 conLikeFullSig (PatSynCon pat_syn) =
178 let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn
179 -- eqSpec is empty
180 in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)
181
182 -- | Extract the type for any given labelled field of the 'ConLike'
183 conLikeFieldType :: ConLike -> FieldLabelString -> Type
184 conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
185 conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
186
187
188 -- | The ConLikes that have *all* the given fields
189 conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
190 conLikesWithFields con_likes lbls = filter has_flds con_likes
191 where has_flds dc = all (has_fld dc) lbls
192 has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
193
194 conLikeIsInfix :: ConLike -> Bool
195 conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
196 conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps