f1db883509f821f33b83c5e5cd0d2b3c797b76cc
[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 VanillaId 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 =
372 map (mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps)) fields
373
374 isUnidirectional :: HsPatSynDir a -> Bool
375 isUnidirectional Unidirectional = True
376 isUnidirectional ImplicitBidirectional = False
377 isUnidirectional ExplicitBidirectional{} = False
378
379 {-
380 ************************************************************************
381 * *
382 Constructing the "builder" Id
383 * *
384 ************************************************************************
385 -}
386
387 mkPatSynBuilderId :: HsPatSynDir a -> Located Name
388 -> [TyVar] -> ThetaType -> [Type] -> Type -> PatSyn
389 -> TcM (Maybe (Id, Bool))
390 mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty pat_syn
391 | isUnidirectional dir
392 = return Nothing
393 | otherwise
394 = do { builder_name <- newImplicitBinder name mkBuilderOcc
395 ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
396 builder_id =
397 -- See Note [Exported LocalIds] in Id
398 mkExportedLocalId (PatSynBuilderId pat_syn)
399 builder_name builder_sigma
400 ; return (Just (builder_id, need_dummy_arg)) }
401 where
402 builder_arg_tys | need_dummy_arg = [voidPrimTy]
403 | otherwise = arg_tys
404 need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta
405
406 tcPatSynBuilderBind :: PatSynBind Name Name
407 -> TcM (LHsBinds Id)
408 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
409 tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
410 , psb_dir = dir, psb_args = details }
411 | isUnidirectional dir
412 = return emptyBag
413
414 | isNothing mb_match_group -- Can't invert the pattern
415 = setSrcSpan (getLoc lpat) $ failWithTc $
416 hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
417 2 (ppr lpat)
418
419 | otherwise -- Bidirectional
420 = do { patsyn <- tcLookupPatSyn name
421 ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
422 -- Bidirectional, so patSynBuilder returns Just
423
424 match_group' | need_dummy_arg = add_dummy_arg match_group
425 | otherwise = match_group
426
427 bind = FunBind { fun_id = L loc (idName builder_id)
428 , fun_infix = False
429 , fun_matches = match_group'
430 , fun_co_fn = idHsWrapper
431 , bind_fvs = placeHolderNamesTc
432 , fun_tick = [] }
433
434 ; sig <- instTcTySigFromId builder_id
435 -- See Note [Redundant constraints for builder]
436
437 ; (builder_binds, _) <- tcPolyCheck NonRecursive emptyPragEnv sig (noLoc bind)
438 ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
439 ; return builder_binds }
440 where
441 Just match_group = mb_match_group
442 mb_match_group
443 = case dir of
444 Unidirectional -> Nothing
445 ExplicitBidirectional explicit_mg -> Just explicit_mg
446 ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
447
448 mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
449 mk_mg body = mkMatchGroupName Generated [builder_match]
450 where
451 builder_args = [L loc (VarPat n) | L loc n <- args]
452 builder_match = mkMatch builder_args body EmptyLocalBinds
453
454 args = case details of
455 PrefixPatSyn args -> args
456 InfixPatSyn arg1 arg2 -> [arg1, arg2]
457 RecordPatSyn args -> map recordPatSynPatVar args
458
459 add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name)
460 add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] })
461 = mg { mg_alts = [L loc (Match Nothing [nlWildPatName] ty grhss)] }
462 add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
463 pprMatches (PatSyn :: HsMatchContext Name) other_mg
464
465 tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
466 -- The result type should be fully instantiated
467 tcPatSynBuilderOcc orig ps
468 | Just (builder_id, add_void_arg) <- builder
469 = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
470 ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
471 ; if add_void_arg
472 then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
473 , tcFunResultTy rho )
474 else return ( inst_fun, rho ) }
475
476 | otherwise -- Unidirectional
477 = nonBidirectionalErr name
478 where
479 name = patSynName ps
480 builder = patSynBuilder ps
481
482 {-
483 Note [Redundant constraints for builder]
484 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
485 The builder can have redundant constraints, which are awkard to eliminate.
486 Consider
487 pattern P = Just 34
488 To match against this pattern we need (Eq a, Num a). But to build
489 (Just 34) we need only (Num a). Fortunately instTcSigFromId sets
490 sig_warn_redundant to False.
491
492 ************************************************************************
493 * *
494 Helper functions
495 * *
496 ************************************************************************
497
498 Note [As-patterns in pattern synonym definitions]
499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
500 The rationale for rejecting as-patterns in pattern synonym definitions
501 is that an as-pattern would introduce nonindependent pattern synonym
502 arguments, e.g. given a pattern synonym like:
503
504 pattern K x y = x@(Just y)
505
506 one could write a nonsensical function like
507
508 f (K Nothing x) = ...
509
510 or
511 g (K (Just True) False) = ...
512
513 Note [Type signatures and the builder expression]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 Consider
516 pattern L x = Left x :: Either [a] [b]
517
518 In tc{Infer/Check}PatSynDecl we will check that the pattern has the
519 specified type. We check the pattern *as a pattern*, so the type
520 signature is a pattern signature, and so brings 'a' and 'b' into
521 scope. But we don't have a way to bind 'a, b' in the LHS, as we do
522 'x', say. Nevertheless, the sigature may be useful to constrain
523 the type.
524
525 When making the binding for the *builder*, though, we don't want
526 $buildL x = Left x :: Either [a] [b]
527 because that wil either mean (forall a b. Either [a] [b]), or we'll
528 get a complaint that 'a' and 'b' are out of scope. (Actually the
529 latter; Trac #9867.) No, the job of the signature is done, so when
530 converting the pattern to an expression (for the builder RHS) we
531 simply discard the signature.
532
533 Note [Record PatSyn Desugaring]
534 -------------------------------
535
536 It is important that prov_theta comes before req_theta as this ordering is used
537 when desugaring record pattern synonym updates.
538
539 Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
540 want to avoid difficult to decipher core lint errors!
541 -}
542
543 tcCheckPatSynPat :: LPat Name -> TcM ()
544 tcCheckPatSynPat = go
545 where
546 go :: LPat Name -> TcM ()
547 go = addLocM go1
548
549 go1 :: Pat Name -> TcM ()
550 go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
551 go1 VarPat{} = return ()
552 go1 WildPat{} = return ()
553 go1 p@(AsPat _ _) = asPatInPatSynErr p
554 go1 (LazyPat pat) = go pat
555 go1 (ParPat pat) = go pat
556 go1 (BangPat pat) = go pat
557 go1 (PArrPat pats _) = mapM_ go pats
558 go1 (ListPat pats _ _) = mapM_ go pats
559 go1 (TuplePat pats _ _) = mapM_ go pats
560 go1 LitPat{} = return ()
561 go1 NPat{} = return ()
562 go1 (SigPatIn pat _) = go pat
563 go1 (ViewPat _ pat _) = go pat
564 go1 p@SplicePat{} = thInPatSynErr p
565 go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
566 go1 ConPatOut{} = panic "ConPatOut in output of renamer"
567 go1 SigPatOut{} = panic "SigPatOut in output of renamer"
568 go1 CoPat{} = panic "CoPat in output of renamer"
569
570 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
571 asPatInPatSynErr pat
572 = failWithTc $
573 hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
574 2 (ppr pat)
575
576 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
577 thInPatSynErr pat
578 = failWithTc $
579 hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
580 2 (ppr pat)
581
582 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
583 nPlusKPatInPatSynErr pat
584 = failWithTc $
585 hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
586 2 (ppr pat)
587
588 nonBidirectionalErr :: Outputable name => name -> TcM a
589 nonBidirectionalErr name = failWithTc $
590 ptext (sLit "non-bidirectional pattern synonym")
591 <+> quotes (ppr name) <+> ptext (sLit "used in an expression")
592
593 tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
594 tcPatToExpr args = go
595 where
596 lhsVars = mkNameSet (map unLoc args)
597
598 go :: LPat Name -> Maybe (LHsExpr Name)
599 go (L loc (ConPatIn (L _ con) info))
600 = do { exprs <- mapM go (hsConPatArgs info)
601 ; return $ L loc $
602 foldl (\x y -> HsApp (L loc x) y) (HsVar con) exprs }
603
604 go (L _ (SigPatIn pat _)) = go pat
605 -- See Note [Type signatures and the builder expression]
606
607 go (L loc p) = fmap (L loc) $ go1 p
608
609 go1 :: Pat Name -> Maybe (HsExpr Name)
610 go1 (VarPat var)
611 | var `elemNameSet` lhsVars = return $ HsVar var
612 | otherwise = Nothing
613 go1 (LazyPat pat) = fmap HsPar $ go pat
614 go1 (ParPat pat) = fmap HsPar $ go pat
615 go1 (BangPat pat) = fmap HsPar $ go pat
616 go1 (PArrPat pats ptt) = do { exprs <- mapM go pats
617 ; return $ ExplicitPArr ptt exprs }
618 go1 (ListPat pats ptt reb) = do { exprs <- mapM go pats
619 ; return $ ExplicitList ptt (fmap snd reb) exprs }
620 go1 (TuplePat pats box _) = do { exprs <- mapM go pats
621 ; return $ ExplicitTuple
622 (map (noLoc . Present) exprs) box }
623 go1 (LitPat lit) = return $ HsLit lit
624 go1 (NPat (L _ n) Nothing _) = return $ HsOverLit n
625 go1 (NPat (L _ n) (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
626 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
627 go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
628 go1 (CoPat{}) = panic "CoPat in output of renamer"
629 go1 _ = Nothing
630
631 -- Walk the whole pattern and for all ConPatOuts, collect the
632 -- existentially-bound type variables and evidence binding variables.
633 --
634 -- These are used in computing the type of a pattern synonym and also
635 -- in generating matcher functions, since success continuations need
636 -- to be passed these pattern-bound evidences.
637 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
638 tcCollectEx = return . go
639 where
640 go :: LPat Id -> (TyVarSet, [EvVar])
641 go = go1 . unLoc
642
643 go1 :: Pat Id -> (TyVarSet, [EvVar])
644 go1 (LazyPat p) = go p
645 go1 (AsPat _ p) = go p
646 go1 (ParPat p) = go p
647 go1 (BangPat p) = go p
648 go1 (ListPat ps _ _) = mconcat . map go $ ps
649 go1 (TuplePat ps _ _) = mconcat . map go $ ps
650 go1 (PArrPat ps _) = mconcat . map go $ ps
651 go1 (ViewPat _ p _) = go p
652 go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
653 goConDetails $ pat_args con
654 go1 (SigPatOut p _) = go p
655 go1 (CoPat _ p _) = go1 p
656 go1 (NPlusKPat n k geq subtract)
657 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
658 go1 _ = mempty
659
660 goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
661 goConDetails (PrefixCon ps) = mconcat . map go $ ps
662 goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
663 goConDetails (RecCon HsRecFields{ rec_flds = flds })
664 = mconcat . map goRecFd $ flds
665
666 goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
667 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p