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