Major patch to add -fwarn-redundant-constraints
[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 { (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
195 (univ_tvs, req_theta, req_ev_binds, req_dicts)
196 (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
197 wrapped_args
198 pat_ty
199
200 ; builder_id <- mkPatSynBuilderId dir lname qtvs theta arg_tys pat_ty
201
202 ; let patSyn = mkPatSyn (unLoc lname) is_infix
203 (univ_tvs, req_theta)
204 (ex_tvs, prov_theta)
205 arg_tys
206 pat_ty
207 matcher_id builder_id
208
209 ; return (patSyn, matcher_bind) }
210 where
211 qtvs = univ_tvs ++ ex_tvs
212 theta = prov_theta ++ req_theta
213 arg_tys = map (varType . fst) wrapped_args
214
215 {-
216 ************************************************************************
217 * *
218 Constructing the "matcher" Id and its binding
219 * *
220 ************************************************************************
221 -}
222
223 tcPatSynMatcher :: Located Name
224 -> LPat Id
225 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
226 -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar])
227 -> [(Var, HsWrapper)]
228 -> TcType
229 -> TcM ((Id, Bool), LHsBinds Id)
230 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
231 tcPatSynMatcher (L loc name) lpat
232 (univ_tvs, req_theta, req_ev_binds, req_dicts)
233 (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
234 wrapped_args pat_ty
235 = do { uniq <- newUnique
236 ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
237 res_tv = mkTcTyVar tv_name openTypeKind (SkolemTv False)
238 is_unlifted = null wrapped_args && null prov_dicts
239 res_ty = mkTyVarTy res_tv
240 (cont_arg_tys, cont_args)
241 | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId])
242 | otherwise = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg)
243 | (arg, wrap) <- wrapped_args
244 ]
245 cont_ty = mkSigmaTy ex_tvs prov_theta $
246 mkFunTys cont_arg_tys res_ty
247
248 fail_ty = mkFunTy voidPrimTy res_ty
249
250 ; matcher_name <- newImplicitBinder name mkMatcherOcc
251 ; scrutinee <- newSysLocalId (fsLit "scrut") pat_ty
252 ; cont <- newSysLocalId (fsLit "cont") cont_ty
253 ; fail <- newSysLocalId (fsLit "fail") fail_ty
254
255 ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
256 matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
257 matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
258 -- See Note [Exported LocalIds] in Id
259
260 cont_dicts = map nlHsVar prov_dicts
261 cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
262 nlHsTyApps cont ex_tys (cont_dicts ++ cont_args)
263
264 fail' = nlHsApps fail [nlHsVar voidPrimId]
265
266 args = map nlVarPat [scrutinee, cont, fail]
267 lwpat = noLoc $ WildPat pat_ty
268 cases = if isIrrefutableHsPat lpat
269 then [mkSimpleHsAlt lpat cont']
270 else [mkSimpleHsAlt lpat cont',
271 mkSimpleHsAlt lwpat fail']
272 body = mkLHsWrap (mkWpLet req_ev_binds) $
273 L (getLoc lpat) $
274 HsCase (nlHsVar scrutinee) $
275 MG{ mg_alts = cases
276 , mg_arg_tys = [pat_ty]
277 , mg_res_ty = res_ty
278 , mg_origin = Generated
279 }
280 body' = noLoc $
281 HsLam $
282 MG{ mg_alts = [mkSimpleMatch args body]
283 , mg_arg_tys = [pat_ty, cont_ty, res_ty]
284 , mg_res_ty = res_ty
285 , mg_origin = Generated
286 }
287 match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
288 mg = MG{ mg_alts = [match]
289 , mg_arg_tys = []
290 , mg_res_ty = res_ty
291 , mg_origin = Generated
292 }
293
294 ; let bind = FunBind{ fun_id = L loc matcher_id
295 , fun_infix = False
296 , fun_matches = mg
297 , fun_co_fn = idHsWrapper
298 , bind_fvs = emptyNameSet
299 , fun_tick = [] }
300 matcher_bind = unitBag (noLoc bind)
301
302 ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
303 ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
304
305 ; return ((matcher_id, is_unlifted), matcher_bind) }
306
307
308 isUnidirectional :: HsPatSynDir a -> Bool
309 isUnidirectional Unidirectional = True
310 isUnidirectional ImplicitBidirectional = False
311 isUnidirectional ExplicitBidirectional{} = False
312
313 {-
314 ************************************************************************
315 * *
316 Constructing the "builder" Id
317 * *
318 ************************************************************************
319 -}
320
321 mkPatSynBuilderId :: HsPatSynDir a -> Located Name
322 -> [TyVar] -> ThetaType -> [Type] -> Type
323 -> TcM (Maybe (Id, Bool))
324 mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty
325 | isUnidirectional dir
326 = return Nothing
327 | otherwise
328 = do { builder_name <- newImplicitBinder name mkBuilderOcc
329 ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
330 builder_id = mkExportedLocalId VanillaId builder_name builder_sigma
331 -- See Note [Exported LocalIds] in Id
332 ; return (Just (builder_id, need_dummy_arg)) }
333 where
334 builder_arg_tys | need_dummy_arg = [voidPrimTy]
335 | otherwise = arg_tys
336 need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta
337
338 tcPatSynBuilderBind :: PatSynBind Name Name
339 -> TcM (LHsBinds Id)
340 -- See Note [Matchers and builders for pattern synonyms] in PatSyn
341 tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
342 , psb_dir = dir, psb_args = details }
343 | isUnidirectional dir
344 = return emptyBag
345
346 | isNothing mb_match_group -- Can't invert the pattern
347 = setSrcSpan (getLoc lpat) $ failWithTc $
348 hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
349 2 (ppr lpat)
350
351 | otherwise
352 = do { patsyn <- tcLookupPatSyn name
353 ; let (worker_id, need_dummy_arg) = fromMaybe (panic "mkPatSynWrapper") $
354 patSynBuilder patsyn
355
356 ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds
357 mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy]
358 | otherwise = mg
359
360 ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id)
361 bind = FunBind { fun_id = L loc (idName worker_id)
362 , fun_infix = False
363 , fun_matches = mg'
364 , fun_co_fn = idHsWrapper
365 , bind_fvs = placeHolderNamesTc
366 , fun_tick = [] }
367
368 sig = TcSigInfo{ sig_id = worker_id
369 , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs
370 , sig_theta = worker_theta
371 , sig_tau = worker_tau
372 , sig_loc = noSrcSpan
373 , sig_extra_cts = Nothing
374 , sig_partial = False
375 , sig_warn_redundant = False -- See Note [Redundant constraints for builder]
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 Note [Redundant constraints for builder]
420 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
421 The builder can have redundant constraints, which are awkard to eliminate.
422 Consider
423 pattern P = Just 34
424 To match against this pattern we need (Eq a, Num a). But to build
425 (Just 34) we need only (Num a).
426
427 ************************************************************************
428 * *
429 Helper functions
430 * *
431 ************************************************************************
432
433 Note [As-patterns in pattern synonym definitions]
434 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
435
436 The rationale for rejecting as-patterns in pattern synonym definitions
437 is that an as-pattern would introduce nonindependent pattern synonym
438 arguments, e.g. given a pattern synonym like:
439
440 pattern K x y = x@(Just y)
441
442 one could write a nonsensical function like
443
444 f (K Nothing x) = ...
445
446 or
447 g (K (Just True) False) = ...
448 -}
449
450 tcCheckPatSynPat :: LPat Name -> TcM ()
451 tcCheckPatSynPat = go
452 where
453 go :: LPat Name -> TcM ()
454 go = addLocM go1
455
456 go1 :: Pat Name -> TcM ()
457 go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info)
458 go1 VarPat{} = return ()
459 go1 WildPat{} = return ()
460 go1 p@(AsPat _ _) = asPatInPatSynErr p
461 go1 (LazyPat pat) = go pat
462 go1 (ParPat pat) = go pat
463 go1 (BangPat pat) = go pat
464 go1 (PArrPat pats _) = mapM_ go pats
465 go1 (ListPat pats _ _) = mapM_ go pats
466 go1 (TuplePat pats _ _) = mapM_ go pats
467 go1 LitPat{} = return ()
468 go1 NPat{} = return ()
469 go1 (SigPatIn pat _) = go pat
470 go1 (ViewPat _ pat _) = go pat
471 go1 p@SplicePat{} = thInPatSynErr p
472 go1 p@QuasiQuotePat{} = thInPatSynErr p
473 go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p
474 go1 ConPatOut{} = panic "ConPatOut in output of renamer"
475 go1 SigPatOut{} = panic "SigPatOut in output of renamer"
476 go1 CoPat{} = panic "CoPat in output of renamer"
477
478 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
479 asPatInPatSynErr pat
480 = failWithTc $
481 hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
482 2 (ppr pat)
483
484 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
485 thInPatSynErr pat
486 = failWithTc $
487 hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
488 2 (ppr pat)
489
490 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
491 nPlusKPatInPatSynErr pat
492 = failWithTc $
493 hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
494 2 (ppr pat)
495
496 tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
497 tcPatToExpr args = go
498 where
499 lhsVars = mkNameSet (map unLoc args)
500
501 go :: LPat Name -> Maybe (LHsExpr Name)
502 go (L loc (ConPatIn conName info))
503 = do { let con = L loc (HsVar (unLoc conName))
504 ; exprs <- mapM go (hsConPatArgs info)
505 ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
506 go (L loc p) = fmap (L loc) $ go1 p
507
508 go1 :: Pat Name -> Maybe (HsExpr Name)
509 go1 (VarPat var)
510 | var `elemNameSet` lhsVars = return $ HsVar var
511 | otherwise = Nothing
512 go1 (LazyPat pat) = fmap HsPar $ go pat
513 go1 (ParPat pat) = fmap HsPar $ go pat
514 go1 (BangPat pat) = fmap HsPar $ go pat
515 go1 (PArrPat pats ptt)
516 = do { exprs <- mapM go pats
517 ; return $ ExplicitPArr ptt exprs }
518 go1 (ListPat pats ptt reb)
519 = do { exprs <- mapM go pats
520 ; return $ ExplicitList ptt (fmap snd reb) exprs }
521 go1 (TuplePat pats box _)
522 = do { exprs <- mapM go pats
523 ; return (ExplicitTuple (map (noLoc . Present) exprs) box)
524 }
525 go1 (LitPat lit) = return $ HsLit lit
526 go1 (NPat n Nothing _) = return $ HsOverLit n
527 go1 (NPat n (Just neg) _) = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
528 go1 (SigPatIn pat (HsWB ty _ _ wcs))
529 = do { expr <- go pat
530 ; return $ ExprWithTySig expr ty wcs }
531 go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
532 go1 (SigPatOut{}) = panic "SigPatOut in output of renamer"
533 go1 (CoPat{}) = panic "CoPat in output of renamer"
534 go1 _ = Nothing
535
536 -- Walk the whole pattern and for all ConPatOuts, collect the
537 -- existentially-bound type variables and evidence binding variables.
538 --
539 -- These are used in computing the type of a pattern synonym and also
540 -- in generating matcher functions, since success continuations need
541 -- to be passed these pattern-bound evidences.
542 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
543 tcCollectEx = return . go
544 where
545 go :: LPat Id -> (TyVarSet, [EvVar])
546 go = go1 . unLoc
547
548 go1 :: Pat Id -> (TyVarSet, [EvVar])
549 go1 (LazyPat p) = go p
550 go1 (AsPat _ p) = go p
551 go1 (ParPat p) = go p
552 go1 (BangPat p) = go p
553 go1 (ListPat ps _ _) = mconcat . map go $ ps
554 go1 (TuplePat ps _ _) = mconcat . map go $ ps
555 go1 (PArrPat ps _) = mconcat . map go $ ps
556 go1 (ViewPat _ p _) = go p
557 go1 (QuasiQuotePat qq) = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq
558 go1 con@ConPatOut{} = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
559 goConDetails $ pat_args con
560 go1 (SigPatOut p _) = go p
561 go1 (CoPat _ p _) = go1 p
562 go1 (NPlusKPat n k geq subtract)
563 = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
564 go1 _ = mempty
565
566 goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
567 goConDetails (PrefixCon ps) = mconcat . map go $ ps
568 goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
569 goConDetails (RecCon HsRecFields{ rec_flds = flds })
570 = mconcat . map goRecFd $ flds
571
572 goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
573 goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p