Record pattern synonyms
[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 {-# SOURCE #-} 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)