23262f3db82f77881071e07278516f993b96c580
[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                             }
374
375        ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
376        ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
377        ; return worker_binds }
378   where
379     Just mg = mb_match_group
380     mb_match_group = case dir of
381                         Unidirectional           -> Nothing
382                         ExplicitBidirectional mg -> Just mg
383                         ImplicitBidirectional    -> fmap mk_mg (tcPatToExpr args lpat)
384
385     mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
386     mk_mg body = mkMatchGroupName Generated [wrapper_match]
387                where
388                  wrapper_args  = [L loc (VarPat n) | L loc n <- args]
389                  wrapper_match = mkMatch wrapper_args body EmptyLocalBinds
390
391     args = case details of
392               PrefixPatSyn args -> args
393               InfixPatSyn arg1 arg2 -> [arg1, arg2]
394
395 tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
396 -- The result type should be fully instantiated
397 tcPatSynBuilderOcc orig ps
398   | Just (builder_id, add_void_arg) <- builder
399   = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
400        ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
401        ; if add_void_arg
402          then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
403                      , tcFunResultTy rho )
404          else return ( inst_fun, rho ) }
405
406   | otherwise  -- Unidirectional
407   = failWithTc $
408     ptext (sLit "non-bidirectional pattern synonym")
409     <+> quotes (ppr name) <+> ptext (sLit "used in an expression")
410   where
411     name    = patSynName ps
412     builder = patSynBuilder ps
413 \end{code}
414
415
416 %************************************************************************
417 %*                                                                      *
418          Helper functions
419 %*                                                                      *
420 %************************************************************************
421
422 Note [As-patterns in pattern synonym definitions]
423 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
424
425 The rationale for rejecting as-patterns in pattern synonym definitions
426 is that an as-pattern would introduce nonindependent pattern synonym
427 arguments, e.g. given a pattern synonym like:
428
429         pattern K x y = x@(Just y)
430
431 one could write a nonsensical function like
432
433         f (K Nothing x) = ...
434
435 or
436         g (K (Just True) False) = ...
437
438 \begin{code}
439 tcCheckPatSynPat :: LPat Name -> TcM ()
440 tcCheckPatSynPat = go
441   where
442     go :: LPat Name -> TcM ()
443     go = addLocM go1
444
445     go1 :: Pat Name -> TcM ()
446     go1   (ConPatIn _ info)   = mapM_ go (hsConPatArgs info)
447     go1   VarPat{}            = return ()
448     go1   WildPat{}           = return ()
449     go1 p@(AsPat _ _)         = asPatInPatSynErr p
450     go1   (LazyPat pat)       = go pat
451     go1   (ParPat pat)        = go pat
452     go1   (BangPat pat)       = go pat
453     go1   (PArrPat pats _)    = mapM_ go pats
454     go1   (ListPat pats _ _)  = mapM_ go pats
455     go1   (TuplePat pats _ _) = mapM_ go pats
456     go1   LitPat{}            = return ()
457     go1   NPat{}              = return ()
458     go1   (SigPatIn pat _)    = go pat
459     go1   (ViewPat _ pat _)   = go pat
460     go1 p@SplicePat{}         = thInPatSynErr p
461     go1 p@QuasiQuotePat{}     = thInPatSynErr p
462     go1 p@NPlusKPat{}         = nPlusKPatInPatSynErr p
463     go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
464     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
465     go1   CoPat{}             = panic "CoPat in output of renamer"
466
467 asPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
468 asPatInPatSynErr pat
469   = failWithTc $
470     hang (ptext (sLit "Pattern synonym definition cannot contain as-patterns (@):"))
471        2 (ppr pat)
472
473 thInPatSynErr :: OutputableBndr name => Pat name -> TcM a
474 thInPatSynErr pat
475   = failWithTc $
476     hang (ptext (sLit "Pattern synonym definition cannot contain Template Haskell:"))
477        2 (ppr pat)
478
479 nPlusKPatInPatSynErr :: OutputableBndr name => Pat name -> TcM a
480 nPlusKPatInPatSynErr pat
481   = failWithTc $
482     hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
483        2 (ppr pat)
484
485 tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
486 tcPatToExpr args = go
487   where
488     lhsVars = mkNameSet (map unLoc args)
489
490     go :: LPat Name -> Maybe (LHsExpr Name)
491     go (L loc (ConPatIn conName info))
492       = do { let con = L loc (HsVar (unLoc conName))
493            ; exprs <- mapM go (hsConPatArgs info)
494            ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
495     go (L loc p) = fmap (L loc) $ go1 p
496
497     go1 :: Pat Name -> Maybe (HsExpr Name)
498     go1   (VarPat var)
499       | var `elemNameSet` lhsVars  = return $ HsVar var
500       | otherwise                  = Nothing
501     go1   (LazyPat pat)            = fmap HsPar $ go pat
502     go1   (ParPat pat)             = fmap HsPar $ go pat
503     go1   (BangPat pat)            = fmap HsPar $ go pat
504     go1   (PArrPat pats ptt)
505       = do { exprs <- mapM go pats
506            ; return $ ExplicitPArr ptt exprs }
507     go1   (ListPat pats ptt reb)
508       = do { exprs <- mapM go pats
509            ; return $ ExplicitList ptt (fmap snd reb) exprs }
510     go1   (TuplePat pats box _)
511       = do { exprs <- mapM go pats
512            ; return (ExplicitTuple (map (noLoc . Present) exprs) box)
513            }
514     go1   (LitPat lit)             = return $ HsLit lit
515     go1   (NPat n Nothing _)       = return $ HsOverLit n
516     go1   (NPat n (Just neg) _)    = return $ noLoc neg `HsApp` noLoc (HsOverLit n)
517     go1   (SigPatIn pat (HsWB ty _ _))
518       = do { expr <- go pat
519            ; return $ ExprWithTySig expr ty }
520     go1   (ConPatOut{})            = panic "ConPatOut in output of renamer"
521     go1   (SigPatOut{})            = panic "SigPatOut in output of renamer"
522     go1   (CoPat{})                = panic "CoPat in output of renamer"
523     go1   _                        = Nothing
524
525 -- Walk the whole pattern and for all ConPatOuts, collect the
526 -- existentially-bound type variables and evidence binding variables.
527 --
528 -- These are used in computing the type of a pattern synonym and also
529 -- in generating matcher functions, since success continuations need
530 -- to be passed these pattern-bound evidences.
531 tcCollectEx :: LPat Id -> TcM (TyVarSet, [EvVar])
532 tcCollectEx = return . go
533   where
534     go :: LPat Id -> (TyVarSet, [EvVar])
535     go = go1 . unLoc
536
537     go1 :: Pat Id -> (TyVarSet, [EvVar])
538     go1 (LazyPat p)         = go p
539     go1 (AsPat _ p)         = go p
540     go1 (ParPat p)          = go p
541     go1 (BangPat p)         = go p
542     go1 (ListPat ps _ _)    = mconcat . map go $ ps
543     go1 (TuplePat ps _ _)   = mconcat . map go $ ps
544     go1 (PArrPat ps _)      = mconcat . map go $ ps
545     go1 (ViewPat _ p _)     = go p
546     go1 (QuasiQuotePat qq)  = pprPanic "TODO: tcInstPatSyn QuasiQuotePat" $ ppr qq
547     go1 con@ConPatOut{}     = mappend (mkVarSet (pat_tvs con), pat_dicts con) $
548                                  goConDetails $ pat_args con
549     go1 (SigPatOut p _)     = go p
550     go1 (CoPat _ p _)       = go1 p
551     go1 (NPlusKPat n k geq subtract)
552       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
553     go1 _                   = mempty
554
555     goConDetails :: HsConPatDetails Id -> (TyVarSet, [EvVar])
556     goConDetails (PrefixCon ps) = mconcat . map go $ ps
557     goConDetails (InfixCon p1 p2) = go p1 `mappend` go p2
558     goConDetails (RecCon HsRecFields{ rec_flds = flds })
559       = mconcat . map goRecFd $ flds
560
561     goRecFd :: LHsRecField Id (LPat Id) -> (TyVarSet, [EvVar])
562     goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p
563
564 \end{code}