081968aabd80d8c89680e6544cd4ef6751dfda8b
[ghc.git] / compiler / basicTypes / PatSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[PatSyn]{@PatSyn@: Pattern synonyms}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module PatSyn (
11 -- * Main data types
12 PatSyn, mkPatSyn,
13
14 -- ** Type deconstruction
15 patSynName, patSynArity, patSynIsInfix,
16 patSynArgs, patSynTyDetails, patSynType,
17 patSynMatcher, patSynBuilder,
18 patSynExTyVars, patSynSig,
19 patSynInstArgTys, patSynInstResTy,
20 tidyPatSynIds
21 ) where
22
23 #include "HsVersions.h"
24
25 import Type
26 import TcType( mkSigmaTy )
27 import Name
28 import Outputable
29 import Unique
30 import Util
31 import BasicTypes
32 import FastString
33 import Var
34 import HsBinds( HsPatSynDetails(..) )
35
36 import qualified Data.Data as Data
37 import qualified Data.Typeable
38 import Data.Function
39
40 {-
41 ************************************************************************
42 * *
43 \subsection{Pattern synonyms}
44 * *
45 ************************************************************************
46 -}
47
48 -- | A pattern synonym
49 -- See Note [Pattern synonym representation]
50 data PatSyn
51 = MkPatSyn {
52 psName :: Name,
53 psUnique :: Unique, -- Cached from Name
54
55 psArgs :: [Type],
56 psArity :: Arity, -- == length psArgs
57 psInfix :: Bool, -- True <=> declared infix
58
59 psUnivTyVars :: [TyVar], -- Universially-quantified type variables
60 psReqTheta :: ThetaType, -- Required dictionaries
61 psExTyVars :: [TyVar], -- Existentially-quantified type vars
62 psProvTheta :: ThetaType, -- Provided dictionaries
63 psOrigResTy :: Type, -- Mentions only psUnivTyVars
64
65 -- See Note [Matchers and builders for pattern synonyms]
66 psMatcher :: (Id, Bool),
67 -- Matcher function.
68 -- If Bool is True then prov_theta and arg_tys are empty
69 -- and type is
70 -- forall (r :: ?) univ_tvs. req_theta
71 -- => res_ty
72 -- -> (forall ex_tvs. Void# -> r)
73 -- -> (Void# -> r)
74 -- -> r
75 --
76 -- Otherwise type is
77 -- forall (r :: ?) univ_tvs. req_theta
78 -- => res_ty
79 -- -> (forall ex_tvs. prov_theta => arg_tys -> r)
80 -- -> (Void# -> r)
81 -- -> r
82
83 psBuilder :: Maybe (Id, Bool)
84 -- Nothing => uni-directional pattern synonym
85 -- Just (builder, is_unlifted) => bi-directional
86 -- Builder function, of type
87 -- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
88 -- => arg_tys -> res_ty
89 -- See Note [Builder for pattern synonyms with unboxed type]
90 }
91 deriving Data.Typeable.Typeable
92
93 {-
94 Note [Pattern synonym representation]
95 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
96 Consider the following pattern synonym declaration
97
98 pattern P x = MkT [x] (Just 42)
99
100 where
101 data T a where
102 MkT :: (Show a, Ord b) => [b] -> a -> T a
103
104 so pattern P has type
105
106 b -> T (Maybe t)
107
108 with the following typeclass constraints:
109
110 provides: (Show (Maybe t), Ord b)
111 requires: (Eq t, Num t)
112
113 In this case, the fields of MkPatSyn will be set as follows:
114
115 psArgs = [b]
116 psArity = 1
117 psInfix = False
118
119 psUnivTyVars = [t]
120 psExTyVars = [b]
121 psProvTheta = (Show (Maybe t), Ord b)
122 psReqTheta = (Eq t, Num t)
123 psOrigResTy = T (Maybe t)
124
125 Note [Matchers and builders for pattern synonyms]
126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
127 For each pattern synonym P, we generate
128
129 * a "matcher" function, used to desugar uses of P in patterns,
130 which implements pattern matching
131
132 * A "builder" function (for bidirectional pattern synonyms only),
133 used to desugar uses of P in expressions, which constructs P-values.
134
135 For the above example, the matcher function has type:
136
137 $mP :: forall (r :: ?) t. (Eq t, Num t)
138 => T (Maybe t)
139 -> (forall b. (Show (Maybe t), Ord b) => b -> r)
140 -> (Void# -> r)
141 -> r
142
143 with the following implementation:
144
145 $mP @r @t $dEq $dNum scrut cont fail
146 = case scrut of
147 MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
148 _ -> fail Void#
149
150 Notice that the return type 'r' has an open kind, so that it can
151 be instantiated by an unboxed type; for example where we see
152 f (P x) = 3#
153
154 The extra Void# argument for the failure continuation is needed so that
155 it is lazy even when the result type is unboxed.
156
157 For the same reason, if the pattern has no arguments, an extra Void#
158 argument is added to the success continuation as well.
159
160 For *bidirectional* pattern synonyms, we also generate a "builder"
161 function which implements the pattern synonym in an expression
162 context. For our running example, it will be:
163
164 $bP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
165 => b -> T (Maybe t)
166 $bP x = MkT [x] (Just 42)
167
168 NB: the existential/universal and required/provided split does not
169 apply to the builder since you are only putting stuff in, not getting
170 stuff out.
171
172 Injectivity of bidirectional pattern synonyms is checked in
173 tcPatToExpr which walks the pattern and returns its corresponding
174 expression when available.
175
176 Note [Builder for pattern synonyms with unboxed type]
177 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
178 For bidirectional pattern synonyms that have no arguments and have an
179 unboxed type, we add an extra Void# argument to the builder, else it
180 would be a top-level declaration with an unboxed type.
181
182 pattern P = 0#
183
184 $bP :: Void# -> Int#
185 $bP _ = 0#
186
187 This means that when typechecking an occurrence of P in an expression,
188 we must remember that the builder has this void argument. This is
189 done by TcPatSyn.patSynBuilderOcc.
190
191
192 ************************************************************************
193 * *
194 \subsection{Instances}
195 * *
196 ************************************************************************
197 -}
198
199 instance Eq PatSyn where
200 (==) = (==) `on` getUnique
201 (/=) = (/=) `on` getUnique
202
203 instance Ord PatSyn where
204 (<=) = (<=) `on` getUnique
205 (<) = (<) `on` getUnique
206 (>=) = (>=) `on` getUnique
207 (>) = (>) `on` getUnique
208 compare = compare `on` getUnique
209
210 instance Uniquable PatSyn where
211 getUnique = psUnique
212
213 instance NamedThing PatSyn where
214 getName = patSynName
215
216 instance Outputable PatSyn where
217 ppr = ppr . getName
218
219 instance OutputableBndr PatSyn where
220 pprInfixOcc = pprInfixName . getName
221 pprPrefixOcc = pprPrefixName . getName
222
223 instance Data.Data PatSyn where
224 -- don't traverse?
225 toConstr _ = abstractConstr "PatSyn"
226 gunfold _ _ = error "gunfold"
227 dataTypeOf _ = mkNoRepType "PatSyn"
228
229 {-
230 ************************************************************************
231 * *
232 \subsection{Construction}
233 * *
234 ************************************************************************
235 -}
236
237 -- | Build a new pattern synonym
238 mkPatSyn :: Name
239 -> Bool -- ^ Is the pattern synonym declared infix?
240 -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
241 -- and required dicts
242 -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
243 -- and provided dicts
244 -> [Type] -- ^ Original arguments
245 -> Type -- ^ Original result type
246 -> (Id, Bool) -- ^ Name of matcher
247 -> Maybe (Id, Bool) -- ^ Name of builder
248 -> PatSyn
249 mkPatSyn name declared_infix
250 (univ_tvs, req_theta)
251 (ex_tvs, prov_theta)
252 orig_args
253 orig_res_ty
254 matcher builder
255 = MkPatSyn {psName = name, psUnique = getUnique name,
256 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
257 psProvTheta = prov_theta, psReqTheta = req_theta,
258 psInfix = declared_infix,
259 psArgs = orig_args,
260 psArity = length orig_args,
261 psOrigResTy = orig_res_ty,
262 psMatcher = matcher,
263 psBuilder = builder }
264
265 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
266 patSynName :: PatSyn -> Name
267 patSynName = psName
268
269 patSynType :: PatSyn -> Type
270 -- The full pattern type, used only in error messages
271 patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
272 , psExTyVars = ex_tvs, psProvTheta = prov_theta
273 , psArgs = orig_args, psOrigResTy = orig_res_ty })
274 = mkSigmaTy univ_tvs req_theta $
275 mkSigmaTy ex_tvs prov_theta $
276 mkFunTys orig_args orig_res_ty
277
278 -- | Should the 'PatSyn' be presented infix?
279 patSynIsInfix :: PatSyn -> Bool
280 patSynIsInfix = psInfix
281
282 -- | Arity of the pattern synonym
283 patSynArity :: PatSyn -> Arity
284 patSynArity = psArity
285
286 patSynArgs :: PatSyn -> [Type]
287 patSynArgs = psArgs
288
289 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
290 patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
291 | is_infix, [left,right] <- arg_tys
292 = InfixPatSyn left right
293 | otherwise
294 = PrefixPatSyn arg_tys
295
296 patSynExTyVars :: PatSyn -> [TyVar]
297 patSynExTyVars = psExTyVars
298
299 patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
300 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
301 , psProvTheta = prov, psReqTheta = req
302 , psArgs = arg_tys, psOrigResTy = res_ty })
303 = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
304
305 patSynMatcher :: PatSyn -> (Id,Bool)
306 patSynMatcher = psMatcher
307
308 patSynBuilder :: PatSyn -> Maybe (Id, Bool)
309 patSynBuilder = psBuilder
310
311 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
312 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
313 = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
314 where
315 tidy_pr (id, dummy) = (tidy_fn id, dummy)
316
317 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
318 -- Return the types of the argument patterns
319 -- e.g. data D a = forall b. MkD a b (b->a)
320 -- pattern P f x y = MkD (x,True) y f
321 -- D :: forall a. forall b. a -> b -> (b->a) -> D a
322 -- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
323 -- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
324 -- NB: the inst_tys should be both universal and existential
325 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
326 , psExTyVars = ex_tvs, psArgs = arg_tys })
327 inst_tys
328 = ASSERT2( length tyvars == length inst_tys
329 , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
330 map (substTyWith tyvars inst_tys) arg_tys
331 where
332 tyvars = univ_tvs ++ ex_tvs
333
334 patSynInstResTy :: PatSyn -> [Type] -> Type
335 -- Return the type of whole pattern
336 -- E.g. pattern P x y = Just (x,x,y)
337 -- P :: a -> b -> Just (a,a,b)
338 -- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
339 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
340 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
341 , psOrigResTy = res_ty })
342 inst_tys
343 = ASSERT2( length univ_tvs == length inst_tys
344 , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
345 substTyWith univ_tvs inst_tys res_ty