Generate Typeable info at definition sites
[ghc.git] / compiler / typecheck / TcPatSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[TcPatSyn]{Typechecking pattern synonym declarations}
6 -}
7
8 {-# LANGUAGE CPP #-}
9
10 module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
11 , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
12 ) where
13
14 import HsSyn
15 import TcPat
16 import TcRnMonad
17 import TcEnv
18 import TcMType
19 import TysPrim
20 import TypeRep
21 import Name
22 import SrcLoc
23 import PatSyn
24 import NameSet
25 import Panic
26 import Outputable
27 import FastString
28 import Var
29 import Id
30 import IdInfo( IdDetails(..), RecSelParent(..))
31 import TcBinds
32 import BasicTypes
33 import TcSimplify
34 import TcUnify
35 import TcType
36 import TcEvidence
37 import BuildTyCl
38 import VarSet
39 import MkId
40 import VarEnv
41 import Inst
42 import TcTyDecls
43 import ConLike
44 import FieldLabel
45 #if __GLASGOW_HASKELL__ < 709
46 import Data.Monoid
47 #endif
48 import Bag
49 import Util
50 import Data.Maybe
51 import Control.Monad (forM)
52
53 #include "HsVersions.h"
54
55 {-
56 ************************************************************************
57 * *
58 Type checking a pattern synonym
59 * *
60 ************************************************************************
61 -}
62
63 tcInferPatSynDecl :: PatSynBind Name Name
64 -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
65 tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
66 psb_def = lpat, psb_dir = dir }
67 = setSrcSpan loc $
68 do { traceTc "tcInferPatSynDecl {" $ ppr name
69 ; tcCheckPatSynPat lpat
70
71 ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
72
73 ; ((lpat', (args, pat_ty)), tclvl, wanted)
74 <- pushLevelAndCaptureConstraints $
75 do { pat_ty <- newFlexiTyVarTy openTypeKind
76 ; tcPat PatSyn lpat pat_ty $
77 do { args <- mapM tcLookupId arg_names
78 ; return (args, pat_ty) } }
79
80 ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
81
82 ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
83
84 ; (ex_vars, prov_dicts) <- tcCollectEx lpat'
85 ; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
86 ex_tvs = varSetElems ex_vars
87 prov_theta = map evVarPred prov_dicts
88 req_theta = map evVarPred req_dicts
89
90 ; traceTc "tcInferPatSynDecl }" $ ppr name
91 ; tc_patsyn_finish lname dir is_infix lpat'
92 (univ_tvs, req_theta, ev_binds, req_dicts)
93 (ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts)
94 (zip args $ repeat idHsWrapper)
95 pat_ty rec_fields }
96
97
98 tcCheckPatSynDecl :: PatSynBind Name Name
99 -> TcPatSynInfo
100 -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
101 tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
102 psb_def = lpat, psb_dir = dir }
103 TPSI{ patsig_tau = tau,
104 patsig_ex = ex_tvs, patsig_univ = univ_tvs,
105 patsig_prov = prov_theta, patsig_req = req_theta }
106 = setSrcSpan loc $
107 do { traceTc "tcCheckPatSynDecl" $
108 ppr (ex_tvs, prov_theta) $$
109 ppr (univ_tvs, req_theta) $$
110 ppr arg_tys $$
111 ppr tau
112 ; tcCheckPatSynPat lpat
113
114 ; req_dicts <- newEvVars req_theta
115
116 -- TODO: find a better SkolInfo
117 ; let skol_info = SigSkol (PatSynCtxt name) (mkFunTys arg_tys pat_ty)
118
119 ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
120
121 ; let ty_arity = length arg_tys
122 ; checkTc (length arg_names == ty_arity)
123 (wrongNumberOfParmsErr ty_arity)
124
125 -- Typecheck the pattern against pat_ty, then unify the type of args
126 -- against arg_tys, with ex_tvs changed to SigTyVars.
127 -- We get out of this:
128 -- * The evidence bindings for the requested theta: req_ev_binds
129 -- * The typechecked pattern: lpat'
130 -- * The arguments, type-coerced to the SigTyVars: wrapped_args
131 -- * The instantiation of ex_tvs to pass to the success continuation: ex_tys
132 -- * The provided theta substituted with the SigTyVars: prov_theta'
133 ; (implic1, req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <-
134 buildImplication skol_info univ_tvs req_dicts $
135 tcPat PatSyn lpat pat_ty $ do
136 { ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs
137 ; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $
138 zipTyEnv ex_tvs (map mkTyVarTy ex_sigtvs)
139 ; let ex_tys = substTys subst $ map mkTyVarTy ex_tvs
140 prov_theta' = substTheta subst prov_theta
141 ; wrapped_args <- forM (zipEqual "tcCheckPatSynDecl" arg_names arg_tys) $ \(arg_name, arg_ty) -> do
142 { arg <- tcLookupId arg_name
143 ; let arg_ty' = substTy subst arg_ty
144 ; coi <- unifyType (varType arg) arg_ty'
145 ; return (setVarType arg arg_ty, coToHsWrapper coi) }
146 ; return (ex_tys, prov_theta', wrapped_args) }
147
148 ; (ex_vars_rhs, prov_dicts_rhs) <- tcCollectEx lpat'
149 ; let ex_tvs_rhs = varSetElems ex_vars_rhs
150
151 -- Check that prov_theta' can be satisfied with the dicts from the pattern
152 ; (implic2, prov_ev_binds, prov_dicts) <-
153 buildImplication skol_info ex_tvs_rhs prov_dicts_rhs $ do
154 { let origin = PatOrigin -- TODO
155 ; emitWanteds origin prov_theta' }
156
157 -- Solve the constraints now, because we are about to make a PatSyn,
158 -- which should not contain unification variables and the like (Trac #10997)
159 -- Since all the inputs are implications the returned bindings will be empty
160 ; _ <- simplifyTop (emptyWC `addImplics` (implic1 `unionBags` implic2))
161
162 ; traceTc "tcCheckPatSynDecl }" $ ppr name
163 ; tc_patsyn_finish lname dir is_infix lpat'
164 (univ_tvs, req_theta, req_ev_binds, req_dicts)
165 (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
166 wrapped_args
167 pat_ty rec_fields }
168 where
169 (arg_tys, pat_ty) = tcSplitFunTys tau
170
171 collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool)
172 collectPatSynArgInfo details =
173 case details of
174 PrefixPatSyn names -> (map unLoc names, [], False)
175 InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
176 RecordPatSyn names ->
177 let (vars, sels) = unzip (map splitRecordPatSyn names)
178 in (vars, sels, False)
179
180 where
181 splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name)
182 splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
183 , recordPatSynSelectorId = L _ selId })
184 = (patVar, selId)
185
186 wrongNumberOfParmsErr :: Arity -> SDoc
187 wrongNumberOfParmsErr ty_arity
188 = ptext (sLit "Number of pattern synonym arguments doesn't match type; expected")
189 <+> ppr ty_arity
190
191 -------------------------
192 -- Shared by both tcInferPatSyn and tcCheckPatSyn
193 tc_patsyn_finish :: Located Name -- ^ PatSyn Name
194 -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
195 -> Bool -- ^ Whether infix
196 -> LPat Id -- ^ Pattern of the PatSyn
197 -> ([TcTyVar], [PredType], TcEvBinds, [EvVar])
198 -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar])
199 -> [(Var, HsWrapper)] -- ^ Pattern arguments
200 -> TcType -- ^ Pattern type
201 -> [Name] -- ^ Selector names
202 -- ^ Whether fields, empty if not record PatSyn
203 -> TcM (PatSyn, LHsBinds Id, TcGblEnv)
204 tc_patsyn_finish lname dir is_infix lpat'
205 (univ_tvs, req_theta, req_ev_binds, req_dicts)
206 (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
207 wrapped_args
208 pat_ty field_labels
209 = do { -- Zonk everything. We are about to build a final PatSyn
210 -- so there had better be no unification variables in there
211 univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs
212 ; ex_tvs <- mapM zonkQuantifiedTyVar ex_tvs
213 ; prov_theta <- zonkTcThetaType prov_theta
214 ; req_theta <- zonkTcThetaType req_theta
215 ; pat_ty <- zonkTcType pat_ty
216 ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args
217 ; let qtvs = univ_tvs ++ ex_tvs
218 -- See Note [Record PatSyn Desugaring]
219 theta = prov_theta ++ req_theta
220 arg_tys = map (varType . fst) wrapped_args
221
222 ; (patSyn, matcher_bind) <- fixM $ \ ~(patSyn,_) -> do {
223
224 traceTc "tc_patsyn_finish {" $
225 ppr (unLoc lname) $$ ppr (unLoc lpat') $$
226 ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
227 ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$
228 ppr wrapped_args $$
229 ppr pat_ty
230
231 -- Make the 'matcher'
232 ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
233 (univ_tvs, req_theta, req_ev_binds, req_dicts)
234 (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
235 wrapped_args -- Not necessarily zonked
236 pat_ty
237
238
239 -- Make the 'builder'
240 ; builder_id <- mkPatSynBuilderId dir lname qtvs theta
241 arg_tys pat_ty patSyn
242
243 -- TODO: Make this have the proper information
244 ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
245 field_labels' = (map mkFieldLabel field_labels)
246
247
248 -- Make the PatSyn itself
249 ; let patSyn' = mkPatSyn (unLoc lname) is_infix
250 (univ_tvs, req_theta)
251 (ex_tvs, prov_theta)
252 arg_tys
253 pat_ty
254 matcher_id builder_id
255 field_labels'
256 ; return (patSyn', matcher_bind) }
257
258 -- Selectors
259 ; let (sigs, selector_binds) =
260 unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn))
261 ; let tything = AConLike (PatSynCon patSyn)
262 ; tcg_env <-
263 tcExtendGlobalEnv [tything] $
264 tcRecSelBinds
265 (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)
266
267 ; return (patSyn, matcher_bind, tcg_env) }
268
269 where
270 zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper)
271 -- The HsWrapper will get zonked later, as part of the LHsBinds
272 zonk_wrapped_arg (arg_id, wrap) = do { arg_id <- zonkId arg_id
273 ; return (arg_id, wrap) }
274
275 {-
276 ************************************************************************
277 * *
278 Constructing the "matcher" Id and its binding
279 * *
280 ************************************************************************
281 -}
282
283 tcPatSynMatcher :: Located Name
284 -> LPat Id
285 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
286 -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar])
287 -> [(Var, HsWrapper)]
288 -> TcType
289 -> TcM ((Id, Bool), LHsBinds Id)
290 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
291 tcPatSynMatcher (L loc name) lpat
292 (univ_tvs, req_theta, req_ev_binds, req_dicts)
293 (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
294 wrapped_args pat_ty
295 = do { uniq <- newUnique
296 ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
297 res_tv = mkTcTyVar tv_name openTypeKind (SkolemTv False)
298 is_unlifted = null wrapped_args && null prov_dicts
299 res_ty = mkTyVarTy res_tv
300 (cont_arg_tys, cont_args)
301 | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId])
302 | otherwise = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg)
303 | (arg, wrap) <- wrapped_args
304 ]
305 cont_ty = mkSigmaTy ex_tvs prov_theta $
306 mkFunTys cont_arg_tys res_ty
307
308 fail_ty = mkFunTy voidPrimTy res_ty
309
310 ; matcher_name <- newImplicitBinder name mkMatcherOcc
311 ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
312 ; cont <- newSysLocalId (fsLit "cont") cont_ty
313 ; fail <- newSysLocalId (fsLit "fail") fail_ty
314
315 ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
316 matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
317 matcher_id = mkExportedLocalId PatSynId matcher_name matcher_sigma
318 -- See Note [Exported LocalIds] in Id
319
320 cont_dicts = map nlHsVar prov_dicts
321 cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
322 nlHsTyApps cont ex_tys (cont_dicts ++ cont_args)
323
324 fail' = nlHsApps fail [nlHsVar voidPrimId]
325
326 args = map nlVarPat [scrutinee, cont, fail]
327 lwpat = noLoc $ WildPat pat_ty
328 cases = if isIrrefutableHsPat lpat
329 then [mkSimpleHsAlt lpat cont']
330 else [mkSimpleHsAlt lpat cont',
331 mkSimpleHsAlt lwpat fail']
332 body = mkLHsWrap (mkWpLet req_ev_binds) $
333 L (getLoc lpat) $
334 HsCase (nlHsVar scrutinee) $
335 MG{ mg_alts = cases
336 , mg_arg_tys = [pat_ty]
337 , mg_res_ty = res_ty
338 , mg_origin = Generated
339 }
340 body' = noLoc $
341 HsLam $
342 MG{ mg_alts = [mkSimpleMatch args body]
343 , mg_arg_tys = [pat_ty, cont_ty, res_ty]
344 , mg_res_ty = res_ty
345 , mg_origin = Generated
346 }
347 match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
348 mg = MG{ mg_alts = [match]
349 , mg_arg_tys = []
350 , mg_res_ty = res_ty
351 , mg_origin = Generated
352 }
353
354 ; let bind = FunBind{ fun_id = L loc matcher_id
355 , fun_infix = False
356 , fun_matches = mg
357 , fun_co_fn = idHsWrapper
358 , bind_fvs = emptyNameSet
359 , fun_tick = [] }
360 matcher_bind = unitBag (noLoc bind)
361
362 ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
363 ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
364
365 ; return ((matcher_id, is_unlifted), matcher_bind) }
366
367 mkPatSynRecSelBinds :: PatSyn
368 -> [FieldLabel]
369 -- ^ Visible field labels
370 -> [(LSig Name, LHsBinds Name)]
371 mkPatSynRecSelBinds ps fields = map mkRecSel fields
372 where
373 mkRecSel fld_lbl =
374 case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
375 (name, (_rec_flag, binds)) -> (name, binds)
376
377 isUnidirectional :: HsPatSynDir a -> Bool
378 isUnidirectional Unidirectional = True
379 isUnidirectional ImplicitBidirectional = False
380 isUnidirectional ExplicitBidirectional{} = False
381
382 {-
383 ************************************************************************
384 * *
385 Constructing the "builder" Id
386 * *
387 ************************************************************************
388 -}
389
390 mkPatSynBuilderId :: HsPatSynDir a -> Located Name
391 -> [TyVar] -> ThetaType -> [Type] -> Type -> PatSyn
392 -> TcM (Maybe (Id, Bool))
393 mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty pat_syn
394 | isUnidirectional dir
395 = return Nothing
396 | otherwise
397 = do { builder_name <- newImplicitBinder name mkBuilderOcc
398 ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
399 builder_id =
400 -- See Note [Exported LocalIds] in Id
401 mkExportedLocalId (PatSynBuilderId pat_syn)
402 builder_name builder_sigma
403 ; return (Just (builder_id, need_dummy_arg)) }
404 where
405 builder_arg_tys | need_dummy_arg = [voidPrimTy]
406 | otherwise = arg_tys
407 need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta
408
409 tcPatSynBuilderBind :: PatSynBind Name Name
410 -> TcM (LHsBinds Id)
411 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
412 tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
413 , psb_dir = dir, psb_args = details }
414 | isUnidirectional dir
415 = return emptyBag
416
417 | isNothing mb_match_group -- Can't invert the pattern
418 = setSrcSpan (getLoc lpat) $ failWithTc $
419 hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
420 2 (ppr lpat)
421
422 | otherwise -- Bidirectional
423 = do { patsyn <- tcLookupPatSyn name
424 ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
425 -- Bidirectional, so patSynBuilder returns Just
426
427 match_group' | need_dummy_arg = add_dummy_arg match_group
428 | otherwise = match_group
429
430 bind = FunBind { fun_id = L loc (idName builder_id)
431 , fun_infix = False
432 , fun_matches = match_group'
433 , fun_co_fn = idHsWrapper
434 , bind_fvs = placeHolderNamesTc
435 , fun_tick = [] }
436
437 ; sig <- instTcTySigFromId builder_id
438 -- See Note [Redundant constraints for builder]
439
440 ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
441 ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
442 ; return builder_binds }
443 where
444 Just match_group = mb_match_group
445 mb_match_group
446 = case dir of
447 Unidirectional -> Nothing
448 ExplicitBidirectional explicit_mg -> Just explicit_mg
449 ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
450
451 mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
452 mk_mg body = mkMatchGroupName Generated [builder_match]
453 where
454 builder_args = [L loc (VarPat n) | L loc n <- args]
455 builder_match = mkMatch builder_args body EmptyLocalBinds
456
457 args = case details of
458 PrefixPatSyn args -> args
459 InfixPatSyn arg1 arg2 -> [arg1, arg2]
460 RecordPatSyn args -> map recordPatSynPatVar args
461
462 add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name)
463 add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] })
464 = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] }
465 add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
466 pprMatches (PatSyn :: HsMatchContext Name) other_mg
467
468 tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
469 -- The result type should be fully instantiated
470 tcPatSynBuilderOcc orig ps
471 | Just (builder_id, add_void_arg) <- builder
472 = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
473 ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
474 ; if add_void_arg
475 then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
476 , tcFunResultTy rho )
477 else return ( inst_fun, rho ) }
478
479 | otherwise -- Unidirectional
480 = nonBidirectionalErr name
481 where
482 name = patSynName ps
483 builder = patSynBuilder ps
484
485 {-
486 Note [Redundant constraints for builder]
487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
488 The builder can have redundant constraints, which are awkard to eliminate.
489 Consider
490 pattern P = Just 34
491 To match against this pattern we need (Eq a, Num a). But to build
492 (Just 34) we need only (Num a). Fortunately instTcSigFromId sets
493 sig_warn_redundant to False.
494
495 ************************************************************************
496 * *
497 Helper functions
498 * *
499 ************************************************************************
500
501 Note [As-patterns in pattern synonym definitions]
502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
503 The rationale for rejecting as-patterns in pattern synonym definitions
504 is that an as-pattern would introduce nonindependent pattern synonym
505 arguments, e.g. given a pattern synonym like:
506
507 pattern K x y = x@(Just y)
508
509 one could write a nonsensical function like
510
511 f (K Nothing x) = ...
512
513 or
514 g (K (Just True) False) = ...
515
516 Note [Type signatures and the builder expression]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 Consider
519 pattern L x = Left x :: Either [a] [b]
520
521 In tc{Infer/Check}PatSynDecl we will check that the pattern has the
522 specified type. We check the pattern *as a pattern*, so the type
523 signature is a pattern signature, and so brings 'a' and 'b' into
524 scope. But we don't have a way to bind 'a, b' in the LHS, as we do
525 'x', say. Nevertheless, the sigature may be useful to constrain
526 the type.
527
528 When making the binding for the *builder*, though, we don't want
529 $buildL x = Left x :: Either [a] [b]
530 because that wil either mean (forall a b. Either [a] [b]), or we'll
531 get a complaint that 'a' and 'b' are out of scope. (Actually the
532 latter; Trac #9867.) No, the job of the signature is done, so when
533 converting the pattern to an expression (for the builder RHS) we
534 simply discard the signature.
535
536 Note [Record PatSyn Desugaring]
537 -------------------------------
538
539 It is important that prov_theta comes before req_theta as this ordering is used
540 when desugaring record pattern synonym updates.
541
542 Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
543 want to avoid difficult to decipher core lint errors!
544 -}
545
546 tcCheckPatSynPat :: LPat Name -> TcM ()
547 tcCheckPatSynPat = go
548 where
549 go :: LPat Name -> TcM ()
550 go = addLocM go1
551
552 go1 :: Pat Name -> TcM ()
553 go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
554 go1 VarPat{} = return ()
555 go1 WildPat{} = return ()
556 go1 p@(AsPat _ _) = asPatInPatSynErr p
557 go1 (LazyPat pat) = go pat
558 go1 (ParPat pat) = go pat
559 go1 (BangPat pat) = go pat
560 go1 (PArrPat pats _) = mapM_ go pats
561 go1 (ListPat pats _ _) = mapM_ go pats
562 go1 (TuplePat pats _ _) = mapM_ go pats
563 go1 LitPat{} = return ()
564 go1 NPat{} = return ()
565 go1 (SigPatIn pat _) = go pat
566 go1 (ViewPat _ pat _) = go pat
567 go1 p@SplicePat{} = thInPatSynErr p
568 go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
569 go1 ConPatOut{} = panic "ConPatOut in output of renamer"
570 go1 SigPatOut{} = panic "SigPatOut in output of renamer"
571 go1 CoPat{} = panic "CoPat in output of renamer"
572
573 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
574 asPatInPatSynErr pat
575 = failWithTc $
576 hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
577 2 (ppr pat)
578
579 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
580 thInPatSynErr pat
581 = failWithTc $
582 hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
583 2 (ppr pat)
584
585 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
586 nPlusKPatInPatSynErr pat
587 = failWithTc $
588 hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
589 2 (ppr pat)
590
591 nonBidirectionalErr :: Outputable name => name -> TcM a
592 nonBidirectionalErr name = failWithTc $
593 ptext (sLit "non-bidirectional pattern synonym")
594 <+> quotes (ppr name) <+> ptext (sLit "used in an expression")
595
596 tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
597 tcPatToExpr args = go
598 where
599 lhsVars = mkNameSet (map unLoc args)
600
601 go :: LPat Name -> Maybe (LHsExpr Name)
602 go (L loc (ConPatIn (L _ con) info))
603 = do { exprs <- mapM go (hsConPatArgs info)
604 ; return $ L loc $
605 foldl (\x y -> HsApp (L loc x) y) (HsVar con) exprs }
606
607 go (L _ (SigPatIn pat _)) = go pat
608 -- See Note [Type signatures and the builder expression]
609
610 go (L loc p) = fmap (L loc) $ go1 p
611
612 go1 :: Pat Name -> Maybe (HsExpr Name)
613 go1 (VarPat var)
614 | var `elemNameSet` lhsVars = return $ HsVar var
615 | otherwise = Nothing
616 go1 (LazyPat pat) = fmap HsPar $ go pat
617 go1 (ParPat pat) = fmap HsPar $ go pat
618 go1 (BangPat pat) = fmap HsPar $ go pat
619 go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
620 ; return $ ExplicitPArr ptt exprs }
621 go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats
622 ; return $ ExplicitList ptt (fmap snd reb) exprs }
623 go1 (TuplePat pats box _) = do { exprs <- mapM go pats
624 ; return $ ExplicitTuple
625 (map (noLoc . Present) exprs) box }
626 go1 (LitPat lit) = return $ HsLit lit
627 go1 (NPat (L _ n) Nothing _) = return $ HsOverLit n
628 go1 (NPat (L _ n) (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
629 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
630 go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
631 go1 (CoPat{}) = panic "CoPat in output of renamer"
632 go1 _ = Nothing
633
634 -- Walk the whole pattern and for all ConPatOuts, collect the
635 -- existentially-bound type variables and evidence binding variables.
636 --
637 -- These are used in computing the type of a pattern synonym and also
638 -- in generating matcher functions, since success continuations need
639 -- to be passed these pattern-bound evidences.
640 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
641 tcCollectEx = return . go
642 where
643 go :: LPat Id -> (TyVarSet, [EvVar])
644 go = go1 . unLoc
645
646 go1 :: Pat Id -> (TyVarSet, [EvVar])
647 go1 (LazyPat p) = go p
648 go1 (AsPat _ p) = go p
649 go1 (ParPat p) = go p
650 go1 (BangPat p) = go p
651 go1 (ListPat ps _ _) = mconcat . map go $ ps
652 go1 (TuplePat ps _ _) = mconcat . map go $ ps
653 go1 (PArrPat ps _) = mconcat . map go $ ps
654 go1 (ViewPat _ p _) = go p
655 go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
656 goConDetails $ pat_args con
657 go1 (SigPatOut p _) = go p
658 go1 (CoPat _ p _) = go1 p
659 go1 (NPlusKPat n k geq subtract)
660 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
661 go1 _ = mempty
662
663 goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
664 goConDetails (PrefixCon ps) = mconcat . map go $ ps
665 goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
666 goConDetails (RecCon HsRecFields{ rec_flds = flds })
667 = mconcat . map goRecFd $ flds
668
669 goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
670 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p