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