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