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, tcInferRho, tcMonoExpr )
  17
  18 import HsSyn            ( HsExpr(..), LHsExpr, MatchGroup(..),
  19                           Match(..), LMatch, GRHSs(..), GRHS(..),
  20                           Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
  21                           ReboundNames, LPat, HsBindGroup(..),
  22                           pprMatch, isDoExpr,
  23                           pprMatchContext, pprStmtContext, pprStmtResultContext,
  24                           collectPatsBinders, glueBindsOnGRHSs
  25                         )
  26 import TcHsSyn          ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
  27
  28 import TcRnMonad
  29 import TcHsType         ( tcHsPatSigType, UserTypeCtxt(..) )
  30 import Inst             ( tcSyntaxName, tcInstCall )
  31 import TcEnv            ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
  32                           tcExtendTyVarEnv )
  33 import TcPat            ( PatCtxt(..), tcPats )
  34 import TcMType          ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType, isRigidType )
  35 import TcType           ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
  36                           tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkTyConApp,
  37                           liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy )
  38 import TcBinds          ( tcBindsAndThen )
  39 import TcUnify          ( Expected(..), zapExpectedType, readExpectedType,
  40                           unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
  41                           checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
  42                           unifyAppTy )
  43 import TcSimplify       ( bindInstsOfLocalFuns )
  44 import Name             ( Name )
  45 import TysWiredIn       ( boolTy, parrTyCon, listTyCon )
  46 import Id               ( idType, mkLocalId )
  47 import CoreFVs          ( idFreeTyVars )
  48 import VarSet
  49 import BasicTypes       ( RecFlag(..) )
  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              -> MatchGroup Name
  71              -> Expected TcRhoType      -- Expected type of function
  72              -> TcM (MatchGroup TcId)   -- Returns type of body
  73
  74 tcMatchesFun fun_name matches exp_ty
  75   = do  {  -- 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) (varyingArgsErr fun_name matches)
  82
  83         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  84         -- because inconsistency between branches
  85         -- may show up as something wrong with the (non-existent) type signature
  86
  87                 -- This is one of two places places we call subFunTys
  88                 -- The point is that if expected_y is a "hole", we want
  89                 -- to make pat_tys and rhs_ty as "holes" too.
  90         ; exp_ty' <- zapExpectedBranches matches exp_ty
  91         ; subFunTys matches exp_ty'     $ \ pat_tys rhs_ty ->
  92           tcMatches match_ctxt pat_tys rhs_ty matches
  93         }
  94   where
  95     match_ctxt = MC { mc_what = FunRhs fun_name,
  96                       mc_body = tcMonoExpr }
  97 \end{code}
  98
  99 @tcMatchesCase@ doesn't do the argument-count check because the
 100 parser guarantees that each equation has exactly one argument.
 101
 102 \begin{code}
 103 tcMatchesCase :: TcMatchCtxt            -- Case context
 104               -> TcRhoType              -- Type of scrutinee
 105               -> MatchGroup Name        -- The case alternatives
 106               -> Expected TcRhoType     -- Type of whole case expressions
 107               -> TcM (MatchGroup TcId)  -- Translated alternatives
 108
 109 tcMatchesCase ctxt scrut_ty matches exp_ty
 110   = do  { exp_ty' <- zapExpectedBranches matches exp_ty
 111         ; tcMatches ctxt [Check scrut_ty] exp_ty' matches }
 112
 113 tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId)
 114 tcMatchLambda match exp_ty      -- One branch so no unifyBranches needed
 115   = subFunTys match exp_ty      $ \ pat_tys rhs_ty ->
 116     tcMatches match_ctxt pat_tys rhs_ty match
 117   where
 118     match_ctxt = MC { mc_what = LambdaExpr,
 119                       mc_body = tcMonoExpr }
 120 \end{code}
 121
 122 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 123
 124 \begin{code}
 125 tcGRHSsPat :: GRHSs Name
 126            -> Expected TcRhoType
 127            -> TcM (GRHSs TcId)
 128 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
 129   where
 130     match_ctxt = MC { mc_what = PatBindRhs,
 131                       mc_body = tcMonoExpr }
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{tcMatch}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcMatches :: TcMatchCtxt
 143           -> [Expected TcRhoType]       -- Expected pattern types
 144           -> Expected TcRhoType         -- Expected result-type of the Match.
 145           -> MatchGroup Name
 146           -> TcM (MatchGroup TcId)
 147
 148 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 149   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 150          mc_body :: LHsExpr Name                -- Type checker for a body of an alternative
 151                  -> Expected TcRhoType
 152                  -> TcM (LHsExpr TcId) }
 153
 154 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 155   = do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 156         ; pat_tys' <- mapM readExpectedType pat_tys
 157         ; rhs_ty'  <- readExpectedType rhs_ty
 158         ; return (MatchGroup matches' (mkFunTys pat_tys' rhs_ty')) }
 159
 160 -------------
 161 tcMatch :: TcMatchCtxt
 162         -> [Expected TcRhoType]         -- Expected pattern types
 163         -> Expected TcRhoType           -- Expected result-type of the Match.
 164         -> LMatch Name
 165         -> TcM (LMatch TcId)
 166
 167 tcMatch ctxt pat_tys rhs_ty match
 168   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 169
 170 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 171   = addErrCtxt (matchCtxt (mc_what ctxt) match) $
 172     do  { (pats', grhss') <- tcMatchPats pats pat_tys rhs_ty $
 173                              tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
 174         ; returnM (Match pats' Nothing grhss') }
 175
 176
 177 -------------
 178 tc_grhss ctxt Nothing grhss rhs_ty
 179   = tcGRHSs ctxt grhss rhs_ty   -- No result signature
 180
 181 tc_grhss ctxt (Just res_sig) grhss rhs_ty
 182   = do  { (sig_tvs, sig_ty) <- tcHsPatSigType ResSigCtxt res_sig
 183         ; traceTc (text "tc_grhss" <+> ppr sig_tvs)
 184         ; (co_fn, grhss') <- tcExtendTyVarEnv sig_tvs $
 185                              tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty
 186
 187                 -- Push the coercion down to the right hand sides,
 188                 -- because there is no convenient place to hang it otherwise.
 189         ; if isIdCoercion co_fn then
 190                 return grhss'
 191           else
 192                 return (lift_grhss co_fn grhss') }
 193
 194 -------------
 195 lift_grhss co_fn (GRHSs grhss binds)
 196   = GRHSs (map (fmap lift_grhs) grhss) binds
 197   where
 198     lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
 199
 200     lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
 201     lift_stmt stmt                   = stmt
 202
 203 -------------
 204 tcGRHSs :: TcMatchCtxt -> GRHSs Name
 205         -> Expected TcRhoType
 206         -> TcM (GRHSs TcId)
 207
 208   -- Special case when there is just one equation with a degenerate
 209   -- guard; then we pass in the full Expected type, so that we get
 210   -- good inference from simple things like
 211   --    f = \(x::forall a.a->a) -> <stuff>
 212   -- This is a consequence of the fact that tcStmts takes a TcType,
 213   -- not a Expected TcType, a decision we could revisit if necessary
 214 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds) exp_ty
 215   = tcBindsAndThen glueBindsOnGRHSs binds       $
 216     mc_body ctxt rhs exp_ty                     `thenM` \ rhs' ->
 217     returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [])
 218
 219 tcGRHSs ctxt (GRHSs grhss binds) exp_ty
 220   = tcBindsAndThen glueBindsOnGRHSs binds       $
 221     zapExpectedType exp_ty openTypeKind         `thenM` \ exp_ty' ->
 222         -- Even if there is only one guard, we zap the RHS type to
 223         -- a monotype.  Reason: it makes tcStmts much easier,
 224         -- and even a one-armed guard has a notional second arm
 225     let
 226       stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
 227                        sc_rhs  = tcInferRho,
 228                        sc_body = sc_body,
 229                        sc_ty   = exp_ty' }
 230       sc_body body = mc_body ctxt body (Check exp_ty')
 231
 232       tc_grhs (GRHS guarded)
 233         = tcStmts stmt_ctxt  guarded    `thenM` \ guarded' ->
 234           returnM (GRHS guarded')
 235     in
 236     mappM (wrapLocM tc_grhs) grhss      `thenM` \ grhss' ->
 237     returnM (GRHSs grhss' [])
 238 \end{code}
 239
 240
 241 \begin{code}
 242 tcThingWithSig :: TcSigmaType           -- Type signature
 243                -> (TcRhoType -> TcM r)  -- How to type check the thing inside
 244                -> Expected TcRhoType    -- Overall expected result type
 245                -> TcM (ExprCoFn, r)
 246 -- Used for expressions with a type signature, and for result type signatures
 247
 248 tcThingWithSig sig_ty thing_inside res_ty
 249   | not (isSigmaTy sig_ty)
 250   = thing_inside sig_ty         `thenM` \ result ->
 251     tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
 252     returnM (co_fn, result)
 253
 254   | otherwise   -- The signature has some outer foralls
 255   =     -- Must instantiate the outer for-alls of sig_tc_ty
 256         -- else we risk instantiating a ? res_ty to a forall-type
 257         -- which breaks the invariant that tcMonoExpr only returns phi-types
 258     tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
 259     tcInstCall InstSigOrigin sig_ty             `thenM` \ (inst_fn, _, inst_sig_ty) ->
 260     tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
 261     returnM (co_fn <.> inst_fn <.> gen_fn,  result)
 262         -- Note that we generalise, then instantiate. Ah well.
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection{tcMatchPats}
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 tcMatchPats :: [LPat Name]
 274             -> [Expected TcSigmaType]   -- Pattern types
 275             -> Expected TcRhoType       -- Result type;
 276                                         -- used only to check existential escape
 277             -> TcM a
 278             -> TcM ([LPat TcId], a)
 279 -- Typecheck the patterns, extend the environment to bind the variables,
 280 -- do the thing inside, use any existentially-bound dictionaries to
 281 -- discharge parts of the returning LIE, and deal with pattern type
 282 -- signatures
 283
 284 tcMatchPats pats tys body_ty thing_inside
 285   = do  { do_refinement <- can_refine body_ty
 286         ; (pats', ex_tvs, res) <- tcPats (LamPat do_refinement) pats tys thing_inside
 287         ; tcCheckExistentialPat pats' ex_tvs tys body_ty
 288         ; returnM (pats', res) }
 289   where
 290         -- Do GADT refinement if we are doing checking (not inference)
 291         -- and the body_ty is completely rigid
 292         -- ToDo: explain why
 293     can_refine (Infer _)  = return False
 294     can_refine (Check ty) = isRigidType ty
 295
 296 tcCheckExistentialPat :: [LPat TcId]            -- Patterns (just for error message)
 297                       -> [TcTyVar]              -- Existentially quantified tyvars bound by pattern
 298                       -> [Expected TcSigmaType] -- Types of the patterns
 299                       -> Expected TcRhoType     -- Type of the body of the match
 300                                                 -- Tyvars in either of these must not escape
 301                       -> TcM ()
 302         -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
 303         -- For example, we must reject this program:
 304         --      data C = forall a. C (a -> Int)
 305         --      f (C g) x = g x
 306         -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 307
 308 tcCheckExistentialPat pats [] pat_tys body_ty
 309   = return ()   -- Short cut for case when there are no existentials
 310
 311 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
 312   = do  { tys <- mapM readExpectedType (body_ty : pat_tys)
 313         ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $
 314           checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs }
 315 \end{code}
 316
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 tcDoStmts :: HsStmtContext Name
 326           -> [LStmt Name] -> ReboundNames Name
 327           -> TcRhoType          -- To keep it simple, we don't have an "expected" type here
 328           -> TcM ([LStmt TcId], ReboundNames TcId)
 329 tcDoStmts PArrComp stmts method_names res_ty
 330   = do  { [elt_ty] <- unifyTyConApp parrTyCon res_ty
 331         ; stmts' <- tcComprehension PArrComp parrTyCon elt_ty stmts
 332         ; return (stmts', [{- unused -}]) }
 333
 334 tcDoStmts ListComp stmts method_names res_ty
 335   = unifyListTy res_ty                          `       thenM` \ elt_ty ->
 336     tcComprehension ListComp listTyCon elt_ty stmts     `thenM` \ stmts' ->
 337     returnM (stmts', [{- unused -}])
 338
 339 tcDoStmts do_or_mdo stmts method_names res_ty
 340   = newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
 341     newTyFlexiVarTy liftedTypeKind                              `thenM` \ elt_ty ->
 342     unifyTauTy res_ty (mkAppTy m_ty elt_ty)                     `thenM_`
 343     let
 344         ctxt = SC { sc_what = do_or_mdo,
 345                     sc_rhs  = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
 346                                           ; rhs_elt_ty <- unifyAppTy m_ty rhs_ty
 347                                           ; return (rhs', rhs_elt_ty) },
 348                     sc_body = \ body -> tcCheckRho body res_ty,
 349                     sc_ty   = res_ty }
 350     in
 351     tcStmts ctxt stmts                                          `thenM` \ stmts' ->
 352
 353         -- Build the then and zero methods in case we need them
 354         -- It's important that "then" and "return" appear just once in the final LIE,
 355         -- not only for typechecker efficiency, but also because otherwise during
 356         -- simplification we end up with silly stuff like
 357         --      then = case d of (t,r) -> t
 358         --      then = then
 359         -- where the second "then" sees that it already exists in the "available" stuff.
 360     mapM (tcSyntaxName DoOrigin m_ty) method_names                `thenM` \ methods ->
 361
 362     returnM (stmts', methods)
 363
 364 tcComprehension do_or_lc m_tycon elt_ty stmts
 365   = tcStmts ctxt stmts
 366   where
 367     ctxt = SC { sc_what = do_or_lc,
 368                 sc_rhs  = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
 369                                       ; [rhs_elt_ty] <- unifyTyConApp m_tycon rhs_ty
 370                                       ; return (rhs', rhs_elt_ty) },
 371                 sc_body = \ body -> tcCheckRho body elt_ty,     -- Note: no m_tycon here!
 372                 sc_ty   = mkTyConApp m_tycon [elt_ty] }
 373 \end{code}
 374
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection{tcStmts}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 383
 384         [ (g x, h x) | ... ; let g v = ...
 385                      | ... ; let h v = ... ]
 386
 387 It's possible that g,h are overloaded, so we need to feed the LIE from the
 388 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 389 Similarly if we had an existential pattern match:
 390
 391         data T = forall a. Show a => C a
 392
 393         [ (show x, show y) | ... ; C x <- ...
 394                            | ... ; C y <- ... ]
 395
 396 Then we need the LIE from (show x, show y) to be simplified against
 397 the bindings for x and y.
 398
 399 It's difficult to do this in parallel, so we rely on the renamer to
 400 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 401 So the binders of the first parallel group will be in scope in the second
 402 group.  But that's fine; there's no shadowing to worry about.
 403
 404 \begin{code}
 405 tcStmts ctxt stmts
 406   = ASSERT( notNull stmts )
 407     tcStmtsAndThen (:) ctxt stmts (returnM [])
 408
 409 data TcStmtCtxt
 410   = SC { sc_what :: HsStmtContext Name,                         -- What kind of thing this is
 411          sc_rhs  :: LHsExpr Name -> TcM (LHsExpr TcId, TcType), -- Type inference for RHS computations
 412          sc_body :: LHsExpr Name -> TcM (LHsExpr TcId),         -- Type checker for return computation
 413          sc_ty   :: TcType }                                    -- Return type; used *only* to check
 414                                                                 -- for escape in existential patterns
 415         -- We use type *inference* for the RHS computations, becuase of GADTs.
 416         --      do { pat <- rhs; <rest> }
 417         -- is rather like
 418         --      case rhs of { pat -> <rest> }
 419         -- We do inference on rhs, so that information about its type can be refined
 420         -- when type-checking the pattern.
 421
 422 tcStmtsAndThen
 423         :: (LStmt TcId -> thing -> thing)       -- Combiner
 424         -> TcStmtCtxt
 425         -> [LStmt Name]
 426         -> TcM thing
 427         -> TcM thing
 428
 429         -- Base case
 430 tcStmtsAndThen combine ctxt [] thing_inside
 431   = thing_inside
 432
 433 tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
 434   = tcStmtAndThen  combine ctxt stmt  $
 435     tcStmtsAndThen combine ctxt stmts $
 436     thing_inside
 437
 438         -- LetStmt
 439 tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside
 440   = tcBindsAndThen              -- No error context, but a binding group is
 441         (glue_binds combine)    -- rather a large thing for an error context anyway
 442         binds
 443         thing_inside
 444
 445         -- BindStmt
 446 tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
 447   = setSrcSpan src_loc                                  $
 448     addErrCtxt (stmtCtxt ctxt stmt)                     $
 449     do  { (exp', pat_ty)  <- sc_rhs ctxt exp
 450         ; ([pat'], thing) <- tcMatchPats [pat] [Check pat_ty] (Check (sc_ty ctxt)) $
 451                              popErrCtxt thing_inside
 452         ; return (combine (L src_loc (BindStmt pat' exp')) thing) }
 453
 454         -- ExprStmt
 455 tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
 456   = setSrcSpan src_loc          (
 457         addErrCtxt (stmtCtxt ctxt stmt) $
 458         if isDoExpr (sc_what ctxt)
 459         then    -- do or mdo; the expression is a computation
 460                 sc_rhs ctxt exp                 `thenM` \ (exp', exp_ty) ->
 461                 returnM (L src_loc (ExprStmt exp' exp_ty))
 462         else    -- List comprehensions, pattern guards; expression is a boolean
 463                 tcCheckRho exp boolTy           `thenM` \ exp' ->
 464                 returnM (L src_loc (ExprStmt exp' boolTy))
 465     )                                           `thenM` \ stmt' ->
 466
 467     thing_inside                                `thenM` \ thing ->
 468     returnM (combine stmt' thing)
 469
 470
 471         -- ParStmt
 472 tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
 473   = loop bndr_stmts_s           `thenM` \ (pairs', thing) ->
 474     returnM (combine (L src_loc (ParStmt pairs')) thing)
 475   where
 476     loop [] = thing_inside              `thenM` \ thing ->
 477               returnM ([], thing)
 478
 479     loop ((stmts, bndrs) : pairs)
 480       = tcStmtsAndThen combine_par ctxt stmts $
 481                         -- Notice we pass on ctxt; the result type is used only
 482                         -- to get escaping type variables for checkExistentialPat
 483         tcLookupLocalIds bndrs          `thenM` \ bndrs' ->
 484         loop pairs                      `thenM` \ (pairs', thing) ->
 485         returnM (([], bndrs') : pairs', thing)
 486
 487     combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
 488
 489         -- RecStmt
 490 tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
 491   = newTyFlexiVarTys (length recNames) liftedTypeKind           `thenM` \ recTys ->
 492     let
 493         rec_ids = zipWith mkLocalId recNames recTys
 494     in
 495     tcExtendIdEnv rec_ids                       $
 496     tcStmtsAndThen combine_rec ctxt stmts (
 497         zipWithM tc_ret recNames recTys         `thenM` \ rec_rets ->
 498         tcLookupLocalIds laterNames             `thenM` \ later_ids ->
 499         returnM ([], (later_ids, rec_rets))
 500     )                                           `thenM` \ (stmts', (later_ids, rec_rets)) ->
 501
 502     tcExtendIdEnv later_ids             $
 503         -- NB:  The rec_ids for the recursive things
 504         --      already scope over this part. This binding may shadow
 505         --      some of them with polymorphic things with the same Name
 506         --      (see note [RecStmt] in HsExpr)
 507     getLIE thing_inside                         `thenM` \ (thing, lie) ->
 508     bindInstsOfLocalFuns lie later_ids          `thenM` \ lie_binds ->
 509
 510     returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets))     $
 511              combine (L src_loc (LetStmt [HsBindGroup lie_binds  [] Recursive])) $
 512              thing)
 513   where
 514     combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
 515
 516     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 517     tc_ret rec_name mono_ty
 518         = tcLookupId rec_name                           `thenM` \ poly_id ->
 519                 -- poly_id may have a polymorphic type
 520                 -- but mono_ty is just a monomorphic type variable
 521           tcSubExp (Check mono_ty) (idType poly_id)     `thenM` \ co_fn ->
 522           returnM (L src_loc (co_fn <$> HsVar poly_id))
 523
 524         -- Result statements
 525 tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside
 526   = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp)  `thenM` \ exp' ->
 527     thing_inside                                        `thenM` \ thing ->
 528     returnM (combine (L src_loc (ResultStmt exp')) thing)
 529
 530
 531 ------------------------------
 532 glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing
 533         -- ToDo: fix the noLoc
 534 \end{code}
 535
 536
 537 %************************************************************************
 538 %*                                                                      *
 539 \subsection{Errors and contexts}
 540 %*                                                                      *
 541 %************************************************************************
 542
 543 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 544 number of args are used in each equation.
 545
 546 \begin{code}
 547 sameNoOfArgs :: MatchGroup Name -> Bool
 548 sameNoOfArgs (MatchGroup matches _)
 549    = isSingleton (nub (map args_in_match matches))
 550   where
 551     args_in_match :: LMatch Name -> Int
 552     args_in_match (L _ (Match pats _ _)) = length pats
 553 \end{code}
 554
 555 \begin{code}
 556 varyingArgsErr name matches
 557   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 558
 559 matchCtxt ctxt  match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 560                               4 (pprMatch ctxt match)
 561
 562 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
 563         where
 564           pp_ctxt  = case stmt of
 565                         ResultStmt _ -> pprStmtResultContext
 566                         other        -> pprStmtContext
 567
 568 sigPatCtxt bound_ids bound_tvs tys tidy_env
 569   =     -- tys is (body_ty : pat_tys)
 570     mapM zonkTcType tys         `thenM` \ tys' ->
 571     let
 572         (env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 573         (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
 574     in
 575     returnM (env1,
 576                  sep [ptext SLIT("When checking an existential match that binds"),
 577                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 578                       ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 579                       ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 580                 ])
 581   where
 582     show_ids = filter is_interesting bound_ids
 583     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 584
 585     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 586         -- Don't zonk the types so we get the separate, un-unified versions
 587 \end{code}