fcea649d01539955e40183fbb9894c157be8cb1c
[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 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
13 , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr
14 ) where
15
16 import GhcPrelude
17
18 import HsSyn
19 import TcPat
20 import Type( mkEmptyTCvSubst, tidyTyVarBinders, tidyTypes, tidyType )
21 import TcRnMonad
22 import TcSigs( emptyPragEnv, completeSigFromId )
23 import TcType( mkMinimalBySCs )
24 import TcEnv
25 import TcMType
26 import TcHsSyn( zonkTyVarBindersX, zonkTcTypeToTypes
27 , zonkTcTypeToType, emptyZonkEnv )
28 import TysPrim
29 import TysWiredIn ( runtimeRepTy )
30 import Name
31 import SrcLoc
32 import PatSyn
33 import NameSet
34 import Panic
35 import Outputable
36 import FastString
37 import Var
38 import VarEnv( emptyTidyEnv, mkInScopeSet )
39 import Id
40 import IdInfo( RecSelParent(..), setLevityInfoWithType )
41 import TcBinds
42 import BasicTypes
43 import TcSimplify
44 import TcUnify
45 import TcType
46 import TcEvidence
47 import BuildTyCl
48 import VarSet
49 import MkId
50 import TcTyDecls
51 import ConLike
52 import FieldLabel
53 import Bag
54 import Util
55 import ErrUtils
56 import Control.Monad ( zipWithM )
57 import Data.List( partition )
58
59 #include "HsVersions.h"
60
61 {-
62 ************************************************************************
63 * *
64 Type checking a pattern synonym
65 * *
66 ************************************************************************
67 -}
68
69 tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
70 -> TcM (LHsBinds GhcTc, TcGblEnv)
71 tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
72 psb_def = lpat, psb_dir = dir }
73 = addPatSynCtxt lname $
74 do { traceTc "tcInferPatSynDecl {" $ ppr name
75
76 ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
77 ; (tclvl, wanted, ((lpat', args), pat_ty))
78 <- pushLevelAndCaptureConstraints $
79 tcInferNoInst $ \ exp_ty ->
80 tcPat PatSyn lpat exp_ty $
81 mapM tcLookupId arg_names
82
83 ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
84
85 ; (qtvs, req_dicts, ev_binds, _) <- simplifyInfer tclvl NoRestrictions []
86 named_taus wanted
87
88 ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
89 ex_tv_set = mkVarSet ex_tvs
90 univ_tvs = filterOut (`elemVarSet` ex_tv_set) qtvs
91 req_theta = map evVarPred req_dicts
92
93 ; prov_dicts <- mapM zonkId prov_dicts
94 ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
95 prov_theta = map evVarPred filtered_prov_dicts
96 -- Filtering: see Note [Remove redundant provided dicts]
97
98 -- Report bad universal type variables
99 -- See Note [Type variables whose kind is captured]
100 ; let bad_tvs = [ tv | tv <- univ_tvs
101 , tyCoVarsOfType (tyVarKind tv)
102 `intersectsVarSet` ex_tv_set ]
103 ; mapM_ (badUnivTvErr ex_tvs) bad_tvs
104
105 -- Report coercions that esacpe
106 -- See Note [Coercions that escape]
107 ; args <- mapM zonkId args
108 ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
109 , let bad_cos = filterDVarSet isId $
110 (tyCoVarsOfTypeDSet (idType arg))
111 , not (isEmptyDVarSet bad_cos) ]
112 ; mapM_ dependentArgErr bad_args
113
114 ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
115 ; tc_patsyn_finish lname dir is_infix lpat'
116 (mkTyVarBinders Inferred univ_tvs
117 , req_theta, ev_binds, req_dicts)
118 (mkTyVarBinders Inferred ex_tvs
119 , mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts)
120 (map nlHsVar args, map idType args)
121 pat_ty rec_fields }
122 tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
123
124 badUnivTvErr :: [TyVar] -> TyVar -> TcM ()
125 -- See Note [Type variables whose kind is captured]
126 badUnivTvErr ex_tvs bad_tv
127 = addErrTc $
128 vcat [ text "Universal type variable" <+> quotes (ppr bad_tv)
129 <+> text "has existentially bound kind:"
130 , nest 2 (ppr_with_kind bad_tv)
131 , hang (text "Existentially-bound variables:")
132 2 (vcat (map ppr_with_kind ex_tvs))
133 , text "Probable fix: give the pattern synoym a type signature"
134 ]
135 where
136 ppr_with_kind tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
137
138 dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
139 -- See Note [Coercions that escape]
140 dependentArgErr (arg, bad_cos)
141 = addErrTc $
142 vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
143 , hang (text "Pattern-bound variable")
144 2 (ppr arg <+> dcolon <+> ppr (idType arg))
145 , nest 2 $
146 hang (text "has a type that mentions pattern-bound coercion"
147 <> plural bad_co_list <> colon)
148 2 (pprWithCommas ppr bad_co_list)
149 , text "Hint: use -fprint-explicit-coercions to see the coercions"
150 , text "Probable fix: add a pattern signature" ]
151 where
152 bad_co_list = dVarSetElems bad_cos
153
154 {- Note [Remove redundant provided dicts]
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 Recall that
157 HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
158 => a1 :~~: a2
159 (NB: technically the (k1~k2) existential dictionary is not necessary,
160 but it's there at the moment.)
161
162 Now consider (Trac #14394):
163 pattern Foo = HRefl
164 in a non-poly-kinded module. We don't want to get
165 pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
166 with that redundant (* ~ *). We'd like to remove it; hence the call to
167 mkMinimalWithSCs.
168
169 Similarly consider
170 data S a where { MkS :: Ord a => a -> S a }
171 pattern Bam x y <- (MkS (x::a), MkS (y::a)))
172
173 The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
174 need one. Agian mkMimimalWithSCs removes the redundant one.
175
176 Note [Type variables whose kind is captured]
177 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
178 Consider
179 data AST a = Sym [a]
180 class Prj s where { prj :: [a] -> Maybe (s a)
181 pattern P x <= Sym (prj -> Just x)
182
183 Here we get a matcher with this type
184 $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
185
186 No problem. But note that 's' is not fixed by the type of the
187 pattern (AST a), nor is it existentially bound. It's really only
188 fixed by the type of the continuation.
189
190 Trac #14552 showed that this can go wrong if the kind of 's' mentions
191 existentially bound variables. We obviously can't make a type like
192 $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
193 -> r -> r
194 But neither is 's' itself existentially bound, so the forall (s::k->*)
195 can't go in the inner forall either. (What would the matcher apply
196 the continuation to?)
197
198 So we just fail in this case, with a pretty terrible error message.
199 Maybe we could do better, but I can't see how. (It'd be possible to
200 default 's' to (Any k), but that probably isn't what the user wanted,
201 and it not straightforward to implement, because by the time we see
202 the problem, simplifyInfer has already skolemised 's'.)
203
204 This stuff can only happen in the presence of view patterns, with
205 TypeInType, so it's a bit of a corner case.
206
207 Note [Coercions that escape]
208 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
209 Trac #14507 showed an example where the inferred type of the matcher
210 for the pattern synonym was somethign like
211 $mSO :: forall (r :: TYPE rep) kk (a :: k).
212 TypeRep k a
213 -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
214 -> (Void# -> r)
215 -> r
216
217 What is that co_a2sv :: Bool ~# *?? It was bound (via a superclass
218 selection) by the pattern being matched; and indeed it is implicit in
219 the context (Bool ~ k). You could imagine trying to extract it like
220 this:
221 $mSO :: forall (r :: TYPE rep) kk (a :: k).
222 TypeRep k a
223 -> ( co :: ((Bool :: *) ~ (k :: *)) =>
224 let co_a2sv = sc_sel co
225 in TypeRep Bool (a |> co_a2sv) -> r)
226 -> (Void# -> r)
227 -> r
228
229 But we simply don't allow that in types. Maybe one day but not now.
230
231 How to detect this situation? We just look for free coercion variables
232 in the types of any of the arguments to the matcher. The error message
233 is not very helpful, but at least we don't get a Lint error.
234 -}
235
236 tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
237 -> TcPatSynInfo
238 -> TcM (LHsBinds GhcTc, TcGblEnv)
239 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
240 , psb_def = lpat, psb_dir = dir }
241 TPSI{ patsig_implicit_bndrs = implicit_tvs
242 , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
243 , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta
244 , patsig_body_ty = sig_body_ty }
245 = addPatSynCtxt lname $
246 do { let decl_arity = length arg_names
247 (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
248
249 ; traceTc "tcCheckPatSynDecl" $
250 vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
251 , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
252
253 ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
254 Right stuff -> return stuff
255 Left missing -> wrongNumberOfParmsErr name decl_arity missing
256
257 -- Complain about: pattern P :: () => forall x. x -> P x
258 -- The existential 'x' should not appear in the result type
259 -- Can't check this until we know P's arity
260 ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
261 ; checkTc (null bad_tvs) $
262 hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
263 , text "namely" <+> quotes (ppr pat_ty) ])
264 2 (text "mentions existential type variable" <> plural bad_tvs
265 <+> pprQuotedList bad_tvs)
266
267 -- See Note [The pattern-synonym signature splitting rule] in TcSigs
268 ; let univ_fvs = closeOverKinds $
269 (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
270 (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
271 univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
272 ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs
273 univ_tvs = binderVars univ_bndrs
274 ex_tvs = binderVars ex_bndrs
275
276 -- Right! Let's check the pattern against the signature
277 -- See Note [Checking against a pattern signature]
278 ; req_dicts <- newEvVars req_theta
279 ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
280 ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
281 pushLevelAndCaptureConstraints $
282 tcExtendTyVarEnv univ_tvs $
283 tcExtendKindEnvList [(getName (binderVar ex_tv), APromotionErr PatSynExPE)
284 | ex_tv <- extra_ex] $
285 -- See Note [Pattern synonym existentials do not scope]
286 tcPat PatSyn lpat (mkCheckExpType pat_ty) $
287 do { let in_scope = mkInScopeSet (mkVarSet univ_tvs)
288 empty_subst = mkEmptyTCvSubst in_scope
289 ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
290 -- newMetaTyVarX: see the "Existential type variables"
291 -- part of Note [Checking against a pattern signature]
292 ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
293 ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
294 ; let prov_theta' = substTheta subst prov_theta
295 -- Add univ_tvs to the in_scope set to
296 -- satisfy the substitution invariant. There's no need to
297 -- add 'ex_tvs' as they are already in the domain of the
298 -- substitution.
299 -- See also Note [The substitution invariant] in TyCoRep.
300 ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
301 ; args' <- zipWithM (tc_arg subst) arg_names arg_tys
302 ; return (ex_tvs', prov_dicts, args') }
303
304 ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
305 -- The type here is a bit bogus, but we do not print
306 -- the type for PatSynCtxt, so it doesn't matter
307 -- See TcRnTypes Note [Skolem info for pattern synonyms]
308 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
309
310 -- Solve the constraints now, because we are about to make a PatSyn,
311 -- which should not contain unification variables and the like (Trac #10997)
312 ; simplifyTopImplic implics
313
314 -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
315 -- Otherwise we may get a type error when typechecking the builder,
316 -- when that should be impossible
317
318 ; traceTc "tcCheckPatSynDecl }" $ ppr name
319 ; tc_patsyn_finish lname dir is_infix lpat'
320 (univ_bndrs, req_theta, ev_binds, req_dicts)
321 (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
322 (args', arg_tys)
323 pat_ty rec_fields }
324 where
325 tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
326 tc_arg subst arg_name arg_ty
327 = do { -- Look up the variable actually bound by lpat
328 -- and check that it has the expected type
329 arg_id <- tcLookupId arg_name
330 ; wrap <- tcSubType_NC GenSigCtxt
331 (idType arg_id)
332 (substTyUnchecked subst arg_ty)
333 -- Why do we need tcSubType here?
334 -- See Note [Pattern synonyms and higher rank types]
335 ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
336 tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
337
338 {- [Pattern synonyms and higher rank types]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 Consider
341 data T = MkT (forall a. a->a)
342
343 pattern P :: (Int -> Int) -> T
344 pattern P x <- MkT x
345
346 This should work. But in the matcher we must match against MkT, and then
347 instantiate its argument 'x', to get a function of type (Int -> Int).
348 Equality is not enough! Trac #13752 was an example.
349
350 Note [Pattern synonym existentials do not scope]
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 Consider this (Trac #14498):
353 pattern SS :: forall (t :: k). () =>
354 => forall (a :: kk -> k) (n :: kk).
355 => TypeRep n -> TypeRep t
356 pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)
357
358 Here 'k' is implicitly bound in the signature, but (with
359 -XScopedTypeVariables) it does still scope over the pattern-synonym
360 definition. But what about 'kk', which is oexistential? It too is
361 implicitly bound in the signature; should it too scope? And if so,
362 what type variable is it bound to?
363
364 The trouble is that the type variable to which it is bound is itself
365 only brought into scope in part the pattern, so it makes no sense for
366 'kk' to scope over the whole pattern. See the discussion on
367 Trac #14498, esp comment:16ff. Here is a simpler example:
368 data T where { MkT :: x -> (x->Int) -> T }
369 pattern P :: () => forall x. x -> (x->Int) -> T
370 pattern P a b = (MkT a b, True)
371
372 Here it would make no sense to mention 'x' in the True pattern,
373 like this:
374 pattern P a b = (MkT a b, True :: x)
375
376 The 'x' only makes sense "under" the MkT pattern. Conclusion: the
377 existential type variables of a pattern-synonym signature should not
378 scope.
379
380 But it's not that easy to implement, because we don't know
381 exactly what the existentials /are/ until we get to type checking.
382 (See Note [The pattern-synonym signature splitting rule], and
383 the partition of implicit_tvs in tcCheckPatSynDecl.)
384
385 So we do this:
386
387 - The reaner brings all the implicitly-bound kind variables into
388 scope, without trying to distinguish universal from existential
389
390 - tcCheckPatSynDecl uses tcExtendKindEnvList to bind the
391 implicitly-bound existentials to
392 APromotionErr PatSynExPE
393 It's not really a promotion error, but it's a way to bind the Name
394 (which the renamer has not complained about) to something that, when
395 looked up, will cause a complaint (in this case
396 TcHsType.promotionErr)
397
398
399 Note [The pattern-synonym signature splitting rule]
400 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
401 Given a pattern signature, we must split
402 the kind-generalised variables, and
403 the implicitly-bound variables
404 into universal and existential. The rule is this
405 (see discussion on Trac #11224):
406
407 The universal tyvars are the ones mentioned in
408 - univ_tvs: the user-specified (forall'd) universals
409 - req_theta
410 - res_ty
411 The existential tyvars are all the rest
412
413 For example
414
415 pattern P :: () => b -> T a
416 pattern P x = ...
417
418 Here 'a' is universal, and 'b' is existential. But there is a wrinkle:
419 how do we split the arg_tys from req_ty? Consider
420
421 pattern Q :: () => b -> S c -> T a
422 pattern Q x = ...
423
424 This is an odd example because Q has only one syntactic argument, and
425 so presumably is defined by a view pattern matching a function. But
426 it can happen (Trac #11977, #12108).
427
428 We don't know Q's arity from the pattern signature, so we have to wait
429 until we see the pattern declaration itself before deciding res_ty is,
430 and hence which variables are existential and which are universal.
431
432 And that in turn is why TcPatSynInfo has a separate field,
433 patsig_implicit_bndrs, to capture the implicitly bound type variables,
434 because we don't yet know how to split them up.
435
436 It's a slight compromise, because it means we don't really know the
437 pattern synonym's real signature until we see its declaration. So,
438 for example, in hs-boot file, we may need to think what to do...
439 (eg don't have any implicitly-bound variables).
440
441
442 Note [Checking against a pattern signature]
443 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
444 When checking the actual supplied pattern against the pattern synonym
445 signature, we need to be quite careful.
446
447 ----- Provided constraints
448 Example
449
450 data T a where
451 MkT :: Ord a => a -> T a
452
453 pattern P :: () => Eq a => a -> [T a]
454 pattern P x = [MkT x]
455
456 We must check that the (Eq a) that P claims to bind (and to
457 make available to matches against P), is derivable from the
458 actual pattern. For example:
459 f (P (x::a)) = ...here (Eq a) should be available...
460 And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
461
462 ----- Existential type variables
463 Unusually, we instantiate the existential tyvars of the pattern with
464 *meta* type variables. For example
465
466 data S where
467 MkS :: Eq a => [a] -> S
468
469 pattern P :: () => Eq x => x -> S
470 pattern P x <- MkS x
471
472 The pattern synonym conceals from its client the fact that MkS has a
473 list inside it. The client just thinks it's a type 'x'. So we must
474 unify x := [a] during type checking, and then use the instantiating type
475 [a] (called ex_tys) when building the matcher. In this case we'll get
476
477 $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
478 $mP x k = case x of
479 MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
480 dl = $dfunEqList d
481 in k [a] dl ys
482
483 All this applies when type-checking the /matching/ side of
484 a pattern synonym. What about the /building/ side?
485
486 * For Unidirectional, there is no builder
487
488 * For ExplicitBidirectional, the builder is completely separate
489 code, typechecked in tcPatSynBuilderBind
490
491 * For ImplicitBidirectional, the builder is still typechecked in
492 tcPatSynBuilderBind, by converting the pattern to an expression and
493 typechecking it.
494
495 At one point, for ImplicitBidirectional I used SigTvs (instead of
496 TauTvs) in tcCheckPatSynDecl. But (a) strengthening the check here
497 is redundant since tcPatSynBuilderBind does the job, (b) it was
498 still incomplete (SigTvs can unify with each other), and (c) it
499 didn't even work (Trac #13441 was accepted with
500 ExplicitBidirectional, but rejected if expressed in
501 ImplicitBidirectional form. Conclusion: trying to be too clever is
502 a bad idea.
503 -}
504
505 collectPatSynArgInfo :: HsPatSynDetails (Located Name)
506 -> ([Name], [Name], Bool)
507 collectPatSynArgInfo details =
508 case details of
509 PrefixCon names -> (map unLoc names, [], False)
510 InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
511 RecCon names -> (vars, sels, False)
512 where
513 (vars, sels) = unzip (map splitRecordPatSyn names)
514 where
515 splitRecordPatSyn :: RecordPatSynField (Located Name)
516 -> (Name, Name)
517 splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar
518 , recordPatSynSelectorId = L _ selId })
519 = (patVar, selId)
520
521 addPatSynCtxt :: Located Name -> TcM a -> TcM a
522 addPatSynCtxt (L loc name) thing_inside
523 = setSrcSpan loc $
524 addErrCtxt (text "In the declaration for pattern synonym"
525 <+> quotes (ppr name)) $
526 thing_inside
527
528 wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
529 wrongNumberOfParmsErr name decl_arity missing
530 = failWithTc $
531 hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
532 <+> speakNOf decl_arity (text "argument"))
533 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
534
535 -------------------------
536 -- Shared by both tcInferPatSyn and tcCheckPatSyn
537 tc_patsyn_finish :: Located Name -- ^ PatSyn Name
538 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
539 -> Bool -- ^ Whether infix
540 -> LPat GhcTc -- ^ Pattern of the PatSyn
541 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
542 -> ([TcTyVarBinder], [TcType], [PredType], [EvExpr])
543 -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and
544 -- types
545 -> TcType -- ^ Pattern type
546 -> [Name] -- ^ Selector names
547 -- ^ Whether fields, empty if not record PatSyn
548 -> TcM (LHsBinds GhcTc, TcGblEnv)
549 tc_patsyn_finish lname dir is_infix lpat'
550 (univ_tvs, req_theta, req_ev_binds, req_dicts)
551 (ex_tvs, ex_tys, prov_theta, prov_dicts)
552 (args, arg_tys)
553 pat_ty field_labels
554 = do { -- Zonk everything. We are about to build a final PatSyn
555 -- so there had better be no unification variables in there
556
557 (ze, univ_tvs') <- zonkTyVarBindersX emptyZonkEnv univ_tvs
558 ; req_theta' <- zonkTcTypeToTypes ze req_theta
559 ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs
560 ; prov_theta' <- zonkTcTypeToTypes ze prov_theta
561 ; pat_ty' <- zonkTcTypeToType ze pat_ty
562 ; arg_tys' <- zonkTcTypeToTypes ze arg_tys
563
564 ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs'
565 (env2, ex_tvs) = tidyTyVarBinders env1 ex_tvs'
566 req_theta = tidyTypes env2 req_theta'
567 prov_theta = tidyTypes env2 prov_theta'
568 arg_tys = tidyTypes env2 arg_tys'
569 pat_ty = tidyType env2 pat_ty'
570
571 ; traceTc "tc_patsyn_finish {" $
572 ppr (unLoc lname) $$ ppr (unLoc lpat') $$
573 ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
574 ppr (ex_tvs, prov_theta, prov_dicts) $$
575 ppr args $$
576 ppr arg_tys $$
577 ppr pat_ty
578
579 -- Make the 'matcher'
580 ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
581 (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
582 (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
583 (args, arg_tys)
584 pat_ty
585
586 -- Make the 'builder'
587 ; builder_id <- mkPatSynBuilderId dir lname
588 univ_tvs req_theta
589 ex_tvs prov_theta
590 arg_tys pat_ty
591
592 -- TODO: Make this have the proper information
593 ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
594 , flIsOverloaded = False
595 , flSelector = name }
596 field_labels' = map mkFieldLabel field_labels
597
598
599 -- Make the PatSyn itself
600 ; let patSyn = mkPatSyn (unLoc lname) is_infix
601 (univ_tvs, req_theta)
602 (ex_tvs, prov_theta)
603 arg_tys
604 pat_ty
605 matcher_id builder_id
606 field_labels'
607
608 -- Selectors
609 ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
610 tything = AConLike (PatSynCon patSyn)
611 ; tcg_env <- tcExtendGlobalEnv [tything] $
612 tcRecSelBinds rn_rec_sel_binds
613
614 ; traceTc "tc_patsyn_finish }" empty
615 ; return (matcher_bind, tcg_env) }
616
617 {-
618 ************************************************************************
619 * *
620 Constructing the "matcher" Id and its binding
621 * *
622 ************************************************************************
623 -}
624
625 tcPatSynMatcher :: Located Name
626 -> LPat GhcTc
627 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
628 -> ([TcTyVar], [TcType], ThetaType, [EvExpr])
629 -> ([LHsExpr GhcTcId], [TcType])
630 -> TcType
631 -> TcM ((Id, Bool), LHsBinds GhcTc)
632 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
633 tcPatSynMatcher (L loc name) lpat
634 (univ_tvs, req_theta, req_ev_binds, req_dicts)
635 (ex_tvs, ex_tys, prov_theta, prov_dicts)
636 (args, arg_tys) pat_ty
637 = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
638 ; tv_name <- newNameAt (mkTyVarOcc "r") loc
639 ; let rr_tv = mkTyVar rr_name runtimeRepTy
640 rr = mkTyVarTy rr_tv
641 res_tv = mkTyVar tv_name (tYPE rr)
642 res_ty = mkTyVarTy res_tv
643 is_unlifted = null args && null prov_dicts
644 (cont_args, cont_arg_tys)
645 | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
646 | otherwise = (args, arg_tys)
647 cont_ty = mkInfSigmaTy ex_tvs prov_theta $
648 mkFunTys cont_arg_tys res_ty
649
650 fail_ty = mkFunTy voidPrimTy res_ty
651
652 ; matcher_name <- newImplicitBinder name mkMatcherOcc
653 ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
654 ; cont <- newSysLocalId (fsLit "cont") cont_ty
655 ; fail <- newSysLocalId (fsLit "fail") fail_ty
656
657 ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
658 matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
659 matcher_id = mkExportedVanillaId matcher_name matcher_sigma
660 -- See Note [Exported LocalIds] in Id
661
662 inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
663 cont' = foldl nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
664
665 fail' = nlHsApps fail [nlHsVar voidPrimId]
666
667 args = map nlVarPat [scrutinee, cont, fail]
668 lwpat = noLoc $ WildPat pat_ty
669 cases = if isIrrefutableHsPat lpat
670 then [mkHsCaseAlt lpat cont']
671 else [mkHsCaseAlt lpat cont',
672 mkHsCaseAlt lwpat fail']
673 body = mkLHsWrap (mkWpLet req_ev_binds) $
674 L (getLoc lpat) $
675 HsCase noExt (nlHsVar scrutinee) $
676 MG{ mg_alts = L (getLoc lpat) cases
677 , mg_ext = MatchGroupTc [pat_ty] res_ty
678 , mg_origin = Generated
679 }
680 body' = noLoc $
681 HsLam noExt $
682 MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
683 args body]
684 , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
685 , mg_origin = Generated
686 }
687 match = mkMatch (mkPrefixFunRhs (L loc name)) []
688 (mkHsLams (rr_tv:res_tv:univ_tvs)
689 req_dicts body')
690 (noLoc (EmptyLocalBinds noExt))
691 mg :: MatchGroup GhcTc (LHsExpr GhcTc)
692 mg = MG{ mg_alts = L (getLoc match) [match]
693 , mg_ext = MatchGroupTc [] res_ty
694 , mg_origin = Generated
695 }
696
697 ; let bind = FunBind{ fun_ext = emptyNameSet
698 , fun_id = L loc matcher_id
699 , fun_matches = mg
700 , fun_co_fn = idHsWrapper
701 , fun_tick = [] }
702 matcher_bind = unitBag (noLoc bind)
703
704 ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
705 ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
706
707 ; return ((matcher_id, is_unlifted), matcher_bind) }
708
709 mkPatSynRecSelBinds :: PatSyn
710 -> [FieldLabel] -- ^ Visible field labels
711 -> HsValBinds GhcRn
712 mkPatSynRecSelBinds ps fields
713 = XValBindsLR (NValBinds selector_binds sigs)
714 where
715 (sigs, selector_binds) = unzip (map mkRecSel fields)
716 mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
717
718 isUnidirectional :: HsPatSynDir a -> Bool
719 isUnidirectional Unidirectional = True
720 isUnidirectional ImplicitBidirectional = False
721 isUnidirectional ExplicitBidirectional{} = False
722
723 {-
724 ************************************************************************
725 * *
726 Constructing the "builder" Id
727 * *
728 ************************************************************************
729 -}
730
731 mkPatSynBuilderId :: HsPatSynDir a -> Located Name
732 -> [TyVarBinder] -> ThetaType
733 -> [TyVarBinder] -> ThetaType
734 -> [Type] -> Type
735 -> TcM (Maybe (Id, Bool))
736 mkPatSynBuilderId dir (L _ name)
737 univ_bndrs req_theta ex_bndrs prov_theta
738 arg_tys pat_ty
739 | isUnidirectional dir
740 = return Nothing
741 | otherwise
742 = do { builder_name <- newImplicitBinder name mkBuilderOcc
743 ; let theta = req_theta ++ prov_theta
744 need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
745 builder_sigma = add_void need_dummy_arg $
746 mkForAllTys univ_bndrs $
747 mkForAllTys ex_bndrs $
748 mkFunTys theta $
749 mkFunTys arg_tys $
750 pat_ty
751 builder_id = mkExportedVanillaId builder_name builder_sigma
752 -- See Note [Exported LocalIds] in Id
753
754 builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
755
756 ; return (Just (builder_id', need_dummy_arg)) }
757 where
758
759 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
760 -> TcM (LHsBinds GhcTc)
761 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
762 tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
763 , psb_dir = dir, psb_args = details })
764 | isUnidirectional dir
765 = return emptyBag
766
767 | Left why <- mb_match_group -- Can't invert the pattern
768 = setSrcSpan (getLoc lpat) $ failWithTc $
769 vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
770 <+> quotes (ppr name) <> colon)
771 2 why
772 , text "RHS pattern:" <+> ppr lpat ]
773
774 | Right match_group <- mb_match_group -- Bidirectional
775 = do { patsyn <- tcLookupPatSyn name
776 ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn
777 -- Bidirectional, so patSynBuilder returns Just
778
779 match_group' | need_dummy_arg = add_dummy_arg match_group
780 | otherwise = match_group
781
782 bind = FunBind { fun_ext = placeHolderNamesTc
783 , fun_id = L loc (idName builder_id)
784 , fun_matches = match_group'
785 , fun_co_fn = idHsWrapper
786 , fun_tick = [] }
787
788 sig = completeSigFromId (PatSynCtxt name) builder_id
789
790 ; traceTc "tcPatSynBuilderBind {" $
791 ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
792 ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
793 ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
794 ; return builder_binds }
795
796 | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with
797 where
798 mb_match_group
799 = case dir of
800 ExplicitBidirectional explicit_mg -> Right explicit_mg
801 ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
802 Unidirectional -> panic "tcPatSynBuilderBind"
803
804 mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
805 mk_mg body = mkMatchGroup Generated [builder_match]
806 where
807 builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
808 builder_match = mkMatch (mkPrefixFunRhs (L loc name))
809 builder_args body
810 (noLoc (EmptyLocalBinds noExt))
811
812 args = case details of
813 PrefixCon args -> args
814 InfixCon arg1 arg2 -> [arg1, arg2]
815 RecCon args -> map recordPatSynPatVar args
816
817 add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
818 -> MatchGroup GhcRn (LHsExpr GhcRn)
819 add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] })
820 = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
821 add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
822 pprMatches other_mg
823 tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
824
825 tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
826 -- monadic only for failure
827 tcPatSynBuilderOcc ps
828 | Just (builder_id, add_void_arg) <- builder
829 , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
830 builder_ty = idType builder_id
831 = return $
832 if add_void_arg
833 then ( builder_expr -- still just return builder_expr; the void# arg is added
834 -- by dsConLike in the desugarer
835 , tcFunResultTy builder_ty )
836 else (builder_expr, builder_ty)
837
838 | otherwise -- Unidirectional
839 = nonBidirectionalErr name
840 where
841 name = patSynName ps
842 builder = patSynBuilder ps
843
844 add_void :: Bool -> Type -> Type
845 add_void need_dummy_arg ty
846 | need_dummy_arg = mkFunTy voidPrimTy ty
847 | otherwise = ty
848
849 tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
850 -> Either MsgDoc (LHsExpr GhcRn)
851 -- Given a /pattern/, return an /expression/ that builds a value
852 -- that matches the pattern. E.g. if the pattern is (Just [x]),
853 -- the expression is (Just [x]). They look the same, but the
854 -- input uses constructors from HsPat and the output uses constructors
855 -- from HsExpr.
856 --
857 -- Returns (Left r) if the pattern is not invertible, for reason r.
858 -- See Note [Builder for a bidirectional pattern synonym]
859 tcPatToExpr name args pat = go pat
860 where
861 lhsVars = mkNameSet (map unLoc args)
862
863 -- Make a prefix con for prefix and infix patterns for simplicity
864 mkPrefixConExpr :: Located Name -> [LPat GhcRn]
865 -> Either MsgDoc (HsExpr GhcRn)
866 mkPrefixConExpr lcon@(L loc _) pats
867 = do { exprs <- mapM go pats
868 ; return (foldl (\x y -> HsApp noExt (L loc x) y)
869 (HsVar noExt lcon) exprs) }
870
871 mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
872 -> Either MsgDoc (HsExpr GhcRn)
873 mkRecordConExpr con fields
874 = do { exprFields <- mapM go fields
875 ; return (RecordCon noExt con exprFields) }
876
877 go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
878 go (L loc p) = L loc <$> go1 p
879
880 go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
881 go1 (ConPatIn con info)
882 = case info of
883 PrefixCon ps -> mkPrefixConExpr con ps
884 InfixCon l r -> mkPrefixConExpr con [l,r]
885 RecCon fields -> mkRecordConExpr con fields
886
887 go1 (SigPat _ pat) = go1 (unLoc pat)
888 -- See Note [Type signatures and the builder expression]
889
890 go1 (VarPat _ (L l var))
891 | var `elemNameSet` lhsVars
892 = return $ HsVar noExt (L l var)
893 | otherwise
894 = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
895 go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat
896 go1 p@(ListPat reb pats)
897 | Nothing <- reb = do { exprs <- mapM go pats
898 ; return $ ExplicitList noExt Nothing exprs }
899 | otherwise = notInvertibleListPat p
900 go1 (TuplePat _ pats box) = do { exprs <- mapM go pats
901 ; return $ ExplicitTuple noExt
902 (map (noLoc . (Present noExt)) exprs)
903 box }
904 go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat)
905 ; return $ ExplicitSum noExt alt arity
906 (noLoc expr)
907 }
908 go1 (LitPat _ lit) = return $ HsLit noExt lit
909 go1 (NPat _ (L _ n) mb_neg _)
910 | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg
911 [noLoc (HsOverLit noExt n)]
912 | otherwise = return $ HsOverLit noExt n
913 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
914 go1 (CoPat{}) = panic "CoPat in output of renamer"
915 go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
916 = go1 pat
917 go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
918
919 -- The following patterns are not invertible.
920 go1 p@(BangPat {}) = notInvertible p -- #14112
921 go1 p@(LazyPat {}) = notInvertible p
922 go1 p@(WildPat {}) = notInvertible p
923 go1 p@(AsPat {}) = notInvertible p
924 go1 p@(ViewPat {}) = notInvertible p
925 go1 p@(NPlusKPat {}) = notInvertible p
926 go1 p@(XPat {}) = notInvertible p
927 go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
928 go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
929 go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p
930 go1 p@(SplicePat _ (XSplice {})) = notInvertible p
931
932 notInvertible p = Left (not_invertible_msg p)
933
934 not_invertible_msg p
935 = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
936 $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
937 <+> text "pattern synonym, e.g.")
938 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
939 <+> ppr pat <+> text "where")
940 2 (pp_name <+> pp_args <+> equals <+> text "..."))
941 where
942 pp_name = ppr name
943 pp_args = hsep (map ppr args)
944
945 -- We should really be able to invert list patterns, even when
946 -- rebindable syntax is on, but doing so involves a bit of
947 -- refactoring; see Trac #14380. Until then we reject with a
948 -- helpful error message.
949 notInvertibleListPat p
950 = Left (vcat [ not_invertible_msg p
951 , text "Reason: rebindable syntax is on."
952 , text "This is fixable: add use-case to Trac #14380" ])
953
954 {- Note [Builder for a bidirectional pattern synonym]
955 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
956 For a bidirectional pattern synonym we need to produce an /expression/
957 that matches the supplied /pattern/, given values for the arguments
958 of the pattern synoymy. For example
959 pattern F x y = (Just x, [y])
960 The 'builder' for F looks like
961 $builderF x y = (Just x, [y])
962
963 We can't always do this:
964 * Some patterns aren't invertible; e.g. view patterns
965 pattern F x = (reverse -> x:_)
966
967 * The RHS pattern might bind more variables than the pattern
968 synonym, so again we can't invert it
969 pattern F x = (x,y)
970
971 * Ditto wildcards
972 pattern F x = (x,_)
973
974
975 Note [Redundant constraints for builder]
976 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
977 The builder can have redundant constraints, which are awkard to eliminate.
978 Consider
979 pattern P = Just 34
980 To match against this pattern we need (Eq a, Num a). But to build
981 (Just 34) we need only (Num a). Fortunately instTcSigFromId sets
982 sig_warn_redundant to False.
983
984 ************************************************************************
985 * *
986 Helper functions
987 * *
988 ************************************************************************
989
990 Note [As-patterns in pattern synonym definitions]
991 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
992 The rationale for rejecting as-patterns in pattern synonym definitions
993 is that an as-pattern would introduce nonindependent pattern synonym
994 arguments, e.g. given a pattern synonym like:
995
996 pattern K x y = x@(Just y)
997
998 one could write a nonsensical function like
999
1000 f (K Nothing x) = ...
1001
1002 or
1003 g (K (Just True) False) = ...
1004
1005 Note [Type signatures and the builder expression]
1006 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1007 Consider
1008 pattern L x = Left x :: Either [a] [b]
1009
1010 In tc{Infer/Check}PatSynDecl we will check that the pattern has the
1011 specified type. We check the pattern *as a pattern*, so the type
1012 signature is a pattern signature, and so brings 'a' and 'b' into
1013 scope. But we don't have a way to bind 'a, b' in the LHS, as we do
1014 'x', say. Nevertheless, the sigature may be useful to constrain
1015 the type.
1016
1017 When making the binding for the *builder*, though, we don't want
1018 $buildL x = Left x :: Either [a] [b]
1019 because that wil either mean (forall a b. Either [a] [b]), or we'll
1020 get a complaint that 'a' and 'b' are out of scope. (Actually the
1021 latter; Trac #9867.) No, the job of the signature is done, so when
1022 converting the pattern to an expression (for the builder RHS) we
1023 simply discard the signature.
1024
1025 Note [Record PatSyn Desugaring]
1026 -------------------------------
1027 It is important that prov_theta comes before req_theta as this ordering is used
1028 when desugaring record pattern synonym updates.
1029
1030 Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
1031 want to avoid difficult to decipher core lint errors!
1032 -}
1033
1034
1035 nonBidirectionalErr :: Outputable name => name -> TcM a
1036 nonBidirectionalErr name = failWithTc $
1037 text "non-bidirectional pattern synonym"
1038 <+> quotes (ppr name) <+> text "used in an expression"
1039
1040 -- Walk the whole pattern and for all ConPatOuts, collect the
1041 -- existentially-bound type variables and evidence binding variables.
1042 --
1043 -- These are used in computing the type of a pattern synonym and also
1044 -- in generating matcher functions, since success continuations need
1045 -- to be passed these pattern-bound evidences.
1046 tcCollectEx
1047 :: LPat GhcTc
1048 -> ( [TyVar] -- Existentially-bound type variables
1049 -- in correctly-scoped order; e.g. [ k:*, x:k ]
1050 , [EvVar] ) -- and evidence variables
1051
1052 tcCollectEx pat = go pat
1053 where
1054 go :: LPat GhcTc -> ([TyVar], [EvVar])
1055 go = go1 . unLoc
1056
1057 go1 :: Pat GhcTc -> ([TyVar], [EvVar])
1058 go1 (LazyPat _ p) = go p
1059 go1 (AsPat _ _ p) = go p
1060 go1 (ParPat _ p) = go p
1061 go1 (BangPat _ p) = go p
1062 go1 (ListPat _ ps) = mergeMany . map go $ ps
1063 go1 (TuplePat _ ps _) = mergeMany . map go $ ps
1064 go1 (SumPat _ p _ _) = go p
1065 go1 (ViewPat _ _ p) = go p
1066 go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
1067 goConDetails $ pat_args con
1068 go1 (SigPat _ p) = go p
1069 go1 (CoPat _ _ p _) = go1 p
1070 go1 (NPlusKPat _ n k _ geq subtract)
1071 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
1072 go1 _ = empty
1073
1074 goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
1075 goConDetails (PrefixCon ps) = mergeMany . map go $ ps
1076 goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
1077 goConDetails (RecCon HsRecFields{ rec_flds = flds })
1078 = mergeMany . map goRecFd $ flds
1079
1080 goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
1081 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
1082
1083 merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
1084 mergeMany = foldr merge empty
1085 empty = ([], [])