compiler/typecheck/TcMatches.lhs

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