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