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, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
   8                    matchCtxt,
   9                    tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
  10                    tcMatchPats,
  11                    TcStmtCtxt(..), TcMatchCtxt(..)
  12        ) where
  13
  14 #include "HsVersions.h"
  15
  16 import {-# SOURCE #-}   TcExpr( tcCheckRho, tcMonoExpr )
  17
  18 import HsSyn            ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  19                           MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
  20                           ReboundNames,
  21                           pprMatch, getMatchLoc, isDoExpr,
  22                           pprMatchContext, pprStmtContext, pprStmtResultContext,
  23                           mkMonoBind, collectSigTysFromPats, glueBindsOnGRHSs
  24                         )
  25 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr,
  26                           RenamedPat, RenamedMatchContext )
  27 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr,
  28                           TcPat, TcStmt, ExprCoFn,
  29                           isIdCoercion, (<$>), (<.>) )
  30
  31 import TcRnMonad
  32 import TcHsType         ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
  33 import Inst             ( tcSyntaxName, tcInstCall )
  34 import TcEnv            ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
  35 import TcPat            ( tcPat, tcMonoPatBndr )
  36 import TcMType          ( newTyVarTy, newTyVarTys, zonkTcType )
  37 import TcType           ( TcType, TcTyVar, TcSigmaType, TcRhoType,
  38                           tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
  39                           mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
  40                           mkArrowKind, mkAppTy )
  41 import TcBinds          ( tcBindsAndThen )
  42 import TcUnify          ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
  43                           unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy,
  44                           checkSigTyVarsWrt, tcSubExp, tcGen )
  45 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  46 import Name             ( Name )
  47 import TysWiredIn       ( boolTy, mkListTy, mkPArrTy )
  48 import Id               ( idType, mkLocalId )
  49 import CoreFVs          ( idFreeTyVars )
  50 import BasicTypes       ( RecFlag(..) )
  51 import VarSet
  52 import Bag
  53 import Util             ( isSingleton, notNull )
  54 import Outputable
  55
  56 import List             ( nub )
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{tcMatchesFun, tcMatchesCase}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  66 @FunMonoBind@.  The second argument is the name of the function, which
  67 is used in error messages.  It checks that all the equations have the
  68 same number of arguments before using @tcMatches@ to do the work.
  69
  70 \begin{code}
  71 tcMatchesFun :: Name
  72              -> [RenamedMatch]
  73              -> Expected TcRhoType              -- Expected type
  74              -> TcM [TcMatch]
  75
  76 tcMatchesFun fun_name matches@(first_match:_) expected_ty
  77   =      -- Check that they all have the same no of arguments
  78          -- Set the location to that of the first equation, so that
  79          -- any inter-equation error messages get some vaguely
  80          -- sensible location.  Note: we have to do this odd
  81          -- ann-grabbing, because we don't always have annotations in
  82          -- hand when we call tcMatchesFun...
  83     addSrcLoc (getMatchLoc first_match)  (
  84             checkTc (sameNoOfArgs matches)
  85                     (varyingArgsErr fun_name matches)
  86     )                                            `thenM_`
  87
  88         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  89         -- because inconsistency between branches
  90         -- may show up as something wrong with the (non-existent) type signature
  91
  92         -- No need to zonk expected_ty, because subFunTys does that on the fly
  93     tcMatches match_ctxt matches expected_ty
  94   where
  95     match_ctxt = MC { mc_what = FunRhs fun_name,
  96                       mc_body = tcMonoExpr }
  97 \end{code}
  98
  99 @tcMatchesCase@ doesn't do the argument-count check because the
 100 parser guarantees that each equation has exactly one argument.
 101
 102 \begin{code}
 103 tcMatchesCase :: TcMatchCtxt            -- Case context
 104               -> [RenamedMatch]         -- The case alternatives
 105               -> Expected TcRhoType     -- Type of whole case expressions
 106               -> TcM (TcRhoType,        -- Inferred type of the scrutinee
 107                       [TcMatch])        -- Translated alternatives
 108
 109 tcMatchesCase ctxt matches (Check expr_ty)
 110   =     -- This case is a bit yukky, because it prevents the
 111         -- scrutinee being higher-ranked, which might just possible
 112         -- matter if we were seq'ing on it.  But it's awkward to fix.
 113     newTyVarTy openTypeKind                                             `thenM` \ scrut_ty ->
 114     tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty))   `thenM` \ matches' ->
 115     returnM (scrut_ty, matches')
 116
 117 tcMatchesCase ctxt matches (Infer hole)
 118   = newHole                                     `thenM` \ fun_hole ->
 119     tcMatches ctxt matches (Infer fun_hole)     `thenM` \ matches' ->
 120     readMutVar fun_hole                         `thenM` \ fun_ty ->
 121         -- The result of tcMatches is bound to be a function type
 122     unifyFunTy fun_ty                           `thenM` \ (scrut_ty, res_ty) ->
 123     writeMutVar hole res_ty                     `thenM_`
 124     returnM (scrut_ty, matches')
 125
 126
 127 tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
 128 tcMatchLambda match res_ty = tcMatch match_ctxt match res_ty
 129   where
 130     match_ctxt = MC { mc_what = LambdaExpr,
 131                       mc_body = tcMonoExpr }
 132 \end{code}
 133
 134 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 135
 136 \begin{code}
 137 tcGRHSsPat :: RenamedGRHSs
 138            -> Expected TcRhoType
 139            -> TcM TcGRHSs
 140 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
 141   where
 142     match_ctxt = MC { mc_what = PatBindRhs,
 143                       mc_body = tcMonoExpr }
 144 \end{code}
 145
 146 \begin{code}
 147 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 148   = MC { mc_what :: RenamedMatchContext,        -- What kind of thing this is
 149          mc_body :: RenamedHsExpr               -- Type checker for a body of an alternative
 150                     -> Expected TcRhoType
 151                     -> TcM TcExpr }
 152
 153 tcMatches :: TcMatchCtxt
 154           -> [RenamedMatch]
 155           -> Expected TcRhoType
 156           -> TcM [TcMatch]
 157
 158 tcMatches ctxt matches exp_ty
 159   =     -- If there is more than one branch, and exp_ty is a 'hole',
 160         -- all branches must be types, not type schemes, otherwise the
 161         -- order in which we check them would affect the result.
 162     zapExpectedBranches matches exp_ty  `thenM` \ exp_ty' ->
 163     mappM (tc_match exp_ty') matches
 164   where
 165     tc_match exp_ty match = tcMatch ctxt match exp_ty
 166 \end{code}
 167
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 \subsection{tcMatch}
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 \begin{code}
 176 tcMatch :: TcMatchCtxt
 177         -> RenamedMatch
 178         -> Expected TcRhoType   -- Expected result-type of the Match.
 179                         -- Early unification with this guy gives better error messages
 180                         -- We regard the Match as having type
 181                         --      (ty1 -> ... -> tyn -> result_ty)
 182                         -- where there are n patterns.
 183         -> TcM TcMatch
 184
 185 tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
 186   = addSrcLoc (getMatchLoc match)               $       -- At one stage I removed this;
 187     addErrCtxt (matchCtxt (mc_what ctxt) match) $       -- I'm not sure why, so I put it back
 188     subFunTys pats expected_ty                  $ \ pats_w_tys rhs_ty ->
 189         -- This is the unique place we call subFunTys
 190         -- The point is that if expected_y is a "hole", we want
 191         -- to make arg_ty and rest_ty as "holes" too.
 192     tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty)     `thenM` \ (pats', grhss', ex_binds) ->
 193     returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
 194
 195   where
 196     tc_grhss rhs_ty
 197         = case maybe_rhs_sig of  -- Deal with the result signature
 198             Nothing  ->  tcGRHSs ctxt grhss rhs_ty
 199
 200             Just sig ->  tcAddScopedTyVars [sig]        $
 201                                 -- Bring into scope the type variables in the signature
 202                          tcHsSigType ResSigCtxt sig                                     `thenM` \ sig_ty ->
 203                          tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty      `thenM` \ (co_fn, grhss') ->
 204
 205                         -- Pushes the coercion down to the right hand sides,
 206                         -- because there is no convenient place to hang it otherwise.
 207                          if isIdCoercion co_fn then
 208                                 returnM grhss'
 209                          else
 210                          readExpectedType rhs_ty                `thenM` \ rhs_ty' ->
 211                          returnM (lift_grhss co_fn rhs_ty' grhss')
 212
 213 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
 214   = GRHSs (map lift_grhs grhss) binds rhs_ty    -- Change the type, since the coercion does
 215   where
 216     lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
 217
 218     lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
 219     lift_stmt stmt             = stmt
 220
 221 tcGRHSs :: TcMatchCtxt -> RenamedGRHSs
 222         -> Expected TcRhoType
 223         -> TcM TcGRHSs
 224
 225   -- Special case when there is just one equation with a degenerate
 226   -- guard; then we pass in the full Expected type, so that we get
 227   -- good inference from simple things like
 228   --    f = \(x::forall a.a->a) -> <stuff>
 229   -- This is a consequence of the fact that tcStmts takes a TcType,
 230   -- not a Expected TcType, a decision we could revisit if necessary
 231 tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
 232   = tcBindsAndThen glueBindsOnGRHSs binds       $
 233     mc_body ctxt rhs exp_ty                     `thenM` \ rhs' ->
 234     readExpectedType exp_ty                     `thenM` \ exp_ty' ->
 235     returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
 236
 237 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
 238   = tcBindsAndThen glueBindsOnGRHSs binds       $
 239     zapExpectedType exp_ty                      `thenM` \ exp_ty' ->
 240         -- Even if there is only one guard, we zap the RHS type to
 241         -- a monotype.  Reason: it makes tcStmts much easier,
 242         -- and even a one-armed guard has a notional second arm
 243     let
 244       stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
 245                        sc_rhs  = tcCheckRho,
 246                        sc_body = sc_body,
 247                        sc_ty   = exp_ty' }
 248       sc_body body = mc_body ctxt body (Check exp_ty')
 249
 250       tc_grhs (GRHS guarded locn)
 251         = addSrcLoc locn                $
 252           tcStmts stmt_ctxt  guarded    `thenM` \ guarded' ->
 253           returnM (GRHS guarded' locn)
 254     in
 255     mappM tc_grhs grhss                 `thenM` \ grhss' ->
 256     returnM (GRHSs grhss' EmptyBinds exp_ty')
 257 \end{code}
 258
 259
 260 \begin{code}
 261 tcThingWithSig :: TcSigmaType           -- Type signature
 262                -> (TcRhoType -> TcM r)  -- How to type check the thing inside
 263                -> Expected TcRhoType    -- Overall expected result type
 264                -> TcM (ExprCoFn, r)
 265 -- Used for expressions with a type signature, and for result type signatures
 266
 267 tcThingWithSig sig_ty thing_inside res_ty
 268   | not (isSigmaTy sig_ty)
 269   = thing_inside sig_ty         `thenM` \ result ->
 270     tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
 271     returnM (co_fn, result)
 272
 273   | otherwise   -- The signature has some outer foralls
 274   =     -- Must instantiate the outer for-alls of sig_tc_ty
 275         -- else we risk instantiating a ? res_ty to a forall-type
 276         -- which breaks the invariant that tcMonoExpr only returns phi-types
 277     tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
 278     tcInstCall SignatureOrigin sig_ty           `thenM` \ (inst_fn, inst_sig_ty) ->
 279     tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
 280     returnM (co_fn <.> inst_fn <.> gen_fn,  result)
 281         -- Note that we generalise, then instantiate. Ah well.
 282 \end{code}
 283
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection{tcMatchPats}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 tcMatchPats
 293         :: [(RenamedPat, Expected TcRhoType)]
 294         -> Expected TcRhoType
 295         -> TcM a
 296         -> TcM ([TcPat], a, TcHsBinds)
 297 -- Typecheck the patterns, extend the environment to bind the variables,
 298 -- do the thing inside, use any existentially-bound dictionaries to
 299 -- discharge parts of the returning LIE, and deal with pattern type
 300 -- signatures
 301
 302 tcMatchPats pats_w_tys body_ty thing_inside
 303   =     -- STEP 1: Bring pattern-signature type variables into scope
 304     tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys))      (
 305
 306         -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
 307         --         then do the thing inside
 308         getLIE (tc_match_pats pats_w_tys thing_inside)
 309
 310     ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
 311
 312         -- STEP 4: Check for existentially bound type variables
 313         -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
 314         -- complains that 'a' is captured by the inscope 'a'!  (Test (d) in checkSigTyVars.)
 315         --
 316         -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
 317         -- might need (via lie_req2) something made available from an 'outer'
 318         -- pattern.  But it's inconvenient to deal with, and I can't find an example
 319     tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
 320                           pats_w_tys body_ty            `thenM` \ ex_binds ->
 321         -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
 322         -- For example, we must reject this program:
 323         --      data C = forall a. C (a -> Int)
 324         --      f (C g) x = g x
 325         -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 326
 327     returnM (pats', result, mkMonoBind Recursive ex_binds)
 328
 329 tc_match_pats [] thing_inside
 330   = thing_inside        `thenM` \ answer ->
 331     returnM ([], emptyBag, [], [], answer)
 332
 333 tc_match_pats ((pat,pat_ty):pats) thing_inside
 334   = tcPat tcMonoPatBndr pat pat_ty      `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
 335     let
 336         xve    = bagToList pat_bndrs
 337         ex_ids = [id | (_, id) <- xve]
 338                 -- ex_ids is all the pattern-bound Ids, a superset
 339                 -- of the existential Ids used in checkExistentialPat
 340     in
 341     tcExtendLocalValEnv2 xve                    $
 342     tc_match_pats pats thing_inside     `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
 343     returnM (   pat':pats',
 344                 ex_tvs `unionBags` exs_tvs,
 345                 ex_ids ++ exs_ids,
 346                 ex_lie ++ exs_lie,
 347                 answer
 348     )
 349
 350
 351 tcCheckExistentialPat :: Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 352                       -> [TcId]         -- Ids bound by this pattern; used
 353                                         --   (a) by bindsInstsOfLocalFuns
 354                                         --   (b) to generate helpful error messages
 355                       -> [Inst]         --   and context
 356                       -> [Inst]         -- Required context
 357                       -> [(pat,Expected TcRhoType)]     -- Types of the patterns
 358                       -> Expected TcRhoType             -- Type of the body of the match
 359                                                         -- Tyvars in either of these must not escape
 360                       -> TcM TcDictBinds        -- LIE to float out and dict bindings
 361 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty
 362   | isEmptyBag ex_tvs && all not_overloaded ex_ids
 363         -- Short cut for case when there are no existentials
 364         -- and no polymorphic overloaded variables
 365         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 366         --       f op x = ....
 367         --  Here we must discharge op Methods
 368   = ASSERT( null ex_lie )
 369     extendLIEs lie_req          `thenM_`
 370     returnM EmptyMonoBinds
 371
 372   | otherwise
 373   =     -- Read the by-now-filled-in expected types
 374     mapM readExpectedType (body_ty : map snd pats_w_tys)        `thenM` \ tys ->
 375     addErrCtxtM (sigPatCtxt tv_list ex_ids tys)                 $
 376
 377         -- In case there are any polymorpic, overloaded binders in the pattern
 378         -- (which can happen in the case of rank-2 type signatures, or data constructors
 379         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 380     getLIE (bindInstsOfLocalFuns lie_req ex_ids)        `thenM` \ (inst_binds, lie) ->
 381
 382         -- Deal with overloaded functions bound by the pattern
 383     tcSimplifyCheck doc tv_list ex_lie lie              `thenM` \ dict_binds ->
 384
 385         -- Check for type variable escape
 386     checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list               `thenM_`
 387
 388     returnM (dict_binds `AndMonoBinds` inst_binds)
 389   where
 390     doc     = text ("existential context of a data constructor")
 391     tv_list = bagToList ex_tvs
 392     not_overloaded id = not (isOverloadedTy (idType id))
 393 \end{code}
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 \begin{code}
 403 tcDoStmts :: HsStmtContext Name
 404           -> [RenamedStmt] -> ReboundNames Name
 405           -> TcRhoType          -- To keep it simple, we don't have an "expected" type here
 406           -> TcM ([TcStmt], ReboundNames TcId)
 407 tcDoStmts PArrComp stmts method_names res_ty
 408   = unifyPArrTy res_ty                                  `thenM` \elt_ty ->
 409     tcComprehension PArrComp mkPArrTy elt_ty stmts      `thenM` \ stmts' ->
 410     returnM (stmts', [{- unused -}])
 411
 412 tcDoStmts ListComp stmts method_names res_ty
 413   = unifyListTy res_ty                          `       thenM` \ elt_ty ->
 414     tcComprehension ListComp mkListTy elt_ty stmts      `thenM` \ stmts' ->
 415     returnM (stmts', [{- unused -}])
 416
 417 tcDoStmts do_or_mdo stmts method_names res_ty
 418   = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)      `thenM` \ m_ty ->
 419     newTyVarTy liftedTypeKind                                   `thenM` \ elt_ty ->
 420     unifyTauTy res_ty (mkAppTy m_ty elt_ty)                     `thenM_`
 421     let
 422         ctxt = SC { sc_what = do_or_mdo,
 423                     sc_rhs  = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
 424                     sc_body = \ body -> tcCheckRho body res_ty,
 425                     sc_ty   = res_ty }
 426     in
 427     tcStmts ctxt stmts                                          `thenM` \ stmts' ->
 428
 429         -- Build the then and zero methods in case we need them
 430         -- It's important that "then" and "return" appear just once in the final LIE,
 431         -- not only for typechecker efficiency, but also because otherwise during
 432         -- simplification we end up with silly stuff like
 433         --      then = case d of (t,r) -> t
 434         --      then = then
 435         -- where the second "then" sees that it already exists in the "available" stuff.
 436     mapM (tcSyntaxName DoOrigin m_ty) method_names                `thenM` \ methods ->
 437
 438     returnM (stmts', methods)
 439
 440 tcComprehension do_or_lc mk_mty elt_ty stmts
 441   = tcStmts ctxt stmts
 442   where
 443     ctxt = SC { sc_what = do_or_lc,
 444                 sc_rhs  = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
 445                 sc_body = \ body -> tcCheckRho body elt_ty,     -- Note: no mk_mty!
 446                 sc_ty   = mk_mty elt_ty }
 447 \end{code}
 448
 449
 450 %************************************************************************
 451 %*                                                                      *
 452 \subsection{tcStmts}
 453 %*                                                                      *
 454 %************************************************************************
 455
 456 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 457
 458         [ (g x, h x) | ... ; let g v = ...
 459                      | ... ; let h v = ... ]
 460
 461 It's possible that g,h are overloaded, so we need to feed the LIE from the
 462 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 463 Similarly if we had an existential pattern match:
 464
 465         data T = forall a. Show a => C a
 466
 467         [ (show x, show y) | ... ; C x <- ...
 468                            | ... ; C y <- ... ]
 469
 470 Then we need the LIE from (show x, show y) to be simplified against
 471 the bindings for x and y.
 472
 473 It's difficult to do this in parallel, so we rely on the renamer to
 474 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 475 So the binders of the first parallel group will be in scope in the second
 476 group.  But that's fine; there's no shadowing to worry about.
 477
 478 \begin{code}
 479 tcStmts ctxt stmts
 480   = ASSERT( notNull stmts )
 481     tcStmtsAndThen (:) ctxt stmts (returnM [])
 482
 483 data TcStmtCtxt
 484   = SC { sc_what :: HsStmtContext Name,                         -- What kind of thing this is
 485          sc_rhs  :: RenamedHsExpr -> TcType -> TcM TcExpr,      -- Type checker for RHS computations
 486          sc_body :: RenamedHsExpr -> TcM TcExpr,                -- Type checker for return computation
 487          sc_ty   :: TcType }                                    -- Return type; used *only* to check
 488                                                                 -- for escape in existential patterns
 489 tcStmtsAndThen
 490         :: (TcStmt -> thing -> thing)   -- Combiner
 491         -> TcStmtCtxt
 492         -> [RenamedStmt]
 493         -> TcM thing
 494         -> TcM thing
 495
 496         -- Base case
 497 tcStmtsAndThen combine ctxt [] thing_inside
 498   = thing_inside
 499
 500 tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
 501   = tcStmtAndThen  combine ctxt stmt  $
 502     tcStmtsAndThen combine ctxt stmts $
 503     thing_inside
 504
 505         -- LetStmt
 506 tcStmtAndThen combine ctxt (LetStmt binds) thing_inside
 507   = tcBindsAndThen              -- No error context, but a binding group is
 508         (glue_binds combine)    -- rather a large thing for an error context anyway
 509         binds
 510         thing_inside
 511
 512         -- BindStmt
 513 tcStmtAndThen combine ctxt stmt@(BindStmt pat exp src_loc) thing_inside
 514   = addSrcLoc src_loc                                   $
 515     addErrCtxt (stmtCtxt ctxt stmt)                     $
 516     newTyVarTy liftedTypeKind                           `thenM` \ pat_ty ->
 517     sc_rhs ctxt exp pat_ty                              `thenM` \ exp' ->
 518     tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
 519         popErrCtxt thing_inside
 520     )                                                   `thenM` \ ([pat'], thing, dict_binds) ->
 521     returnM (combine (BindStmt pat' exp' src_loc)
 522                      (glue_binds combine dict_binds thing))
 523
 524         -- ExprStmt
 525 tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside
 526   = addSrcLoc src_loc           (
 527         addErrCtxt (stmtCtxt ctxt stmt) $
 528         if isDoExpr (sc_what ctxt)
 529         then    -- do or mdo; the expression is a computation
 530                 newTyVarTy openTypeKind         `thenM` \ any_ty ->
 531                 sc_rhs ctxt exp any_ty          `thenM` \ exp' ->
 532                 returnM (ExprStmt exp' any_ty src_loc)
 533         else    -- List comprehensions, pattern guards; expression is a boolean
 534                 tcCheckRho exp boolTy           `thenM` \ exp' ->
 535                 returnM (ExprStmt exp' boolTy src_loc)
 536     )                                           `thenM` \ stmt' ->
 537
 538     thing_inside                                `thenM` \ thing ->
 539     returnM (combine stmt' thing)
 540
 541
 542         -- ParStmt
 543 tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside
 544   = loop bndr_stmts_s           `thenM` \ (pairs', thing) ->
 545     returnM (combine (ParStmt pairs') thing)
 546   where
 547     loop [] = thing_inside              `thenM` \ thing ->
 548               returnM ([], thing)
 549
 550     loop ((stmts, bndrs) : pairs)
 551       = tcStmtsAndThen combine_par ctxt stmts $
 552                         -- Notice we pass on ctxt; the result type is used only
 553                         -- to get escaping type variables for checkExistentialPat
 554         tcLookupLocalIds bndrs          `thenM` \ bndrs' ->
 555         loop pairs                      `thenM` \ (pairs', thing) ->
 556         returnM (([], bndrs') : pairs', thing)
 557
 558     combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
 559
 560         -- RecStmt
 561 tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside
 562   = newTyVarTys (length recNames) liftedTypeKind                `thenM` \ recTys ->
 563     let
 564         rec_ids = zipWith mkLocalId recNames recTys
 565     in
 566     tcExtendLocalValEnv rec_ids                 $
 567     tcStmtsAndThen combine_rec ctxt stmts (
 568         mappM tc_ret (recNames `zip` recTys)    `thenM` \ rec_rets ->
 569         tcLookupLocalIds laterNames             `thenM` \ later_ids ->
 570         returnM ([], (later_ids, rec_rets))
 571     )                                           `thenM` \ (stmts', (later_ids, rec_rets)) ->
 572
 573     tcExtendLocalValEnv later_ids               $
 574         -- NB:  The rec_ids for the recursive things
 575         --      already scope over this part
 576     thing_inside                                `thenM` \ thing ->
 577
 578     returnM (combine (RecStmt stmts' later_ids rec_ids rec_rets) thing)
 579   where
 580     combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
 581
 582     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 583     tc_ret (rec_name, mono_ty)
 584         = tcLookupId rec_name                           `thenM` \ poly_id ->
 585                 -- poly_id may have a polymorphic type
 586                 -- but mono_ty is just a monomorphic type variable
 587           tcSubExp (Check mono_ty) (idType poly_id)     `thenM` \ co_fn ->
 588           returnM (co_fn <$> HsVar poly_id)
 589
 590         -- Result statements
 591 tcStmtAndThen combine ctxt stmt@(ResultStmt exp locn) thing_inside
 592   = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp)  `thenM` \ exp' ->
 593     thing_inside                                        `thenM` \ thing ->
 594     returnM (combine (ResultStmt exp' locn) thing)
 595
 596
 597 ------------------------------
 598 glue_binds combine EmptyBinds  thing = thing
 599 glue_binds combine other_binds thing = combine (LetStmt other_binds) thing
 600 \end{code}
 601
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsection{Errors and contexts}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 610 number of args are used in each equation.
 611
 612 \begin{code}
 613 sameNoOfArgs :: [RenamedMatch] -> Bool
 614 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 615   where
 616     args_in_match :: RenamedMatch -> Int
 617     args_in_match (Match pats _ _) = length pats
 618 \end{code}
 619
 620 \begin{code}
 621 varyingArgsErr name matches
 622   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 623
 624 matchCtxt ctxt  match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 625                               4 (pprMatch ctxt match)
 626
 627 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
 628         where
 629           pp_ctxt  = case stmt of
 630                         ResultStmt _ _ -> pprStmtResultContext
 631                         other          -> pprStmtContext
 632
 633 sigPatCtxt bound_tvs bound_ids tys tidy_env
 634   =     -- tys is (body_ty : pat_tys)
 635     mapM zonkTcType tys         `thenM` \ tys' ->
 636     let
 637         (env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 638         (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
 639     in
 640     returnM (env1,
 641                  sep [ptext SLIT("When checking an existential match that binds"),
 642                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 643                       ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 644                       ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 645                 ])
 646   where
 647     show_ids = filter is_interesting bound_ids
 648     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 649
 650     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 651         -- Don't zonk the types so we get the separate, un-unified versions
 652 \end{code}