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