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, TcMatchCtxt(..),
   9                    tcStmts, tcDoStmts,
  10                    tcDoStmt, tcMDoStmt, tcGuardStmt
  11        ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
  16
  17 import HsSyn            ( HsExpr(..), LHsExpr, MatchGroup(..),
  18                           Match(..), LMatch, GRHSs(..), GRHS(..),
  19                           Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
  20                           pprMatch, isIrrefutableHsPat,
  21                           pprMatchContext, pprStmtContext,
  22                           noSyntaxExpr, matchGroupArity, pprMatches,
  23                           ExprCoFn )
  24
  25 import TcRnMonad
  26 import TcHsType         ( tcPatSig, UserTypeCtxt(..) )
  27 import Inst             ( newMethodFromName )
  28 import TcEnv            ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
  29                           tcExtendTyVarEnv2 )
  30 import TcPat            ( PatCtxt(..), tcPats, tcPat )
  31 import TcMType          ( newFlexiTyVarTy, newFlexiTyVarTys )
  32 import TcType           ( TcType, TcRhoType,
  33                           BoxySigmaType, BoxyRhoType,
  34                           mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
  35                           liftedTypeKind )
  36 import TcBinds          ( tcLocalBinds )
  37 import TcUnify          ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
  38                           subFunTys, tcSubExp, withBox )
  39 import TcSimplify       ( bindInstsOfLocalFuns )
  40 import Name             ( Name )
  41 import TysWiredIn       ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
  42 import PrelNames        ( bindMName, returnMName, mfixName, thenMName, failMName )
  43 import Id               ( idType, mkLocalId )
  44 import TyCon            ( TyCon )
  45 import Util             ( isSingleton )
  46 import Outputable
  47 import SrcLoc           ( Located(..) )
  48 import ErrUtils         ( Message )
  49
  50 import List             ( nub )
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{tcMatchesFun, tcMatchesCase}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  60 @FunMonoBind@.  The second argument is the name of the function, which
  61 is used in error messages.  It checks that all the equations have the
  62 same number of arguments before using @tcMatches@ to do the work.
  63
  64 \begin{code}
  65 tcMatchesFun :: Name
  66              -> MatchGroup Name
  67              -> BoxyRhoType             -- Expected type of function
  68              -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
  69
  70 tcMatchesFun fun_name matches exp_ty
  71   = do  {  -- Check that they all have the same no of arguments
  72            -- Location is in the monad, set the caller so that
  73            -- any inter-equation error messages get some vaguely
  74            -- sensible location.        Note: we have to do this odd
  75            -- ann-grabbing, because we don't always have annotations in
  76            -- hand when we call tcMatchesFun...
  77           checkTc (sameNoOfArgs matches) (varyingArgsErr fun_name matches)
  78
  79         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  80         -- because inconsistency between branches
  81         -- may show up as something wrong with the (non-existent) type signature
  82
  83                 -- This is one of two places places we call subFunTys
  84                 -- The point is that if expected_y is a "hole", we want
  85                 -- to make pat_tys and rhs_ty as "holes" too.
  86         ; subFunTys doc n_pats exp_ty     $ \ pat_tys rhs_ty ->
  87           tcMatches match_ctxt pat_tys rhs_ty matches
  88         }
  89   where
  90     doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
  91           <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
  92     n_pats = matchGroupArity matches
  93     match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr }
  94 \end{code}
  95
  96 @tcMatchesCase@ doesn't do the argument-count check because the
  97 parser guarantees that each equation has exactly one argument.
  98
  99 \begin{code}
 100 tcMatchesCase :: TcMatchCtxt            -- Case context
 101               -> TcRhoType              -- Type of scrutinee
 102               -> MatchGroup Name        -- The case alternatives
 103               -> BoxyRhoType            -- Type of whole case expressions
 104               -> TcM (MatchGroup TcId)  -- Translated alternatives
 105
 106 tcMatchesCase ctxt scrut_ty matches res_ty
 107   = tcMatches ctxt [scrut_ty] res_ty matches
 108
 109 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
 110 tcMatchLambda match res_ty
 111   = subFunTys doc n_pats res_ty         $ \ pat_tys rhs_ty ->
 112     tcMatches match_ctxt pat_tys rhs_ty match
 113   where
 114     n_pats = matchGroupArity match
 115     doc = sep [ ptext SLIT("The lambda expression")
 116                  <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
 117                         -- The pprSetDepth makes the abstraction print briefly
 118                 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
 119     match_ctxt = MC { mc_what = LambdaExpr,
 120                       mc_body = tcPolyExpr }
 121 \end{code}
 122
 123 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 124
 125 \begin{code}
 126 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
 127 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 128   where
 129     match_ctxt = MC { mc_what = PatBindRhs,
 130                       mc_body = tcPolyExpr }
 131 \end{code}
 132
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{tcMatch}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 \begin{code}
 141 tcMatches :: TcMatchCtxt
 142           -> [BoxySigmaType]            -- Expected pattern types
 143           -> BoxyRhoType                -- Expected result-type of the Match.
 144           -> MatchGroup Name
 145           -> TcM (MatchGroup TcId)
 146
 147 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 148   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 149          mc_body :: LHsExpr Name                -- Type checker for a body of an alternative
 150                  -> BoxyRhoType
 151                  -> TcM (LHsExpr TcId) }
 152
 153 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 154   = do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 155         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 156
 157 -------------
 158 tcMatch :: TcMatchCtxt
 159         -> [BoxySigmaType]      -- Expected pattern types
 160         -> BoxyRhoType          -- Expected result-type of the Match.
 161         -> LMatch Name
 162         -> TcM (LMatch TcId)
 163
 164 tcMatch ctxt pat_tys rhs_ty match
 165   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 166   where
 167     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 168       = addErrCtxt (matchCtxt (mc_what ctxt) match)     $
 169         do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
 170                                 tc_grhss ctxt maybe_rhs_sig grhss
 171            ; returnM (Match pats' Nothing grhss') }
 172
 173     tc_grhss ctxt Nothing grhss rhs_ty
 174       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 175
 176     tc_grhss ctxt (Just res_sig) grhss rhs_ty
 177       = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty
 178            ; tcExtendTyVarEnv2 sig_tvs $
 179              tcGRHSs ctxt grhss inner_ty }
 180
 181 -------------
 182 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
 183
 184 -- Notice that we pass in the full res_ty, so that we get
 185 -- good inference from simple things like
 186 --      f = \(x::forall a.a->a) -> <stuff>
 187 -- We used to force it to be a monotype when there was more than one guard
 188 -- but we don't need to do that any more
 189
 190 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 191   = do  { (binds', grhss') <- tcLocalBinds binds $
 192                               mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 193
 194         ; returnM (GRHSs grhss' binds') }
 195
 196 -------------
 197 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
 198
 199 tcGRHS ctxt res_ty (GRHS guards rhs)
 200   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 201                              mc_body ctxt rhs
 202         ; return (GRHS guards' rhs') }
 203   where
 204     stmt_ctxt  = PatGuard (mc_what ctxt)
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 tcDoStmts :: HsStmtContext Name
 216           -> [LStmt Name]
 217           -> LHsExpr Name
 218           -> BoxyRhoType
 219           -> TcM (HsExpr TcId)          -- Returns a HsDo
 220 tcDoStmts ListComp stmts body res_ty
 221   = do  { elt_ty <- boxySplitListTy res_ty
 222         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $
 223                              tcBody (doBodyCtxt ListComp body) body
 224         ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 225
 226 tcDoStmts PArrComp stmts body res_ty
 227   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 228         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $
 229                              tcBody (doBodyCtxt PArrComp body) body
 230         ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 231
 232 tcDoStmts DoExpr stmts body res_ty
 233   = do  { (m_ty, elt_ty) <- boxySplitAppTy res_ty
 234         ; let res_ty' = mkAppTy m_ty elt_ty     -- The boxySplit consumes res_ty
 235         ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $
 236                              tcBody (doBodyCtxt DoExpr body) body
 237         ; return (HsDo DoExpr stmts' body' res_ty') }
 238
 239 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
 240   = do  { (m_ty, elt_ty) <- boxySplitAppTy res_ty
 241         ; let res_ty' = mkAppTy m_ty elt_ty     -- The boxySplit consumes res_ty
 242               tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
 243                            tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 244
 245         ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
 246                              tcBody (doBodyCtxt ctxt body) body
 247
 248         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 249         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 250         ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 251
 252 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 253
 254 tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 255 tcBody ctxt body res_ty
 256   = -- addErrCtxt ctxt $        -- This context adds little that is useful
 257     tcPolyExpr body res_ty
 258 \end{code}
 259
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection{tcStmts}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 type TcStmtChecker
 269   = forall thing.  HsStmtContext Name
 270                    -> Stmt Name
 271                    -> BoxyRhoType                       -- Result type for comprehension
 272                    -> (BoxyRhoType -> TcM thing)        -- Checker for what follows the stmt
 273                    -> TcM (Stmt TcId, thing)
 274
 275   -- The incoming BoxyRhoType may be refined by type refinements
 276   -- before being passed to the thing_inside
 277
 278 tcStmts :: HsStmtContext Name
 279         -> TcStmtChecker        -- NB: higher-rank type
 280         -> [LStmt Name]
 281         -> BoxyRhoType
 282         -> (BoxyRhoType -> TcM thing)
 283         -> TcM ([LStmt TcId], thing)
 284
 285 -- Note the higher-rank type.  stmt_chk is applied at different
 286 -- types in the equations for tcStmts
 287
 288 tcStmts ctxt stmt_chk [] res_ty thing_inside
 289   = do  { thing <- thing_inside res_ty
 290         ; return ([], thing) }
 291
 292 -- LetStmts are handled uniformly, regardless of context
 293 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 294   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 295                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 296         ; return (L loc (LetStmt binds') : stmts', thing) }
 297
 298 -- For the vanilla case, handle the location-setting part
 299 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 300   = do  { (stmt', (stmts', thing)) <-
 301                 setSrcSpan loc                          $
 302                 addErrCtxt (stmtCtxt ctxt stmt)         $
 303                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 304                 popErrCtxt                              $
 305                 tcStmts ctxt stmt_chk stmts res_ty'     $
 306                 thing_inside
 307         ; return (L loc stmt' : stmts', thing) }
 308
 309 --------------------------------
 310 --      Pattern guards
 311 tcGuardStmt :: TcStmtChecker
 312 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
 313   = do  { guard' <- tcMonoExpr guard boolTy
 314         ; thing  <- thing_inside res_ty
 315         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 316
 317 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 318   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 319         ; (pat', thing)  <- tcPat LamPat pat rhs_ty res_ty thing_inside
 320         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 321
 322 tcGuardStmt ctxt stmt res_ty thing_inside
 323   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 324
 325
 326 --------------------------------
 327 --      List comprehensions and PArrays
 328
 329 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 330          -> TcStmtChecker
 331
 332 -- A generator, pat <- rhs
 333 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 334  = do   { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
 335                             tcMonoExpr rhs (mkTyConApp m_tc [ty])
 336         ; (pat', thing)  <- tcPat LamPat pat pat_ty res_ty thing_inside
 337         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 338
 339 -- A boolean guard
 340 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
 341   = do  { rhs'  <- tcMonoExpr rhs boolTy
 342         ; thing <- thing_inside res_ty
 343         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 344
 345 -- A parallel set of comprehensions
 346 --      [ (g x, h x) | ... ; let g v = ...
 347 --                   | ... ; let h v = ... ]
 348 --
 349 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 350 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 351 -- Similarly if we had an existential pattern match:
 352 --
 353 --      data T = forall a. Show a => C a
 354 --
 355 --      [ (show x, show y) | ... ; C x <- ...
 356 --                         | ... ; C y <- ... ]
 357 --
 358 -- Then we need the LIE from (show x, show y) to be simplified against
 359 -- the bindings for x and y.
 360 --
 361 -- It's difficult to do this in parallel, so we rely on the renamer to
 362 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 363 -- So the binders of the first parallel group will be in scope in the second
 364 -- group.  But that's fine; there's no shadowing to worry about.
 365
 366 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 367   = do  { (pairs', thing) <- loop bndr_stmts_s
 368         ; return (ParStmt pairs', thing) }
 369   where
 370     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 371     loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
 372                  ; return ([], thing) }         -- matching in the branches
 373
 374     loop ((stmts, names) : pairs)
 375       = do { (stmts', (ids, pairs', thing))
 376                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
 377                    do { ids <- tcLookupLocalIds names
 378                       ; (pairs', thing) <- loop pairs
 379                       ; return (ids, pairs', thing) }
 380            ; return ( (stmts', ids) : pairs', thing ) }
 381
 382 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 383   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 384
 385 --------------------------------
 386 --      Do-notation
 387 -- The main excitement here is dealing with rebindable syntax
 388
 389 tcDoStmt :: TcType              -- Monad type,  m
 390          -> TcStmtChecker
 391
 392 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 393   = do  { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
 394                             tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 395                 -- We should use type *inference* for the RHS computations, becuase of GADTs.
 396                 --      do { pat <- rhs; <rest> }
 397                 -- is rather like
 398                 --      case rhs of { pat -> <rest> }
 399                 -- We do inference on rhs, so that information about its type can be refined
 400                 -- when type-checking the pattern.
 401
 402         ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
 403
 404         -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
 405         ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
 406                                   mkFunTy pat_ty res_ty] res_ty
 407         ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
 408                 -- If (but only if) the pattern can fail,
 409                 -- typecheck the 'fail' operator
 410         ; fail_op' <- if isIrrefutableHsPat pat'
 411                       then return noSyntaxExpr
 412                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
 413         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 414
 415
 416 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 417   = do  {       -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
 418           a_ty <- newFlexiTyVarTy liftedTypeKind
 419         ; let rhs_ty  = mkAppTy m_ty a_ty
 420               then_ty = mkFunTys [rhs_ty, res_ty] res_ty
 421         ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
 422         ; rhs' <- tcPolyExpr rhs rhs_ty
 423         ; thing <- thing_inside res_ty
 424         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 425
 426 tcDoStmt m_ty ctxt stmt res_ty thing_inside
 427   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 428
 429 --------------------------------
 430 --      Mdo-notation
 431 -- The distinctive features here are
 432 --      (a) RecStmts, and
 433 --      (b) no rebindable syntax
 434
 435 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 436           -> TcStmtChecker
 437 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 438   = do  { (rhs', pat_ty) <- tc_rhs rhs
 439         ; (pat', thing)  <- tcPat LamPat pat pat_ty res_ty thing_inside
 440         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 441
 442 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 443   = do  { (rhs', elt_ty) <- tc_rhs rhs
 444         ; thing          <- thing_inside res_ty
 445         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 446
 447 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
 448   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 449         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 450         ; tcExtendIdEnv rec_ids                 $ do
 451         { (stmts', (later_ids, rec_rets))
 452                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
 453                         -- ToDo: res_ty not really right
 454                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 455                       ; later_ids <- tcLookupLocalIds laterNames
 456                       ; return (later_ids, rec_rets) }
 457
 458         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
 459                 -- NB:  The rec_ids for the recursive things
 460                 --      already scope over this part. This binding may shadow
 461                 --      some of them with polymorphic things with the same Name
 462                 --      (see note [RecStmt] in HsExpr)
 463         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 464
 465         ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
 466         }}
 467   where
 468     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 469     tc_ret rec_name mono_ty
 470         = do { poly_id <- tcLookupId rec_name
 471                 -- poly_id may have a polymorphic type
 472                 -- but mono_ty is just a monomorphic type variable
 473              ; co_fn <- tcSubExp (idType poly_id) mono_ty
 474              ; return (HsCoerce co_fn (HsVar poly_id)) }
 475
 476 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
 477   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 478
 479 \end{code}
 480
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsection{Errors and contexts}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 489 number of args are used in each equation.
 490
 491 \begin{code}
 492 sameNoOfArgs :: MatchGroup Name -> Bool
 493 sameNoOfArgs (MatchGroup matches _)
 494    = isSingleton (nub (map args_in_match matches))
 495   where
 496     args_in_match :: LMatch Name -> Int
 497     args_in_match (L _ (Match pats _ _)) = length pats
 498 \end{code}
 499
 500 \begin{code}
 501 varyingArgsErr name matches
 502   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 503
 504 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 505                            4 (pprMatch ctxt match)
 506
 507 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
 508 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
 509                           4 (ppr body)
 510
 511 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
 512                         4 (ppr stmt)
 513 \end{code}