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