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