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