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                    TcMatchCtxt(..),
  11                    tcStmts, tcDoStmts, tcBody,
  12                    tcDoStmt, tcMDoStmt, tcGuardStmt
  13        ) where
  14
  15 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
  16                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
  17
  18 import HsSyn
  19 import BasicTypes
  20 import TcRnMonad
  21 import TcEnv
  22 import TcPat
  23 import TcMType
  24 import TcType
  25 import TcBinds
  26 import TcUnify
  27 import Name
  28 import TysWiredIn
  29 import Id
  30 import TyCon
  31 import TysPrim
  32 import Coercion         ( mkSymCoI )
  33 import Outputable
  34 import Util
  35 import SrcLoc
  36 import FastString
  37
  38 -- Create chunkified tuple tybes for monad comprehensions
  39 import MkCore
  40
  41 import Control.Monad
  42
  43 #include "HsVersions.h"
  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 Note [Polymorphic expected type for tcMatchesFun]
  58 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  59 tcMatchesFun may be given a *sigma* (polymorphic) type
  60 so it must be prepared to use tcGen to skolemise it.
  61 See Note [sig_tau may be polymorphic] in TcPat.
  62
  63 \begin{code}
  64 tcMatchesFun :: Name -> Bool
  65              -> MatchGroup Name
  66              -> TcSigmaType                        -- Expected type of function
  67              -> TcM (HsWrapper, MatchGroup TcId)   -- Returns type of body
  68 tcMatchesFun fun_name inf matches exp_ty
  69   = do  {  -- Check that they all have the same no of arguments
  70            -- Location is in the monad, set the caller so that
  71            -- any inter-equation error messages get some vaguely
  72            -- sensible location.        Note: we have to do this odd
  73            -- ann-grabbing, because we don't always have annotations in
  74            -- hand when we call tcMatchesFun...
  75           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
  76         ; checkArgs fun_name matches
  77
  78         ; (wrap_gen, (wrap_fun, group))
  79             <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
  80                   -- Note [Polymorphic expected type for tcMatchesFun]
  81                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
  82                tcMatches match_ctxt pat_tys rhs_ty matches
  83         ; return (wrap_gen <.> wrap_fun, group) }
  84   where
  85     arity = matchGroupArity matches
  86     herald = ptext (sLit "The equation(s) for")
  87              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
  88     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
  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               -> TcRhoType              -- Type of whole case expressions
  99               -> TcM (MatchGroup TcId)  -- Translated alternatives
 100
 101 tcMatchesCase ctxt scrut_ty matches res_ty
 102   | isEmptyMatchGroup matches   -- Allow empty case expressions
 103   = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty))
 104
 105   | otherwise
 106   = tcMatches ctxt [scrut_ty] res_ty matches
 107
 108 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
 109 tcMatchLambda match res_ty
 110   = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
 111     tcMatches match_ctxt pat_tys rhs_ty match
 112   where
 113     n_pats = matchGroupArity match
 114     herald = sep [ ptext (sLit "The lambda expression")
 115                          <+> quotes (pprSetDepth (PartWay 1) $
 116                              pprMatches (LambdaExpr :: HsMatchContext Name) match),
 117                         -- The pprSetDepth makes the abstraction print briefly
 118                 ptext (sLit "has")]
 119     match_ctxt = MC { mc_what = LambdaExpr,
 120                       mc_body = tcBody }
 121 \end{code}
 122
 123 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 124
 125 \begin{code}
 126 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
 127 -- Used for pattern bindings
 128 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 129   where
 130     match_ctxt = MC { mc_what = PatBindRhs,
 131                       mc_body = tcBody }
 132 \end{code}
 133
 134
 135 \begin{code}
 136 matchFunTys
 137   :: SDoc       -- See Note [Herald for matchExpecteFunTys] in TcUnify
 138   -> Arity
 139   -> TcRhoType
 140   -> ([TcSigmaType] -> TcRhoType -> TcM a)
 141   -> TcM (HsWrapper, a)
 142
 143 -- Written in CPS style for historical reasons;
 144 -- could probably be un-CPSd, like matchExpectedTyConApp
 145
 146 matchFunTys herald arity res_ty thing_inside
 147   = do  { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
 148         ; res <- thing_inside pat_tys res_ty
 149         ; return (coiToHsWrapper (mkSymCoI coi), res) }
 150 \end{code}
 151
 152 %************************************************************************
 153 %*                                                                      *
 154 \subsection{tcMatch}
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 \begin{code}
 159 tcMatches :: TcMatchCtxt
 160           -> [TcSigmaType]      -- Expected pattern types
 161           -> TcRhoType          -- Expected result-type of the Match.
 162           -> MatchGroup Name
 163           -> TcM (MatchGroup TcId)
 164
 165 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 166   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 167          mc_body :: LHsExpr Name                -- Type checker for a body of
 168                                                 -- an alternative
 169                  -> TcRhoType
 170                  -> TcM (LHsExpr TcId) }
 171
 172 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 173   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
 174     do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 175         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 176
 177 -------------
 178 tcMatch :: TcMatchCtxt
 179         -> [TcSigmaType]        -- Expected pattern types
 180         -> TcRhoType            -- Expected result-type of the Match.
 181         -> LMatch Name
 182         -> TcM (LMatch TcId)
 183
 184 tcMatch ctxt pat_tys rhs_ty match
 185   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 186   where
 187     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 188       = add_match_ctxt match $
 189         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
 190                                 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
 191            ; return (Match pats' Nothing grhss') }
 192
 193     tc_grhss ctxt Nothing grhss rhs_ty
 194       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 195
 196         -- Result type sigs are no longer supported
 197     tc_grhss _ (Just {}) _ _
 198       = panic "tc_ghrss"        -- Rejected by renamer
 199
 200         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 201         -- so we don't want to add "In the lambda abstraction \x->e"
 202     add_match_ctxt match thing_inside
 203         = case mc_what ctxt of
 204             LambdaExpr -> thing_inside
 205             m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 206
 207 -------------
 208 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
 209         -> TcM (GRHSs TcId)
 210
 211 -- Notice that we pass in the full res_ty, so that we get
 212 -- good inference from simple things like
 213 --      f = \(x::forall a.a->a) -> <stuff>
 214 -- We used to force it to be a monotype when there was more than one guard
 215 -- but we don't need to do that any more
 216
 217 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 218   = do  { (binds', grhss') <- tcLocalBinds binds $
 219                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 220
 221         ; return (GRHSs grhss' binds') }
 222
 223 -------------
 224 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
 225
 226 tcGRHS ctxt res_ty (GRHS guards rhs)
 227   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 228                              mc_body ctxt rhs
 229         ; return (GRHS guards' rhs') }
 230   where
 231     stmt_ctxt  = PatGuard (mc_what ctxt)
 232 \end{code}
 233
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 \begin{code}
 242 tcDoStmts :: HsStmtContext Name
 243           -> [LStmt Name]
 244           -> LHsExpr Name
 245           -> SyntaxExpr Name            -- 'return' function for monad
 246                                         -- comprehensions
 247           -> TcRhoType
 248           -> TcM (HsExpr TcId)          -- Returns a HsDo
 249 tcDoStmts ListComp stmts body _ res_ty
 250   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 251         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
 252                                      elt_ty $
 253                              tcBody body
 254         ; return $ mkHsWrapCoI coi
 255                      (HsDo ListComp stmts' body' noSyntaxExpr (mkListTy elt_ty)) }
 256
 257 tcDoStmts PArrComp stmts body _ res_ty
 258   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 259         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
 260                                      elt_ty $
 261                              tcBody body
 262         ; return $ mkHsWrapCoI coi
 263                      (HsDo PArrComp stmts' body' noSyntaxExpr (mkPArrTy elt_ty)) }
 264
 265 tcDoStmts DoExpr stmts body _ res_ty
 266   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
 267                              tcBody body
 268         ; return (HsDo DoExpr stmts' body' noSyntaxExpr res_ty) }
 269
 270 tcDoStmts MDoExpr stmts body _ res_ty
 271   = do  { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
 272                              tcBody body
 273         ; return (HsDo MDoExpr stmts' body' noSyntaxExpr res_ty) }
 274
 275 tcDoStmts MonadComp stmts body return_op res_ty
 276   = do  { (stmts', (body', return_op')) <- tcStmts MonadComp tcMcStmt stmts res_ty $
 277                                            tcMcBody body return_op
 278         ; return $ HsDo MonadComp stmts' body' return_op' res_ty }
 279
 280 tcDoStmts ctxt _ _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 281
 282 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 283 tcBody body res_ty
 284   = do  { traceTc "tcBody" (ppr res_ty)
 285         ; body' <- tcMonoExpr body res_ty
 286         ; return body'
 287         }
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{tcStmts}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297 \begin{code}
 298 type TcStmtChecker
 299   =  forall thing. HsStmtContext Name
 300                 -> Stmt Name
 301                 -> TcRhoType                    -- Result type for comprehension
 302                 -> (TcRhoType -> TcM thing)     -- Checker for what follows the stmt
 303                 -> TcM (Stmt TcId, thing)
 304
 305 tcStmts :: HsStmtContext Name
 306         -> TcStmtChecker        -- NB: higher-rank type
 307         -> [LStmt Name]
 308         -> TcRhoType
 309         -> (TcRhoType -> TcM thing)
 310         -> TcM ([LStmt TcId], thing)
 311
 312 -- Note the higher-rank type.  stmt_chk is applied at different
 313 -- types in the equations for tcStmts
 314
 315 tcStmts _ _ [] res_ty thing_inside
 316   = do  { thing <- thing_inside res_ty
 317         ; return ([], thing) }
 318
 319 -- LetStmts are handled uniformly, regardless of context
 320 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 321   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 322                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 323         ; return (L loc (LetStmt binds') : stmts', thing) }
 324
 325 -- For the vanilla case, handle the location-setting part
 326 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 327   = do  { (stmt', (stmts', thing)) <-
 328                 setSrcSpan loc                          $
 329                 addErrCtxt (pprStmtInCtxt ctxt stmt)    $
 330                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 331                 popErrCtxt                              $
 332                 tcStmts ctxt stmt_chk stmts res_ty'     $
 333                 thing_inside
 334         ; return (L loc stmt' : stmts', thing) }
 335
 336 --------------------------------
 337 --      Pattern guards
 338 tcGuardStmt :: TcStmtChecker
 339 tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
 340   = do  { guard' <- tcMonoExpr guard boolTy
 341         ; thing  <- thing_inside res_ty
 342         ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 343
 344 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 345   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
 346         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
 347                             thing_inside res_ty
 348         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 349
 350 tcGuardStmt _ stmt _ _
 351   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 352
 353
 354 --------------------------------
 355 --      List comprehensions and PArrays
 356
 357 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 358          -> TcStmtChecker
 359
 360 -- A generator, pat <- rhs
 361 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 362  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
 363         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
 364         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 365                             thing_inside res_ty
 366         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 367
 368 -- A boolean guard
 369 tcLcStmt _ _ (ExprStmt rhs _ _ _) res_ty thing_inside
 370   = do  { rhs'  <- tcMonoExpr rhs boolTy
 371         ; thing <- thing_inside res_ty
 372         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 373
 374 -- A parallel set of comprehensions
 375 --      [ (g x, h x) | ... ; let g v = ...
 376 --                   | ... ; let h v = ... ]
 377 --
 378 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 379 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
 380 -- Similarly if we had an existential pattern match:
 381 --
 382 --      data T = forall a. Show a => C a
 383 --
 384 --      [ (show x, show y) | ... ; C x <- ...
 385 --                         | ... ; C y <- ... ]
 386 --
 387 -- Then we need the LIE from (show x, show y) to be simplified against
 388 -- the bindings for x and y.
 389 --
 390 -- It's difficult to do this in parallel, so we rely on the renamer to
 391 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 392 -- So the binders of the first parallel group will be in scope in the second
 393 -- group.  But that's fine; there's no shadowing to worry about.
 394
 395 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
 396   = do  { (pairs', thing) <- loop bndr_stmts_s
 397         ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
 398   where
 399     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 400     loop [] = do { thing <- thing_inside elt_ty
 401                  ; return ([], thing) }         -- matching in the branches
 402
 403     loop ((stmts, names) : pairs)
 404       = do { (stmts', (ids, pairs', thing))
 405                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 406                    do { ids <- tcLookupLocalIds names
 407                       ; (pairs', thing) <- loop pairs
 408                       ; return (ids, pairs', thing) }
 409            ; return ( (stmts', ids) : pairs', thing ) }
 410
 411 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_ty thing_inside = do
 412     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 413         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 414             let alphaListTy = mkTyConApp m_tc [alphaTy]
 415
 416             (usingExpr', maybeByExpr') <-
 417                 case maybeByExpr of
 418                     Nothing -> do
 419                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 420                         let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
 421                         usingExpr' <- tcPolyExpr usingExpr using_ty
 422                         return (usingExpr', Nothing)
 423                     Just byExpr -> do
 424                         -- We must infer a type such that e :: t and then check that
 425                         -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
 426                         (byExpr', tTy) <- tcInferRhoNC byExpr
 427                         let using_ty = mkForAllTy alphaTyVar $
 428                                        (alphaTy `mkFunTy` tTy)
 429                                        `mkFunTy` alphaListTy `mkFunTy` alphaListTy
 430                         usingExpr' <- tcPolyExpr usingExpr using_ty
 431                         return (usingExpr', Just byExpr')
 432
 433             binders' <- tcLookupLocalIds binders
 434             thing <- thing_inside elt_ty'
 435
 436             return (binders', usingExpr', maybeByExpr', thing)
 437
 438     return (TransformStmt stmts' binders' usingExpr' maybeByExpr' noSyntaxExpr noSyntaxExpr, thing)
 439
 440 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_inside
 441   = do { let (bndr_names, list_bndr_names) = unzip bindersMap
 442
 443        ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
 444             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 445                 (by', using_ty) <-
 446                    case by of
 447                      Nothing   -> -- check that using :: forall a. [a] -> [[a]]
 448                                   return (Nothing, mkForAllTy alphaTyVar $
 449                                                    alphaListTy `mkFunTy` alphaListListTy)
 450
 451                      Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
 452                                   -- where by :: t
 453                                   do { (by_e', t_ty) <- tcInferRhoNC by_e
 454                                      ; return (Just by_e', mkForAllTy alphaTyVar $
 455                                                            (alphaTy `mkFunTy` t_ty)
 456                                                            `mkFunTy` alphaListTy
 457                                                            `mkFunTy` alphaListListTy) }
 458                 -- Find the Ids (and hence types) of all old binders
 459                 bndr_ids <- tcLookupLocalIds bndr_names
 460
 461                 return (bndr_ids, by', using_ty, elt_ty')
 462
 463                 -- Ensure that every old binder of type b is linked up with
 464                 -- its new binder which should have type [b]
 465        ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
 466              bindersMap' = bndr_ids `zip` list_bndr_ids
 467              -- See Note [GroupStmt binder map] in HsExpr
 468
 469        ; using' <- case using of
 470                      Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
 471                      Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
 472
 473              -- Type check the thing in the environment with
 474              -- these new binders and return the result
 475        ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
 476        ; return (GroupStmt stmts' bindersMap' by' using' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
 477   where
 478     alphaListTy = mkTyConApp m_tc [alphaTy]
 479     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 480
 481     mk_list_bndr :: Name -> TcId -> TcId
 482     mk_list_bndr list_bndr_name bndr_id
 483       = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
 484
 485 tcLcStmt _ _ stmt _ _
 486   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 487
 488
 489 --------------------------------
 490 --      Monad comprehensions
 491
 492 tcMcStmt :: TcStmtChecker
 493
 494 -- Generators for monad comprehensions ( pat <- rhs )
 495 --
 496 --   [ body | q <- gen ]  ->  gen :: m a
 497 --                            q   ::   a
 498 --
 499 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 500  = do   { rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 501         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
 502         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 503         ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op
 504                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 505
 506                       -- If (but only if) the pattern can fail,
 507                       -- typecheck the 'fail' operator
 508         ; fail_op' <- if isIrrefutableHsPat pat
 509                       then return noSyntaxExpr
 510                       else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
 511
 512         ; rhs' <- tcMonoExprNC rhs rhs_ty
 513         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
 514                            thing_inside new_res_ty
 515
 516         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 517
 518 -- Boolean expressions.
 519 --
 520 --   [ body | stmts, expr ]  ->  expr :: m Bool
 521 --
 522 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
 523   = do  { -- Deal with rebindable syntax:
 524           --    guard_op :: test_ty -> rhs_ty
 525           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
 526           -- Where test_ty is, for example, Bool
 527           test_ty    <- newFlexiTyVarTy liftedTypeKind
 528         ; rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 529         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 530         ; rhs'       <- tcMonoExpr rhs test_ty
 531         ; guard_op'  <- tcSyntaxOp MCompOrigin guard_op
 532                                    (mkFunTy test_ty rhs_ty)
 533         ; then_op'   <- tcSyntaxOp MCompOrigin then_op
 534                                    (mkFunTys [rhs_ty, new_res_ty] res_ty)
 535         ; thing      <- thing_inside new_res_ty
 536         ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
 537
 538 -- Transform statements.
 539 --
 540 --   [ body | stmts, then f ]       ->  f :: forall a. m a -> m a
 541 --   [ body | stmts, then f by e ]  ->  f :: forall a. (a -> t) -> m a -> m a
 542 --
 543 tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) elt_ty thing_inside
 544   = do  {
 545         -- We don't know the types of binders yet, so we use this dummy and
 546         -- later unify this type with the `m_bndr_ty`
 547           ty_dummy <- newFlexiTyVarTy liftedTypeKind
 548
 549         ; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
 550               tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \elt_ty' -> do
 551                   { (_, (m_ty, _)) <- matchExpectedAppTy elt_ty'
 552                   ; (usingExpr', maybeByExpr') <-
 553                         case maybeByExpr of
 554                             Nothing -> do
 555                                 -- We must validate that usingExpr :: forall a. m a -> m a
 556                                 let using_ty = mkForAllTy alphaTyVar $
 557                                                (m_ty `mkAppTy` alphaTy)
 558                                                `mkFunTy`
 559                                                (m_ty `mkAppTy` alphaTy)
 560                                 usingExpr' <- tcPolyExpr usingExpr using_ty
 561                                 return (usingExpr', Nothing)
 562                             Just byExpr -> do
 563                                 -- We must infer a type such that e :: t and then check that
 564                                 -- usingExpr :: forall a. (a -> t) -> m a -> m a
 565                                 (byExpr', tTy) <- tcInferRhoNC byExpr
 566                                 let using_ty = mkForAllTy alphaTyVar $
 567                                                (alphaTy `mkFunTy` tTy)
 568                                                `mkFunTy`
 569                                                (m_ty `mkAppTy` alphaTy)
 570                                                `mkFunTy`
 571                                                (m_ty `mkAppTy` alphaTy)
 572                                 usingExpr' <- tcPolyExpr usingExpr using_ty
 573                                 return (usingExpr', Just byExpr')
 574
 575                   ; bndr_ids <- tcLookupLocalIds binders
 576
 577                   -- `return` and `>>=` are used to pass around/modify our
 578                   -- binders, so we know their types:
 579                   --
 580                   --   return :: (a,b,c,..) -> m (a,b,c,..)
 581                   --   (>>=)  :: m (a,b,c,..)
 582                   --          -> ( (a,b,c,..) -> m (a,b,c,..) )
 583                   --          -> m (a,b,c,..)
 584                   --
 585                   ; let bndr_ty   = mkChunkified mkBoxedTupleTy $ map idType bndr_ids
 586                         m_bndr_ty = m_ty `mkAppTy` bndr_ty
 587
 588                   ; return_op' <- tcSyntaxOp MCompOrigin return_op
 589                                       (bndr_ty `mkFunTy` m_bndr_ty)
 590
 591                   ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op $
 592                                       m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` elt_ty)
 593                                                 `mkFunTy` elt_ty
 594
 595                   -- Unify types of the inner comprehension and the binders type
 596                   ; _ <- unifyType elt_ty' m_bndr_ty
 597
 598                   -- Typecheck the `thing` with out old type (which is the type
 599                   -- of the final result of our comprehension)
 600                   ; thing <- thing_inside elt_ty
 601
 602                   ; return (bndr_ids, usingExpr', maybeByExpr', return_op', bind_op', thing) }
 603
 604         ; return (TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op', thing) }
 605
 606 -- Grouping statements
 607 --
 608 --   [ body | stmts, then group by e ]
 609 --     ->  e :: t
 610 --   [ body | stmts, then group by e using f ]
 611 --     ->  e :: t
 612 --         f :: forall a. (a -> t) -> m a -> m (m a)
 613 --   [ body | stmts, then group using f ]
 614 --     ->  f :: forall a. m a -> m (m a)
 615 --
 616 tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op liftM_op) elt_ty thing_inside
 617   = do { let (bndr_names, m_bndr_names) = unzip bindersMap
 618
 619        ; (_,(m_ty,_)) <- matchExpectedAppTy elt_ty
 620        ; let alphaMTy  = m_ty `mkAppTy` alphaTy
 621              alphaMMTy = m_ty `mkAppTy` alphaMTy
 622
 623        -- We don't know the type of the bindings yet. It's not elt_ty!
 624        ; bndr_ty_dummy <- newFlexiTyVarTy liftedTypeKind
 625
 626        ; (stmts', (bndr_ids, by', using_ty, return_op', bind_op')) <-
 627             tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts bndr_ty_dummy $ \elt_ty' -> do
 628                 { (by', using_ty) <-
 629                      case by of
 630                        Nothing   -> -- check that using :: forall a. m a -> m (m a)
 631                                     return (Nothing, mkForAllTy alphaTyVar $
 632                                                      alphaMTy `mkFunTy` alphaMMTy)
 633
 634                        Just by_e -> -- check that using :: forall a. (a -> t) -> m a -> m (m a)
 635                                     -- where by :: t
 636                                     do { (by_e', t_ty) <- tcInferRhoNC by_e
 637                                        ; return (Just by_e', mkForAllTy alphaTyVar $
 638                                                              (alphaTy `mkFunTy` t_ty)
 639                                                              `mkFunTy` alphaMTy
 640                                                              `mkFunTy` alphaMMTy) }
 641
 642
 643                 -- Find the Ids (and hence types) of all old binders
 644                 ; bndr_ids <- tcLookupLocalIds bndr_names
 645
 646                 -- 'return' is only used for the binders, so we know its type.
 647                 --
 648                 --   return :: (a,b,c,..) -> m (a,b,c,..)
 649                 --
 650                 ; let bndr_ty   = mkChunkified mkBoxedTupleTy $ map idType bndr_ids
 651                       m_bndr_ty = m_ty `mkAppTy` bndr_ty
 652                 ; return_op' <- tcSyntaxOp MCompOrigin return_op $ bndr_ty `mkFunTy` m_bndr_ty
 653
 654                 -- '>>=' is used to pass the grouped binders to the rest of the
 655                 -- comprehension.
 656                 --
 657                 --   (>>=) :: m (m a, m b, m c, ..)
 658                 --         -> ( (m a, m b, m c, ..) -> new_elt_ty )
 659                 --         -> elt_ty
 660                 --
 661                 ; let bndr_m_ty   = mkChunkified mkBoxedTupleTy $ map (mkAppTy m_ty . idType) bndr_ids
 662                       m_bndr_m_ty = m_ty `mkAppTy` bndr_m_ty
 663                 ; new_elt_ty <- newFlexiTyVarTy liftedTypeKind
 664                 ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op $
 665                                            m_bndr_m_ty `mkFunTy` (bndr_m_ty `mkFunTy` new_elt_ty)
 666                                                        `mkFunTy` elt_ty
 667
 668                 -- Finally make sure the type of the inner comprehension
 669                 -- represents the types of our binders
 670                 ; _ <- unifyType elt_ty' m_bndr_ty
 671
 672                 ; return (bndr_ids, by', using_ty, return_op', bind_op') }
 673
 674        ; let mk_m_bndr :: Name -> TcId -> TcId
 675              mk_m_bndr m_bndr_name bndr_id =
 676                 mkLocalId m_bndr_name (m_ty `mkAppTy` idType bndr_id)
 677
 678              -- Ensure that every old binder of type `b` is linked up with its
 679              -- new binder which should have type `m b`
 680              m_bndr_ids = zipWith mk_m_bndr m_bndr_names bndr_ids
 681              bindersMap' = bndr_ids `zip` m_bndr_ids
 682
 683              -- See Note [GroupStmt binder map] in HsExpr
 684
 685        ; using' <- case using of
 686                      Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
 687                      Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
 688
 689        -- Type check 'liftM' with 'forall a b. (a -> b) -> m_ty a -> m_ty b'
 690        ; liftM_op' <- fmap unLoc . tcPolyExpr (noLoc liftM_op) $
 691                          mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
 692                              (alphaTy `mkFunTy` betaTy)
 693                              `mkFunTy`
 694                              (m_ty `mkAppTy` alphaTy)
 695                              `mkFunTy`
 696                              (m_ty `mkAppTy` betaTy)
 697
 698        -- Type check the thing in the environment with these new binders and
 699        -- return the result
 700        ; thing <- tcExtendIdEnv m_bndr_ids (thing_inside elt_ty)
 701
 702        ; return (GroupStmt stmts' bindersMap' by' using' return_op' bind_op' liftM_op', thing) }
 703
 704 -- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
 705 -- of `ParStmt`s.
 706 --
 707 -- Note: The `mzip` function will get typechecked via:
 708 --
 709 --   ParStmt [st1::t1, st2::t2, st3::t3]
 710 --
 711 --   mzip :: m st1
 712 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
 713 --        -> m (st1, (st2, st3))
 714 --
 715 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) elt_ty thing_inside
 716   = do  { (_,(m_ty,_)) <- matchExpectedAppTy elt_ty
 717         ; (pairs', thing) <- loop m_ty bndr_stmts_s
 718
 719         ; let mzip_ty  = mkForAllTys [alphaTyVar, betaTyVar] $
 720                          (m_ty `mkAppTy` alphaTy)
 721                          `mkFunTy`
 722                          (m_ty `mkAppTy` betaTy)
 723                          `mkFunTy`
 724                          (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
 725         ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
 726
 727         -- Typecheck bind:
 728         ; let tys      = map (mkChunkified mkBoxedTupleTy . map idType . snd) pairs'
 729               tuple_ty = mk_tuple_ty tys
 730
 731         ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
 732                          (m_ty `mkAppTy` tuple_ty)
 733                          `mkFunTy`
 734                          (tuple_ty `mkFunTy` elt_ty)
 735                          `mkFunTy`
 736                          elt_ty
 737
 738         ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
 739                             mkForAllTy alphaTyVar $
 740                             alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
 741         ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
 742
 743  where mk_tuple_ty tys = foldr (\tn tm -> mkBoxedTupleTy [tn, tm]) (last tys) (init tys)
 744
 745        -- loop :: Type                                  -- m_ty
 746        --      -> [([LStmt Name], [Name])]
 747        --      -> TcM ([([LStmt TcId], [TcId])], thing)
 748        loop _ [] = do { thing <- thing_inside elt_ty
 749                       ; return ([], thing) }           -- matching in the branches
 750
 751        loop m_ty ((stmts, names) : pairs)
 752          = do { -- type dummy since we don't know all binder types yet
 753                 ty_dummy <- newFlexiTyVarTy liftedTypeKind
 754               ; (stmts', (ids, pairs', thing))
 755                    <- tcStmts ctxt tcMcStmt stmts ty_dummy $ \elt_ty' ->
 756                       do { ids <- tcLookupLocalIds names
 757                          ; _ <- unifyType elt_ty' (m_ty `mkAppTy` (mkChunkified mkBoxedTupleTy) (map idType ids))
 758                          ; (pairs', thing) <- loop m_ty pairs
 759                          ; return (ids, pairs', thing) }
 760               ; return ( (stmts', ids) : pairs', thing ) }
 761
 762 tcMcStmt _ stmt _ _
 763   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
 764
 765 -- Typecheck 'body' with type 'a' instead of 'm a' like the rest of the
 766 -- statements, ignore the second type argument coming from the tcStmts loop
 767 tcMcBody :: LHsExpr Name
 768          -> SyntaxExpr Name
 769          -> TcRhoType
 770          -> TcM (LHsExpr TcId, SyntaxExpr TcId)
 771 tcMcBody body return_op res_ty
 772   = do  { (_, (_, a_ty)) <- matchExpectedAppTy res_ty
 773         ; body'      <- tcMonoExpr body a_ty
 774         ; return_op' <- tcSyntaxOp MCompOrigin return_op
 775                                 (a_ty `mkFunTy` res_ty)
 776         ; return (body', return_op')
 777         }
 778
 779
 780 --------------------------------
 781 --      Do-notation
 782 -- The main excitement here is dealing with rebindable syntax
 783
 784 tcDoStmt :: TcStmtChecker
 785
 786 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 787   = do  {       -- Deal with rebindable syntax:
 788                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 789                 -- This level of generality is needed for using do-notation
 790                 -- in full generality; see Trac #1537
 791
 792                 -- I'd like to put this *after* the tcSyntaxOp
 793                 -- (see Note [Treat rebindable syntax first], but that breaks
 794                 -- the rigidity info for GADTs.  When we move to the new story
 795                 -- for GADTs, we can move this after tcSyntaxOp
 796           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 797         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
 798         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 799         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op
 800                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 801
 802                 -- If (but only if) the pattern can fail,
 803                 -- typecheck the 'fail' operator
 804         ; fail_op' <- if isIrrefutableHsPat pat
 805                       then return noSyntaxExpr
 806                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 807
 808         ; rhs' <- tcMonoExprNC rhs rhs_ty
 809         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
 810                            thing_inside new_res_ty
 811
 812         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 813
 814
 815 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
 816   = do  {       -- Deal with rebindable syntax;
 817                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 818                 -- See also Note [Treat rebindable syntax first]
 819           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 820         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 821         ; then_op' <- tcSyntaxOp DoOrigin then_op
 822                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 823
 824         ; rhs' <- tcMonoExprNC rhs rhs_ty
 825         ; thing <- thing_inside new_res_ty
 826         ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
 827
 828 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 829                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
 830                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
 831          res_ty thing_inside
 832   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
 833         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
 834         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
 835               tup_ty  = mkBoxedTupleTy tup_elt_tys
 836
 837         ; tcExtendIdEnv tup_ids $ do
 838         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
 839         ; (stmts', (ret_op', tup_rets))
 840                 <- tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
 841                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
 842                              -- Unify the types of the "final" Ids (which may
 843                              -- be polymorphic) with those of "knot-tied" Ids
 844                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
 845                       ; return (ret_op', tup_rets) }
 846
 847         ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
 848         ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
 849                                  (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
 850
 851         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 852         ; bind_op' <- tcSyntaxOp DoOrigin bind_op
 853                                  (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 854
 855         ; thing <- thing_inside new_res_ty
 856 --         ; lie_binds <- bindLocalMethods lie tup_ids
 857
 858         ; let rec_ids = takeList rec_names tup_ids
 859         ; later_ids <- tcLookupLocalIds later_names
 860         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
 861                                  ppr later_ids <+> ppr (map idType later_ids)]
 862         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 863                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
 864                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
 865                           , recS_rec_rets = tup_rets }, thing)
 866         }}
 867
 868 tcDoStmt _ stmt _ _
 869   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 870 \end{code}
 871
 872 Note [Treat rebindable syntax first]
 873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 874 When typechecking
 875         do { bar; ... } :: IO ()
 876 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 877 pushing info from the context into the RHS.  To do this, we check the
 878 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
 879 Otherwise the error shows up when cheking the rebindable syntax, and
 880 the expected/inferred stuff is back to front (see Trac #3613).
 881
 882 \begin{code}
 883 --------------------------------
 884 --      Mdo-notation
 885 -- The distinctive features here are
 886 --      (a) RecStmts, and
 887 --      (b) no rebindable syntax
 888
 889 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 890           -> TcStmtChecker
 891 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 892   = do  { (rhs', pat_ty) <- tc_rhs rhs
 893         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 894                             thing_inside res_ty
 895         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 896
 897 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside
 898   = do  { (rhs', elt_ty) <- tc_rhs rhs
 899         ; thing          <- thing_inside res_ty
 900         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
 901
 902 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
 903                                , recS_rec_ids = recNames }) res_ty thing_inside
 904   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 905         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 906         ; tcExtendIdEnv rec_ids                 $ do
 907         { (stmts', (later_ids, rec_rets))
 908                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
 909                         -- ToDo: res_ty not really right
 910                    do { rec_rets <- zipWithM tcCheckId recNames rec_tys
 911                       ; later_ids <- tcLookupLocalIds laterNames
 912                       ; return (later_ids, rec_rets) }
 913
 914         ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
 915                 -- NB:  The rec_ids for the recursive things
 916                 --      already scope over this part. This binding may shadow
 917                 --      some of them with polymorphic things with the same Name
 918                 --      (see note [RecStmt] in HsExpr)
 919
 920         ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
 921         }}
 922
 923 tcMDoStmt _ _ stmt _ _
 924   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 925
 926 \end{code}
 927
 928
 929 %************************************************************************
 930 %*                                                                      *
 931 \subsection{Errors and contexts}
 932 %*                                                                      *
 933 %************************************************************************
 934
 935 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 936 number of args are used in each equation.
 937
 938 \begin{code}
 939 checkArgs :: Name -> MatchGroup Name -> TcM ()
 940 checkArgs fun (MatchGroup (match1:matches) _)
 941     | null bad_matches = return ()
 942     | otherwise
 943     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
 944                           ptext (sLit "have different numbers of arguments"),
 945                         nest 2 (ppr (getLoc match1)),
 946                         nest 2 (ppr (getLoc (head bad_matches)))])
 947   where
 948     n_args1 = args_in_match match1
 949     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 950
 951     args_in_match :: LMatch Name -> Int
 952     args_in_match (L _ (Match pats _ _)) = length pats
 953 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
 954 \end{code}
 955