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