01e52afa5c21a4af6121895fcaefcdd790b55a5b
[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, patSynType,
17 patSynMatcher, patSynBuilder,
18 patSynExTyVars, patSynSig,
19 patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
20 patSynFieldType,
21
22 tidyPatSynIds
23 ) where
24
25 #include "HsVersions.h"
26
27 import Type
28 import TcType( mkSigmaTy )
29 import Name
30 import Outputable
31 import Unique
32 import Util
33 import BasicTypes
34 import FastString
35 import Var
36 import FieldLabel
37
38 import qualified Data.Data as Data
39 import qualified Data.Typeable
40 import Data.Function
41 import Data.List
42
43 {-
44 ************************************************************************
45 * *
46 \subsection{Pattern synonyms}
47 * *
48 ************************************************************************
49 -}
50
51 -- | A pattern synonym
52 -- See Note [Pattern synonym representation]
53 -- See Note [Patten synonym signatures]
54 data PatSyn
55 = MkPatSyn {
56 psName :: Name,
57 psUnique :: Unique, -- Cached from Name
58
59 psArgs :: [Type],
60 psArity :: Arity, -- == length psArgs
61 psInfix :: Bool, -- True <=> declared infix
62 psFieldLabels :: [FieldLabel], -- List of fields for a
63 -- record pattern synonym
64 -- INVARIANT: either empty if no
65 -- record pat syn or same length as
66 -- psArgs
67
68 psUnivTyVars :: [TyVar], -- Universially-quantified type variables
69 psReqTheta :: ThetaType, -- Required dictionaries
70 -- these constraints are very much like
71 -- stupid thetas (which is a useful
72 -- guideline when implementing)
73 -- but are actually needed.
74 psExTyVars :: [TyVar], -- Existentially-quantified type vars
75 psProvTheta :: ThetaType, -- Provided dictionaries
76 psOrigResTy :: Type, -- Mentions only psUnivTyVars
77
78 -- See Note [Matchers and builders for pattern synonyms]
79 psMatcher :: (Id, Bool),
80 -- Matcher function.
81 -- If Bool is True then prov_theta and arg_tys are empty
82 -- and type is
83 -- forall (r :: ?) univ_tvs. req_theta
84 -- => res_ty
85 -- -> (forall ex_tvs. Void# -> r)
86 -- -> (Void# -> r)
87 -- -> r
88 --
89 -- Otherwise type is
90 -- forall (r :: ?) univ_tvs. req_theta
91 -- => res_ty
92 -- -> (forall ex_tvs. prov_theta => arg_tys -> r)
93 -- -> (Void# -> r)
94 -- -> r
95
96 psBuilder :: Maybe (Id, Bool)
97 -- Nothing => uni-directional pattern synonym
98 -- Just (builder, is_unlifted) => bi-directional
99 -- Builder function, of type
100 -- forall univ_tvs, ex_tvs. (prov_theta, req_theta)
101 -- => arg_tys -> res_ty
102 -- See Note [Builder for pattern synonyms with unboxed type]
103 }
104 deriving Data.Typeable.Typeable
105
106 {- Note [Patten synonym signatures]
107 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108 In a pattern synonym signature we write
109 pattern P :: req => prov => t1 -> ... tn -> res_ty
110
111 Note that the "required" context comes first, then the "provided"
112 context. Moreover, the "required" context must not mention
113 existentially-bound type variables; that is, ones not mentioned in
114 res_ty. See lots of discussion in Trac #10928.
115
116 If there is no "provided" context, you can omit it; but you
117 can't omit the "required" part (unless you omit both).
118
119 Example 1:
120 pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)
121 pattern P1 x = Just (3,x)
122
123 We require (Num a, Eq a) to match the 3; there is no provided
124 context.
125
126 Example 2:
127 data T2 where
128 MkT2 :: (Num a, Eq a) => a -> a -> T2
129
130 patttern P2 :: () => (Num a, Eq a) => a -> T2
131 pattern P2 x = MkT2 3 x
132
133 When we match against P2 we get a Num dictionary provided.
134 We can use that to check the match against 3.
135
136 Example 3:
137 pattern P3 :: Eq a => a -> b -> T3 b
138
139 This signature is illegal because the (Eq a) is a required
140 constraint, but it mentions the existentially-bound variable 'a'.
141 You can see it's existential because it doesn't appear in the
142 result type (T3 b).
143
144 Note [Pattern synonym representation]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 Consider the following pattern synonym declaration
147
148 pattern P x = MkT [x] (Just 42)
149
150 where
151 data T a where
152 MkT :: (Show a, Ord b) => [b] -> a -> T a
153
154 so pattern P has type
155
156 b -> T (Maybe t)
157
158 with the following typeclass constraints:
159
160 provides: (Show (Maybe t), Ord b)
161 requires: (Eq t, Num t)
162
163 In this case, the fields of MkPatSyn will be set as follows:
164
165 psArgs = [b]
166 psArity = 1
167 psInfix = False
168
169 psUnivTyVars = [t]
170 psExTyVars = [b]
171 psProvTheta = (Show (Maybe t), Ord b)
172 psReqTheta = (Eq t, Num t)
173 psOrigResTy = T (Maybe t)
174
175 Note [Matchers and builders for pattern synonyms]
176 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
177 For each pattern synonym P, we generate
178
179 * a "matcher" function, used to desugar uses of P in patterns,
180 which implements pattern matching
181
182 * A "builder" function (for bidirectional pattern synonyms only),
183 used to desugar uses of P in expressions, which constructs P-values.
184
185 For the above example, the matcher function has type:
186
187 $mP :: forall (r :: ?) t. (Eq t, Num t)
188 => T (Maybe t)
189 -> (forall b. (Show (Maybe t), Ord b) => b -> r)
190 -> (Void# -> r)
191 -> r
192
193 with the following implementation:
194
195 $mP @r @t $dEq $dNum scrut cont fail
196 = case scrut of
197 MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
198 _ -> fail Void#
199
200 Notice that the return type 'r' has an open kind, so that it can
201 be instantiated by an unboxed type; for example where we see
202 f (P x) = 3#
203
204 The extra Void# argument for the failure continuation is needed so that
205 it is lazy even when the result type is unboxed.
206
207 For the same reason, if the pattern has no arguments, an extra Void#
208 argument is added to the success continuation as well.
209
210 For *bidirectional* pattern synonyms, we also generate a "builder"
211 function which implements the pattern synonym in an expression
212 context. For our running example, it will be:
213
214 $bP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
215 => b -> T (Maybe t)
216 $bP x = MkT [x] (Just 42)
217
218 NB: the existential/universal and required/provided split does not
219 apply to the builder since you are only putting stuff in, not getting
220 stuff out.
221
222 Injectivity of bidirectional pattern synonyms is checked in
223 tcPatToExpr which walks the pattern and returns its corresponding
224 expression when available.
225
226 Note [Builder for pattern synonyms with unboxed type]
227 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
228 For bidirectional pattern synonyms that have no arguments and have an
229 unboxed type, we add an extra Void# argument to the builder, else it
230 would be a top-level declaration with an unboxed type.
231
232 pattern P = 0#
233
234 $bP :: Void# -> Int#
235 $bP _ = 0#
236
237 This means that when typechecking an occurrence of P in an expression,
238 we must remember that the builder has this void argument. This is
239 done by TcPatSyn.patSynBuilderOcc.
240
241
242 ************************************************************************
243 * *
244 \subsection{Instances}
245 * *
246 ************************************************************************
247 -}
248
249 instance Eq PatSyn where
250 (==) = (==) `on` getUnique
251 (/=) = (/=) `on` getUnique
252
253 instance Ord PatSyn where
254 (<=) = (<=) `on` getUnique
255 (<) = (<) `on` getUnique
256 (>=) = (>=) `on` getUnique
257 (>) = (>) `on` getUnique
258 compare = compare `on` getUnique
259
260 instance Uniquable PatSyn where
261 getUnique = psUnique
262
263 instance NamedThing PatSyn where
264 getName = patSynName
265
266 instance Outputable PatSyn where
267 ppr = ppr . getName
268
269 instance OutputableBndr PatSyn where
270 pprInfixOcc = pprInfixName . getName
271 pprPrefixOcc = pprPrefixName . getName
272
273 instance Data.Data PatSyn where
274 -- don't traverse?
275 toConstr _ = abstractConstr "PatSyn"
276 gunfold _ _ = error "gunfold"
277 dataTypeOf _ = mkNoRepType "PatSyn"
278
279 {-
280 ************************************************************************
281 * *
282 \subsection{Construction}
283 * *
284 ************************************************************************
285 -}
286
287 -- | Build a new pattern synonym
288 mkPatSyn :: Name
289 -> Bool -- ^ Is the pattern synonym declared infix?
290 -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
291 -- and required dicts
292 -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
293 -- and provided dicts
294 -> [Type] -- ^ Original arguments
295 -> Type -- ^ Original result type
296 -> (Id, Bool) -- ^ Name of matcher
297 -> Maybe (Id, Bool) -- ^ Name of builder
298 -> [FieldLabel] -- ^ Names of fields for
299 -- a record pattern synonym
300 -> PatSyn
301 mkPatSyn name declared_infix
302 (univ_tvs, req_theta)
303 (ex_tvs, prov_theta)
304 orig_args
305 orig_res_ty
306 matcher builder field_labels
307 = MkPatSyn {psName = name, psUnique = getUnique name,
308 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
309 psProvTheta = prov_theta, psReqTheta = req_theta,
310 psInfix = declared_infix,
311 psArgs = orig_args,
312 psArity = length orig_args,
313 psOrigResTy = orig_res_ty,
314 psMatcher = matcher,
315 psBuilder = builder,
316 psFieldLabels = field_labels
317 }
318
319 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
320 patSynName :: PatSyn -> Name
321 patSynName = psName
322
323 patSynType :: PatSyn -> Type
324 -- The full pattern type, used only in error messages
325 -- See Note [Patten synonym signatures]
326 patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
327 , psExTyVars = ex_tvs, psProvTheta = prov_theta
328 , psArgs = orig_args, psOrigResTy = orig_res_ty })
329 = mkSigmaTy univ_tvs req_theta $
330 mkSigmaTy ex_tvs prov_theta $
331 mkFunTys orig_args orig_res_ty
332
333 -- | Should the 'PatSyn' be presented infix?
334 patSynIsInfix :: PatSyn -> Bool
335 patSynIsInfix = psInfix
336
337 -- | Arity of the pattern synonym
338 patSynArity :: PatSyn -> Arity
339 patSynArity = psArity
340
341 patSynArgs :: PatSyn -> [Type]
342 patSynArgs = psArgs
343
344 patSynFieldLabels :: PatSyn -> [FieldLabel]
345 patSynFieldLabels = psFieldLabels
346
347 -- | Extract the type for any given labelled field of the 'DataCon'
348 patSynFieldType :: PatSyn -> FieldLabelString -> Type
349 patSynFieldType ps label
350 = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of
351 Just (_, ty) -> ty
352 Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
353
354 patSynExTyVars :: PatSyn -> [TyVar]
355 patSynExTyVars = psExTyVars
356
357 patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
358 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
359 , psProvTheta = prov, psReqTheta = req
360 , psArgs = arg_tys, psOrigResTy = res_ty })
361 = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty)
362
363 patSynMatcher :: PatSyn -> (Id,Bool)
364 patSynMatcher = psMatcher
365
366 patSynBuilder :: PatSyn -> Maybe (Id, Bool)
367 patSynBuilder = psBuilder
368
369 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
370 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
371 = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
372 where
373 tidy_pr (id, dummy) = (tidy_fn id, dummy)
374
375 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
376 -- Return the types of the argument patterns
377 -- e.g. data D a = forall b. MkD a b (b->a)
378 -- pattern P f x y = MkD (x,True) y f
379 -- D :: forall a. forall b. a -> b -> (b->a) -> D a
380 -- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
381 -- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
382 -- NB: the inst_tys should be both universal and existential
383 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
384 , psExTyVars = ex_tvs, psArgs = arg_tys })
385 inst_tys
386 = ASSERT2( length tyvars == length inst_tys
387 , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
388 map (substTyWith tyvars inst_tys) arg_tys
389 where
390 tyvars = univ_tvs ++ ex_tvs
391
392 patSynInstResTy :: PatSyn -> [Type] -> Type
393 -- Return the type of whole pattern
394 -- E.g. pattern P x y = Just (x,x,y)
395 -- P :: a -> b -> Just (a,a,b)
396 -- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
397 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
398 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
399 , psOrigResTy = res_ty })
400 inst_tys
401 = ASSERT2( length univ_tvs == length inst_tys
402 , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
403 substTyWith univ_tvs inst_tys res_ty