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, typeKind,
  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   = newTyVarTy openTypeKind                                     `thenM` \ scrut_ty ->
 107         -- openTypeKind because the scrutinee can be an unboxed type
 108     tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty))   `thenM` \ matches' ->
 109     returnM (scrut_ty, matches')
 110
 111 tcMatchesCase ctxt matches (Infer hole)
 112   = newHole                                     `thenM` \ fun_hole ->
 113     tcMatches ctxt matches (Infer fun_hole)     `thenM` \ matches' ->
 114     readMutVar fun_hole                         `thenM` \ fun_ty ->
 115         -- The result of tcMatches is bound to be a function type
 116     unifyFunTy fun_ty                           `thenM` \ (scrut_ty, res_ty) ->
 117     writeMutVar hole res_ty                     `thenM_`
 118     returnM (scrut_ty, matches')
 119
 120
 121 tcMatchLambda :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId)
 122 tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match
 123   where
 124     match_ctxt = MC { mc_what = LambdaExpr,
 125                       mc_body = tcMonoExpr }
 126 \end{code}
 127
 128 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 129
 130 \begin{code}
 131 tcGRHSsPat :: GRHSs Name
 132            -> Expected TcRhoType
 133            -> TcM (GRHSs TcId)
 134 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
 135   where
 136     match_ctxt = MC { mc_what = PatBindRhs,
 137                       mc_body = tcMonoExpr }
 138 \end{code}
 139
 140 \begin{code}
 141 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 142   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 143          mc_body :: LHsExpr Name                -- Type checker for a body of an alternative
 144                     -> Expected TcRhoType
 145                     -> TcM (LHsExpr TcId) }
 146
 147 tcMatches :: TcMatchCtxt
 148           -> [LMatch Name]
 149           -> Expected TcRhoType
 150           -> TcM [LMatch TcId]
 151
 152 tcMatches ctxt matches exp_ty
 153   =     -- If there is more than one branch, and exp_ty is a 'hole',
 154         -- all branches must be types, not type schemes, otherwise the
 155         -- order in which we check them would affect the result.
 156     zapExpectedBranches matches exp_ty  `thenM` \ exp_ty' ->
 157     mappM (tcMatch ctxt exp_ty') matches
 158 \end{code}
 159
 160
 161 %************************************************************************
 162 %*                                                                      *
 163 \subsection{tcMatch}
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 \begin{code}
 168 tcMatch :: TcMatchCtxt
 169         -> Expected TcRhoType   -- Expected result-type of the Match.
 170                         -- Early unification with this guy gives better error messages
 171                         -- We regard the Match as having type
 172                         --      (ty1 -> ... -> tyn -> result_ty)
 173                         -- where there are n patterns.
 174         -> LMatch Name
 175         -> TcM (LMatch TcId)
 176
 177 tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match
 178
 179 tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss)
 180   = addErrCtxt (matchCtxt (mc_what ctxt) match) $       -- I'm not sure why, so I put it back
 181     subFunTys pats expected_ty                  $ \ pats_w_tys rhs_ty ->
 182         -- This is the unique place we call subFunTys
 183         -- The point is that if expected_y is a "hole", we want
 184         -- to make arg_ty and rest_ty as "holes" too.
 185     tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty)     `thenM` \ (pats', grhss', ex_binds) ->
 186     returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))
 187
 188   where
 189     tc_grhss rhs_ty
 190         = case maybe_rhs_sig of  -- Deal with the result signature
 191             Nothing  ->  tcGRHSs ctxt grhss rhs_ty
 192
 193             Just sig ->  tcAddScopedTyVars [sig]        $
 194                                 -- Bring into scope the type variables in the signature
 195                          tcHsSigType ResSigCtxt sig                                     `thenM` \ sig_ty ->
 196                          tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty      `thenM` \ (co_fn, grhss') ->
 197
 198                         -- Pushes the coercion down to the right hand sides,
 199                         -- because there is no convenient place to hang it otherwise.
 200                          if isIdCoercion co_fn then
 201                                 returnM grhss'
 202                          else
 203                          readExpectedType rhs_ty                `thenM` \ rhs_ty' ->
 204                          returnM (lift_grhss co_fn rhs_ty' grhss')
 205
 206 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
 207   = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty     -- Change the type, since the coercion does
 208   where
 209     lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
 210
 211     lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
 212     lift_stmt stmt                   = stmt
 213
 214 tcGRHSs :: TcMatchCtxt -> GRHSs Name
 215         -> Expected TcRhoType
 216         -> TcM (GRHSs TcId)
 217
 218   -- Special case when there is just one equation with a degenerate
 219   -- guard; then we pass in the full Expected type, so that we get
 220   -- good inference from simple things like
 221   --    f = \(x::forall a.a->a) -> <stuff>
 222   -- This is a consequence of the fact that tcStmts takes a TcType,
 223   -- not a Expected TcType, a decision we could revisit if necessary
 224 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty
 225   = tcBindsAndThen glueBindsOnGRHSs binds       $
 226     mc_body ctxt rhs exp_ty                     `thenM` \ rhs' ->
 227     readExpectedType exp_ty                     `thenM` \ exp_ty' ->
 228     returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty')
 229
 230 tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
 231   = tcBindsAndThen glueBindsOnGRHSs binds       $
 232     zapExpectedType exp_ty openTypeKind         `thenM` \ exp_ty' ->
 233         -- Even if there is only one guard, we zap the RHS type to
 234         -- a monotype.  Reason: it makes tcStmts much easier,
 235         -- and even a one-armed guard has a notional second arm
 236     let
 237       stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
 238                        sc_rhs  = tcCheckRho,
 239                        sc_body = sc_body,
 240                        sc_ty   = exp_ty' }
 241       sc_body body = mc_body ctxt body (Check exp_ty')
 242
 243       tc_grhs (GRHS guarded)
 244         = tcStmts stmt_ctxt  guarded    `thenM` \ guarded' ->
 245           returnM (GRHS guarded')
 246     in
 247     mappM (wrapLocM tc_grhs) grhss      `thenM` \ grhss' ->
 248     returnM (GRHSs grhss' [] exp_ty')
 249 \end{code}
 250
 251
 252 \begin{code}
 253 tcThingWithSig :: TcSigmaType           -- Type signature
 254                -> (TcRhoType -> TcM r)  -- How to type check the thing inside
 255                -> Expected TcRhoType    -- Overall expected result type
 256                -> TcM (ExprCoFn, r)
 257 -- Used for expressions with a type signature, and for result type signatures
 258
 259 tcThingWithSig sig_ty thing_inside res_ty
 260   | not (isSigmaTy sig_ty)
 261   = thing_inside sig_ty         `thenM` \ result ->
 262     tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
 263     returnM (co_fn, result)
 264
 265   | otherwise   -- The signature has some outer foralls
 266   =     -- Must instantiate the outer for-alls of sig_tc_ty
 267         -- else we risk instantiating a ? res_ty to a forall-type
 268         -- which breaks the invariant that tcMonoExpr only returns phi-types
 269     tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
 270     tcInstCall SignatureOrigin sig_ty           `thenM` \ (inst_fn, inst_sig_ty) ->
 271     tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
 272     returnM (co_fn <.> inst_fn <.> gen_fn,  result)
 273         -- Note that we generalise, then instantiate. Ah well.
 274 \end{code}
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection{tcMatchPats}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 tcMatchPats
 285         :: [(LPat Name, Expected TcRhoType)]
 286         -> Expected TcRhoType
 287         -> TcM a
 288         -> TcM ([LPat TcId], a, HsBindGroup TcId)
 289 -- Typecheck the patterns, extend the environment to bind the variables,
 290 -- do the thing inside, use any existentially-bound dictionaries to
 291 -- discharge parts of the returning LIE, and deal with pattern type
 292 -- signatures
 293
 294 tcMatchPats pats_w_tys body_ty thing_inside
 295   =     -- STEP 1: Bring pattern-signature type variables into scope
 296     tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys))      (
 297
 298         -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
 299         --         then do the thing inside
 300         getLIE (tc_match_pats pats_w_tys thing_inside)
 301
 302     ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
 303
 304         -- STEP 4: Check for existentially bound type variables
 305         -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
 306         -- complains that 'a' is captured by the inscope 'a'!  (Test (d) in checkSigTyVars.)
 307         --
 308         -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
 309         -- might need (via lie_req2) something made available from an 'outer'
 310         -- pattern.  But it's inconvenient to deal with, and I can't find an example
 311     tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req
 312                           pats_w_tys body_ty            `thenM` \ ex_binds ->
 313         -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat
 314         -- For example, we must reject this program:
 315         --      data C = forall a. C (a -> Int)
 316         --      f (C g) x = g x
 317         -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 318
 319     returnM (pats', result, HsBindGroup ex_binds [] Recursive)
 320
 321 tc_match_pats [] thing_inside
 322   = thing_inside        `thenM` \ answer ->
 323     returnM ([], emptyBag, [], [], answer)
 324
 325 tc_match_pats ((pat,pat_ty):pats) thing_inside
 326   = tcPat tcMonoPatBndr pat pat_ty      `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
 327     let
 328         xve    = bagToList pat_bndrs
 329         ex_ids = [id | (_, id) <- xve]
 330                 -- ex_ids is all the pattern-bound Ids, a superset
 331                 -- of the existential Ids used in checkExistentialPat
 332     in
 333     tcExtendLocalValEnv2 xve                    $
 334     traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$
 335                                         ppr (map (typeKind . idType . snd) xve))) `thenM_`
 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 liftedTypeKind       `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}