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