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