Implement Partial Type Signatures
[ghc.git] / compiler / typecheck / TcPatSyn.lhs
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 \begin{code}
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 TcBinds
30 import BasicTypes
31 import TcSimplify
32 import TcUnify
33 import TcType
34 import TcEvidence
35 import BuildTyCl
36 import VarSet
37 import MkId
38 import VarEnv
39 import Inst
40 #if __GLASGOW_HASKELL__ < 709
41 import Data.Monoid
42 #endif
43 import Bag
44 import Util
45 import Data.Maybe
46 import Control.Monad (forM)
47
48 #include "HsVersions.h"
49 \end{code}
50
51 %************************************************************************
52 %*                                                                      *
53                     Type checking a pattern synonym
54 %*                                                                      *
55 %************************************************************************
56
57 \begin{code}
58 tcInferPatSynDecl :: PatSynBind Name Name
59                   -> TcM (PatSyn, LHsBinds Id)
60 tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
61                        psb_def = lpat, psb_dir = dir }
62   = setSrcSpan loc $
63     do { traceTc "tcInferPatSynDecl {" $ ppr name
64        ; tcCheckPatSynPat lpat
65
66        ; let (arg_names, is_infix) = case details of
67                  PrefixPatSyn names      -> (map unLoc names, False)
68                  InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
69        ; (((lpat', (args, pat_ty)), untch), wanted)
70             <- captureConstraints       $
71                captureUntouchables      $
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 untch 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) (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 \end{code}
215
216
217 %************************************************************************
218 %*                                                                      *
219          Constructing the "matcher" Id and its binding
220 %*                                                                      *
221 %************************************************************************
222
223 \begin{code}
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    = mkVanillaGlobal matcher_name matcher_sigma
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 = Nothing }
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 \end{code}
313
314
315 %************************************************************************
316 %*                                                                      *
317          Constructing the "builder" Id
318 %*                                                                      *
319 %************************************************************************
320
321 \begin{code}
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 mkDataConWorkerOcc
330        ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
331              builder_id    = mkVanillaGlobal builder_name builder_sigma
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 = Nothing }
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_nwcs = []
376                             }
377
378        ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
379        ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
380        ; return worker_binds }
381   where
382     Just mg = mb_match_group
383     mb_match_group = case dir of
384                         Unidirectional           -> Nothing
385                         ExplicitBidirectional mg -> Just mg
386                         ImplicitBidirectional    -> fmap mk_mg (tcPatToExpr args lpat)
387
388     mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
389     mk_mg body = mkMatchGroupName Generated [wrapper_match]
390                where
391                  wrapper_args  = [L loc (VarPat n) | L loc n <- args]
392                  wrapper_match = mkMatch wrapper_args body EmptyLocalBinds
393
394     args = case details of
395               PrefixPatSyn args -> args
396               InfixPatSyn arg1 arg2 -> [arg1, arg2]
397
398 tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
399 -- The result type should be fully instantiated
400 tcPatSynBuilderOcc orig ps
401   | Just (builder_id, add_void_arg) <- builder
402   = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
403        ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
404        ; if add_void_arg
405          then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
406                      , tcFunResultTy rho )
407          else return ( inst_fun, rho ) }
408
409   | otherwise  -- Unidirectional
410   = failWithTc $
411     ptext (sLit "non-bidirectional pattern synonym")
412     <+> quotes (ppr name) <+> ptext (sLit "used in an expression")
413   where
414     name    = patSynName ps
415     builder = patSynBuilder ps
416 \end{code}
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 \begin{code}
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
566
567 \end{code}