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