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