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(..), HsStmtContext(..),
  17                           pprMatch, getMatchLoc, pprMatchContext, pprStmtCtxt, 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, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
  29 import TcPat            ( tcPat, tcMonoPatBndr )
  30 import TcMType          ( newTyVarTy, newTyVarTys, 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, (<$>), unifyTauTyLists )
  37 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  38 import Name             ( Name )
  39 import PrelNames        ( monadNames, mfixName )
  40 import TysWiredIn       ( boolTy, mkListTy, mkPArrTy )
  41 import Id               ( idType, mkSysLocal, mkLocalId )
  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 PatGuard (\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 :: HsStmtContext -> [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 PArrComp (mkPArrTy, elt_ty) stmts      `thenM` \ stmts' ->
 325     returnM (EmptyMonoBinds, stmts', [{- unused -}])
 326
 327 tcDoStmts ListComp stmts method_names res_ty
 328   = unifyListTy res_ty                          `thenM` \ elt_ty ->
 329     tcStmts ListComp (mkListTy, elt_ty) stmts   `thenM` \ stmts' ->
 330     returnM (EmptyMonoBinds, stmts', [{- unused -}])
 331
 332 tcDoStmts do_or_mdo_expr stmts method_names res_ty
 333   = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)      `thenM` \ m_ty ->
 334     newTyVarTy liftedTypeKind                                   `thenM` \ elt_ty ->
 335     unifyTauTy res_ty (mkAppTy m_ty elt_ty)                     `thenM_`
 336
 337     tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts         `thenM` \ stmts' ->
 338
 339         -- Build the then and zero methods in case we need them
 340         -- It's important that "then" and "return" appear just once in the final LIE,
 341         -- not only for typechecker efficiency, but also because otherwise during
 342         -- simplification we end up with silly stuff like
 343         --      then = case d of (t,r) -> t
 344         --      then = then
 345         -- where the second "then" sees that it already exists in the "available" stuff.
 346         --
 347     mapAndUnzipM (tc_syn_name m_ty)
 348                  (zipEqual "tcDoStmts" currentMonadNames method_names)  `thenM` \ (binds, ids) ->
 349     returnM (andMonoBindList binds, stmts', ids)
 350   where
 351     currentMonadNames = case do_or_mdo_expr of
 352                           DoExpr  -> monadNames
 353                           MDoExpr -> monadNames ++ [mfixName]
 354     tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
 355     tc_syn_name m_ty (std_nm, usr_nm)
 356         = tcSyntaxName DoOrigin m_ty std_nm usr_nm      `thenM` \ (expr, expr_ty) ->
 357           case expr of
 358             HsVar v -> returnM (EmptyMonoBinds, v)
 359             other   -> newUnique                `thenM` \ uniq ->
 360                        let
 361                           id = mkSysLocal FSLIT("syn") uniq expr_ty
 362                        in
 363                        returnM (VarMonoBind id expr, id)
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{tcStmts}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 374
 375         [ (g x, h x) | ... ; let g v = ...
 376                      | ... ; let h v = ... ]
 377
 378 It's possible that g,h are overloaded, so we need to feed the LIE from the
 379 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 380 Similarly if we had an existential pattern match:
 381
 382         data T = forall a. Show a => C a
 383
 384         [ (show x, show y) | ... ; C x <- ...
 385                            | ... ; C y <- ... ]
 386
 387 Then we need the LIE from (show x, show y) to be simplified against
 388 the bindings for x and y.
 389
 390 It's difficult to do this in parallel, so we rely on the renamer to
 391 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 392 So the binders of the first parallel group will be in scope in the second
 393 group.  But that's fine; there's no shadowing to worry about.
 394
 395 \begin{code}
 396 tcStmts do_or_lc m_ty stmts
 397   = ASSERT( notNull stmts )
 398     tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
 399
 400 tcStmtsAndThen
 401         :: (TcStmt -> thing -> thing)   -- Combiner
 402         -> HsStmtContext
 403         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 404                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 405         -> [RenamedStmt]
 406         -> TcM thing
 407         -> TcM thing
 408
 409         -- Base case
 410 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 411   = do_next
 412
 413 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 414   = tcStmtAndThen combine do_or_lc m_ty stmt
 415         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 416
 417         -- LetStmt
 418 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 419   = tcBindsAndThen              -- No error context, but a binding group is
 420         (glue_binds combine)    -- rather a large thing for an error context anyway
 421         binds
 422         thing_inside
 423
 424 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 425   = addSrcLoc src_loc                                   $
 426     addErrCtxt (stmtCtxt do_or_lc stmt)         $
 427     newTyVarTy liftedTypeKind                           `thenM` \ pat_ty ->
 428     tcMonoExpr exp (m pat_ty)                           `thenM` \ exp' ->
 429     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ _ ->
 430         popErrCtxt thing_inside
 431     )                                                   `thenM` \ ([pat'], thing, dict_binds) ->
 432     returnM (combine (BindStmt pat' exp' src_loc)
 433                      (glue_binds combine Recursive dict_binds thing))
 434
 435         -- ParStmt
 436 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 437   = loop bndr_stmts_s           `thenM` \ (pairs', thing) ->
 438     returnM (combine (ParStmtOut pairs') thing)
 439   where
 440     loop []
 441       = thing_inside                    `thenM` \ thing ->
 442         returnM ([], thing)
 443
 444     loop ((bndrs,stmts) : pairs)
 445       = tcStmtsAndThen
 446                 combine_par ListComp m_ty stmts
 447                         -- Notice we pass on m_ty; the result type is used only
 448                         -- to get escaping type variables for checkExistentialPat
 449                 (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
 450                  loop pairs             `thenM` \ (pairs', thing) ->
 451                  returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
 452
 453         returnM ((bndrs',stmts') : pairs', thing)
 454
 455     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 456
 457         -- RecStmt
 458 tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts) thing_inside
 459   = newTyVarTys (length recNames) liftedTypeKind                `thenM` \ recTys ->
 460     tcExtendLocalValEnv (zipWith mkLocalId recNames recTys)     $
 461     tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
 462         tcLookupLocalIds recNames  `thenM` \ rn ->
 463         returnM ([], rn)
 464     )                                                           `thenM` \ (stmts', recNames') ->
 465
 466     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 467     unifyTauTyLists recTys (map idType recNames')       `thenM_`
 468
 469     thing_inside                                        `thenM` \ thing ->
 470
 471     returnM (combine (RecStmt recNames' stmts') thing)
 472   where
 473     combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
 474
 475         -- ExprStmt
 476 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 477   = setErrCtxt (stmtCtxt do_or_lc stmt) (
 478         if isDoExpr do_or_lc then
 479                 newTyVarTy openTypeKind         `thenM` \ any_ty ->
 480                 tcMonoExpr exp (m any_ty)       `thenM` \ exp' ->
 481                 returnM (ExprStmt exp' any_ty locn)
 482         else
 483                 tcMonoExpr exp boolTy           `thenM` \ exp' ->
 484                 returnM (ExprStmt exp' boolTy locn)
 485     )                                           `thenM` \ stmt' ->
 486
 487     thing_inside                                `thenM` \ thing ->
 488     returnM (combine stmt' thing)
 489
 490
 491         -- Result statements
 492 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 493   = setErrCtxt (stmtCtxt do_or_lc stmt) (
 494         if isDoExpr do_or_lc then
 495                 tcMonoExpr exp (m res_elt_ty)
 496         else
 497                 tcMonoExpr exp res_elt_ty
 498     )                                           `thenM` \ exp' ->
 499
 500     thing_inside                                `thenM` \ thing ->
 501
 502     returnM (combine (ResultStmt exp' locn) thing)
 503
 504
 505 ------------------------------
 506 glue_binds combine is_rec binds thing
 507   | nullMonoBinds binds = thing
 508   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 509 \end{code}
 510
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection{Errors and contexts}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 519 number of args are used in each equation.
 520
 521 \begin{code}
 522 sameNoOfArgs :: [RenamedMatch] -> Bool
 523 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 524   where
 525     args_in_match :: RenamedMatch -> Int
 526     args_in_match (Match pats _ _) = length pats
 527 \end{code}
 528
 529 \begin{code}
 530 varyingArgsErr name matches
 531   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 532
 533 matchCtxt ctxt  match  = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
 534 stmtCtxt do_or_lc stmt = hang (pprStmtCtxt do_or_lc <> colon) 4 (ppr stmt)
 535
 536 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
 537   = zonkTcType match_ty         `thenM` \ match_ty' ->
 538     let
 539         (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 540         (env2, tidy_mty) = tidyOpenType  env1     match_ty'
 541     in
 542     returnM (env1,
 543                  sep [ptext SLIT("When checking an existential match that binds"),
 544                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 545                       ptext SLIT("and whose type is") <+> ppr tidy_mty])
 546   where
 547     show_ids = filter is_interesting bound_ids
 548     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 549
 550     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 551         -- Don't zonk the types so we get the separate, un-unified versions
 552 \end{code}