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