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