ghc/compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcMatches]{Typecheck some @Matches@}
   5
   6 \begin{code}
   7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
   8                    tcDoStmts, tcStmtsAndThen, tcGRHSs
   9        ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-}   TcExpr( tcMonoExpr )
  14
  15 import HsSyn            ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  16                           MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
  17                           pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
  18                           mkMonoBind, nullMonoBinds, collectSigTysFromPats, andMonoBindList
  19                         )
  20 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt,
  21                           RenamedPat, RenamedMatchContext )
  22 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds,
  23                           TcMonoBinds, TcPat, TcStmt )
  24
  25 import TcRnMonad
  26 import TcMonoType       ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
  27 import Inst             ( tcSyntaxName )
  28 import TcEnv            ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
  29 import TcPat            ( tcPat, tcMonoPatBndr )
  30 import TcMType          ( newTyVarTy, zonkTcType, zapToType )
  31 import TcType           ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
  32                           mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
  33                           mkArrowKind, mkAppTy )
  34 import TcBinds          ( tcBindsAndThen )
  35 import TcUnify          ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
  36                           checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
  37 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  38 import Name             ( Name )
  39 import PrelNames        ( monadNames )
  40 import TysWiredIn       ( boolTy, mkListTy, mkPArrTy )
  41 import Id               ( idType, mkSysLocal )
  42 import CoreFVs          ( idFreeTyVars )
  43 import BasicTypes       ( RecFlag(..) )
  44 import VarSet
  45 import Var              ( Id )
  46 import Bag
  47 import Util             ( isSingleton, lengthExceeds, notNull, zipEqual )
  48 import Outputable
  49
  50 import List             ( nub )
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{tcMatchesFun, tcMatchesCase}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  60 @FunMonoBind@.  The second argument is the name of the function, which
  61 is used in error messages.  It checks that all the equations have the
  62 same number of arguments before using @tcMatches@ to do the work.
  63
  64 \begin{code}
  65 tcMatchesFun :: [(Name,Id)]     -- Bindings for the variables bound in this group
  66              -> Name
  67              -> TcType          -- Expected type
  68              -> [RenamedMatch]
  69              -> TcM [TcMatch]
  70
  71 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
  72   =      -- Check that they all have the same no of arguments
  73          -- Set the location to that of the first equation, so that
  74          -- any inter-equation error messages get some vaguely
  75          -- sensible location.  Note: we have to do this odd
  76          -- ann-grabbing, because we don't always have annotations in
  77          -- hand when we call tcMatchesFun...
  78     addSrcLoc (getMatchLoc first_match)  (
  79             checkTc (sameNoOfArgs matches)
  80                     (varyingArgsErr fun_name matches)
  81     )                                            `thenM_`
  82
  83         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  84         -- because inconsistency between branches
  85         -- may show up as something wrong with the (non-existent) type signature
  86
  87         -- No need to zonk expected_ty, because subFunTy does that on the fly
  88     tcMatches xve (FunRhs fun_name) matches expected_ty
  89 \end{code}
  90
  91 @tcMatchesCase@ doesn't do the argument-count check because the
  92 parser guarantees that each equation has exactly one argument.
  93
  94 \begin{code}
  95 tcMatchesCase :: [RenamedMatch]         -- The case alternatives
  96               -> TcType                 -- Type of whole case expressions
  97               -> TcM (TcType,           -- Inferred type of the scrutinee
  98                         [TcMatch])      -- Translated alternatives
  99
 100 tcMatchesCase matches expr_ty
 101   = newTyVarTy openTypeKind                                     `thenM` \ scrut_ty ->
 102     tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty)     `thenM` \ matches' ->
 103     returnM (scrut_ty, matches')
 104
 105 tcMatchLambda :: RenamedMatch -> TcType -> TcM TcMatch
 106 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
 107 \end{code}
 108
 109
 110 \begin{code}
 111 tcMatches :: [(Name,Id)]
 112           -> RenamedMatchContext
 113           -> [RenamedMatch]
 114           -> TcType
 115           -> TcM [TcMatch]
 116
 117 tcMatches xve ctxt matches expected_ty
 118   =     -- If there is more than one branch, and expected_ty is a 'hole',
 119         -- all branches must be types, not type schemes, otherwise the
 120         -- in which we check them would affect the result.
 121     (if lengthExceeds matches 1 then
 122         zapToType expected_ty
 123      else
 124         returnM expected_ty)                    `thenM` \ expected_ty' ->
 125
 126     mappM (tc_match expected_ty') matches
 127   where
 128     tc_match expected_ty match = tcMatch xve ctxt match expected_ty
 129 \end{code}
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{tcMatch}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 \begin{code}
 139 tcMatch :: [(Name,Id)]
 140         -> RenamedMatchContext
 141         -> RenamedMatch
 142         -> TcType       -- Expected result-type of the Match.
 143                         -- Early unification with this guy gives better error messages
 144                         -- We regard the Match as having type
 145                         --      (ty1 -> ... -> tyn -> result_ty)
 146                         -- where there are n patterns.
 147         -> TcM TcMatch
 148
 149 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
 150   = addSrcLoc (getMatchLoc match)               $       -- At one stage I removed this;
 151     addErrCtxt (matchCtxt ctxt match)           $       -- I'm not sure why, so I put it back
 152     tcMatchPats pats expected_ty tc_grhss       `thenM` \ (pats', grhss', ex_binds) ->
 153     returnM (Match pats' Nothing (glue_on Recursive ex_binds grhss'))
 154
 155   where
 156     tc_grhss rhs_ty
 157         = tcExtendLocalValEnv2 xve1                     $
 158
 159                 -- Deal with the result signature
 160           case maybe_rhs_sig of
 161             Nothing ->  tcGRHSs ctxt grhss rhs_ty
 162
 163             Just sig ->  tcAddScopedTyVars [sig]        $
 164                                 -- Bring into scope the type variables in the signature
 165                          tcHsSigType ResSigCtxt sig     `thenM` \ sig_ty ->
 166                          tcGRHSs ctxt grhss sig_ty      `thenM` \ grhss' ->
 167                          tcSubExp rhs_ty sig_ty         `thenM` \ co_fn  ->
 168                          returnM (lift_grhss co_fn rhs_ty grhss')
 169
 170 -- lift_grhss pushes the coercion down to the right hand sides,
 171 -- because there is no convenient place to hang it otherwise.
 172 lift_grhss co_fn rhs_ty grhss
 173   | isIdCoercion co_fn = grhss
 174 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
 175   = GRHSs (map lift_grhs grhss) binds rhs_ty    -- Change the type, since we
 176   where
 177     lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
 178
 179     lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
 180     lift_stmt stmt             = stmt
 181
 182 -- glue_on just avoids stupid dross
 183 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 184 glue_on is_rec mbinds (GRHSs grhss binds ty)
 185   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 186
 187
 188 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
 189         -> TcType
 190         -> TcM TcGRHSs
 191
 192 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
 193   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 194   where
 195     tc_grhss grhss
 196         = mappM tc_grhs grhss       `thenM` \ grhss' ->
 197           returnM (GRHSs grhss' EmptyBinds expected_ty)
 198
 199     tc_grhs (GRHS guarded locn)
 200         = addSrcLoc locn                                $
 201           tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenM` \ guarded' ->
 202           returnM (GRHS guarded' locn)
 203 \end{code}
 204
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{tcMatchPats}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 tcMatchPats
 214         :: [RenamedPat] -> TcType
 215         -> (TcType -> TcM a)
 216         -> TcM ([TcPat], a, TcDictBinds)
 217 -- Typecheck the patterns, extend the environment to bind the variables,
 218 -- do the thing inside, use any existentially-bound dictionaries to
 219 -- discharge parts of the returning LIE, and deal with pattern type
 220 -- signatures
 221
 222 tcMatchPats pats expected_ty thing_inside
 223   =     -- STEP 1: Bring pattern-signature type variables into scope
 224     tcAddScopedTyVars (collectSigTysFromPats pats)      (
 225
 226         -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
 227         --         then do the thing inside
 228         getLIE (tc_match_pats pats expected_ty thing_inside)
 229
 230     ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
 231
 232         -- STEP 4: Check for existentially bound type variables
 233         -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
 234         -- complains that 'a' is captured by the inscope 'a'!  (Test (d) in checkSigTyVars.)
 235         --
 236         -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
 237         -- might need (via lie_req2) something made available from an 'outer'
 238         -- pattern.  But it's inconvenient to deal with, and I can't find an example
 239     tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty      `thenM` \ ex_binds ->
 240         -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
 241         -- For example, we must reject this program:
 242         --      data C = forall a. C (a -> Int)
 243         --      f (C g) x = g x
 244         -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
 245
 246     returnM (pats', result, ex_binds)
 247
 248 tc_match_pats [] expected_ty thing_inside
 249   = thing_inside expected_ty    `thenM` \ answer ->
 250     returnM ([], emptyBag, [], [], answer)
 251
 252 tc_match_pats (pat:pats) expected_ty thing_inside
 253   = subFunTy expected_ty                $ \ arg_ty rest_ty ->
 254         -- This is the unique place we call subFunTy
 255         -- The point is that if expected_y is a "hole", we want
 256         -- to make arg_ty and rest_ty as "holes" too.
 257     tcPat tcMonoPatBndr pat arg_ty      `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
 258     let
 259         xve    = bagToList pat_bndrs
 260         ex_ids = [id | (_, id) <- xve]
 261                 -- ex_ids is all the pattern-bound Ids, a superset
 262                 -- of the existential Ids used in checkExistentialPat
 263     in
 264     tcExtendLocalValEnv2 xve                    $
 265     tc_match_pats pats rest_ty thing_inside     `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
 266     returnM (   pat':pats',
 267                 ex_tvs `unionBags` exs_tvs,
 268                 ex_ids ++ exs_ids,
 269                 ex_lie ++ exs_lie,
 270                 answer
 271     )
 272
 273
 274 tcCheckExistentialPat :: Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 275                       -> [TcId]         -- Ids bound by this pattern; used
 276                                         --   (a) by bindsInstsOfLocalFuns
 277                                         --   (b) to generate helpful error messages
 278                       -> [Inst]         --   and context
 279                       -> [Inst]         -- Required context
 280                       -> TcType         --   and type of the Match; vars in here must not escape
 281                       -> TcM TcDictBinds        -- LIE to float out and dict bindings
 282 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
 283   | isEmptyBag ex_tvs && all not_overloaded ex_ids
 284         -- Short cut for case when there are no existentials
 285         -- and no polymorphic overloaded variables
 286         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 287         --       f op x = ....
 288         --  Here we must discharge op Methods
 289   = ASSERT( null ex_lie )
 290     extendLIEs lie_req          `thenM_`
 291     returnM EmptyMonoBinds
 292
 293   | otherwise
 294   = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty)            $
 295
 296         -- In case there are any polymorpic, overloaded binders in the pattern
 297         -- (which can happen in the case of rank-2 type signatures, or data constructors
 298         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 299     getLIE (bindInstsOfLocalFuns lie_req ex_ids)        `thenM` \ (inst_binds, lie) ->
 300
 301         -- Deal with overloaded functions bound by the pattern
 302     tcSimplifyCheck doc tv_list ex_lie lie              `thenM` \ dict_binds ->
 303     checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list   `thenM_`
 304
 305     returnM (dict_binds `AndMonoBinds` inst_binds)
 306   where
 307     doc     = text ("existential context of a data constructor")
 308     tv_list = bagToList ex_tvs
 309     not_overloaded id = not (isOverloadedTy (idType id))
 310 \end{code}
 311
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 \begin{code}
 320 tcDoStmts :: HsDoContext -> [RenamedStmt] -> [Name] -> TcType
 321           -> TcM (TcMonoBinds, [TcStmt], [Id])
 322 tcDoStmts PArrComp stmts method_names res_ty
 323   = unifyPArrTy res_ty                    `thenM` \elt_ty ->
 324     tcStmts (DoCtxt PArrComp)
 325             (mkPArrTy, elt_ty) stmts      `thenM` \ stmts' ->
 326     returnM (EmptyMonoBinds, stmts', [{- unused -}])
 327
 328 tcDoStmts ListComp stmts method_names res_ty
 329   = unifyListTy res_ty                  `thenM` \ elt_ty ->
 330     tcStmts (DoCtxt ListComp)
 331             (mkListTy, elt_ty) stmts    `thenM` \ stmts' ->
 332     returnM (EmptyMonoBinds, stmts', [{- unused -}])
 333
 334 tcDoStmts DoExpr stmts method_names res_ty
 335   = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)      `thenM` \ m_ty ->
 336     newTyVarTy liftedTypeKind                                   `thenM` \ elt_ty ->
 337     unifyTauTy res_ty (mkAppTy m_ty elt_ty)                     `thenM_`
 338
 339     tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts        `thenM` \ stmts' ->
 340
 341         -- Build the then and zero methods in case we need them
 342         -- It's important that "then" and "return" appear just once in the final LIE,
 343         -- not only for typechecker efficiency, but also because otherwise during
 344         -- simplification we end up with silly stuff like
 345         --      then = case d of (t,r) -> t
 346         --      then = then
 347         -- where the second "then" sees that it already exists in the "available" stuff.
 348         --
 349     mapAndUnzipM (tc_syn_name m_ty)
 350                  (zipEqual "tcDoStmts" monadNames method_names)  `thenM` \ (binds, ids) ->
 351     returnM (andMonoBindList binds, stmts', ids)
 352   where
 353     tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
 354     tc_syn_name m_ty (std_nm, usr_nm)
 355         = tcSyntaxName DoOrigin m_ty std_nm usr_nm      `thenM` \ (expr, expr_ty) ->
 356           case expr of
 357             HsVar v -> returnM (EmptyMonoBinds, v)
 358             other   -> newUnique                `thenM` \ uniq ->
 359                        let
 360                           id = mkSysLocal FSLIT("syn") uniq expr_ty
 361                        in
 362                        returnM (VarMonoBind id expr, id)
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{tcStmts}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 373
 374         [ (g x, h x) | ... ; let g v = ...
 375                      | ... ; let h v = ... ]
 376
 377 It's possible that g,h are overloaded, so we need to feed the LIE from the
 378 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 379 Similarly if we had an existential pattern match:
 380
 381         data T = forall a. Show a => C a
 382
 383         [ (show x, show y) | ... ; C x <- ...
 384                            | ... ; C y <- ... ]
 385
 386 Then we need the LIE from (show x, show y) to be simplified against
 387 the bindings for x and y.
 388
 389 It's difficult to do this in parallel, so we rely on the renamer to
 390 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 391 So the binders of the first parallel group will be in scope in the second
 392 group.  But that's fine; there's no shadowing to worry about.
 393
 394 \begin{code}
 395 tcStmts do_or_lc m_ty stmts
 396   = ASSERT( notNull stmts )
 397     tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
 398
 399 tcStmtsAndThen
 400         :: (TcStmt -> thing -> thing)   -- Combiner
 401         -> RenamedMatchContext
 402         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 403                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 404         -> [RenamedStmt]
 405         -> TcM thing
 406         -> TcM thing
 407
 408         -- Base case
 409 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 410   = do_next
 411
 412 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 413   = tcStmtAndThen combine do_or_lc m_ty stmt
 414         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 415
 416         -- LetStmt
 417 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 418   = tcBindsAndThen              -- No error context, but a binding group is
 419         (glue_binds combine)    -- rather a large thing for an error context anyway
 420         binds
 421         thing_inside
 422
 423 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 424   = addSrcLoc src_loc                                   $
 425     addErrCtxt (stmtCtxt do_or_lc stmt)         $
 426     newTyVarTy liftedTypeKind                           `thenM` \ pat_ty ->
 427     tcMonoExpr exp (m pat_ty)                           `thenM` \ exp' ->
 428     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ _ ->
 429         popErrCtxt thing_inside
 430     )                                                   `thenM` \ ([pat'], thing, dict_binds) ->
 431     returnM (combine (BindStmt pat' exp' src_loc)
 432                      (glue_binds combine Recursive dict_binds thing))
 433
 434         -- ParStmt
 435 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 436   = loop bndr_stmts_s           `thenM` \ (pairs', thing) ->
 437     returnM (combine (ParStmtOut pairs') thing)
 438   where
 439     loop []
 440       = thing_inside                    `thenM` \ thing ->
 441         returnM ([], thing)
 442
 443     loop ((bndrs,stmts) : pairs)
 444       = tcStmtsAndThen
 445                 combine_par (DoCtxt ListComp) m_ty stmts
 446                         -- Notice we pass on m_ty; the result type is used only
 447                         -- to get escaping type variables for checkExistentialPat
 448                 (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
 449                  loop pairs             `thenM` \ (pairs', thing) ->
 450                  returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
 451
 452         returnM ((bndrs',stmts') : pairs', thing)
 453
 454     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 455
 456         -- ExprStmt
 457 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 458   = setErrCtxt (stmtCtxt do_or_lc stmt) (
 459         if isDoExpr do_or_lc then
 460                 newTyVarTy openTypeKind         `thenM` \ any_ty ->
 461                 tcMonoExpr exp (m any_ty)       `thenM` \ exp' ->
 462                 returnM (ExprStmt exp' any_ty locn)
 463         else
 464                 tcMonoExpr exp boolTy           `thenM` \ exp' ->
 465                 returnM (ExprStmt exp' boolTy locn)
 466     )                                           `thenM` \ stmt' ->
 467
 468     thing_inside                                `thenM` \ thing ->
 469     returnM (combine stmt' thing)
 470
 471
 472         -- Result statements
 473 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 474   = setErrCtxt (stmtCtxt do_or_lc stmt) (
 475         if isDoExpr do_or_lc then
 476                 tcMonoExpr exp (m res_elt_ty)
 477         else
 478                 tcMonoExpr exp res_elt_ty
 479     )                                           `thenM` \ exp' ->
 480
 481     thing_inside                                `thenM` \ thing ->
 482
 483     returnM (combine (ResultStmt exp' locn) thing)
 484
 485
 486 ------------------------------
 487 glue_binds combine is_rec binds thing
 488   | nullMonoBinds binds = thing
 489   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 490 \end{code}
 491
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection{Errors and contexts}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 500 number of args are used in each equation.
 501
 502 \begin{code}
 503 sameNoOfArgs :: [RenamedMatch] -> Bool
 504 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 505   where
 506     args_in_match :: RenamedMatch -> Int
 507     args_in_match (Match pats _ _) = length pats
 508 \end{code}
 509
 510 \begin{code}
 511 varyingArgsErr name matches
 512   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 513
 514 matchCtxt ctxt  match  = hang (pprMatchContext ctxt     <> colon) 4 (pprMatch ctxt match)
 515 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 516
 517 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
 518   = zonkTcType match_ty         `thenM` \ match_ty' ->
 519     let
 520         (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 521         (env2, tidy_mty) = tidyOpenType  env1     match_ty'
 522     in
 523     returnM (env1,
 524                  sep [ptext SLIT("When checking an existential match that binds"),
 525                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 526                       ptext SLIT("and whose type is") <+> ppr tidy_mty])
 527   where
 528     show_ids = filter is_interesting bound_ids
 529     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 530
 531     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 532         -- Don't zonk the types so we get the separate, un-unified versions
 533 \end{code}