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