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 TcRnMonad
  20 import TcEnv
  21 import TcPat
  22 import TcMType
  23 import TcType
  24 import TcBinds
  25 import TcUnify
  26 import Name
  27 import TysWiredIn
  28 import Id
  29 import TyCon
  30 import TysPrim
  31 import Coercion         ( mkSymCo )
  32 import Outputable
  33 import BasicTypes       ( Arity )
  34 import Util
  35 import SrcLoc
  36 import FastString
  37
  38 import Control.Monad
  39
  40 #include "HsVersions.h"
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection{tcMatchesFun, tcMatchesCase}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  50 @FunMonoBind@.  The second argument is the name of the function, which
  51 is used in error messages.  It checks that all the equations have the
  52 same number of arguments before using @tcMatches@ to do the work.
  53
  54 Note [Polymorphic expected type for tcMatchesFun]
  55 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  56 tcMatchesFun may be given a *sigma* (polymorphic) type
  57 so it must be prepared to use tcGen to skolemise it.
  58 See Note [sig_tau may be polymorphic] in TcPat.
  59
  60 \begin{code}
  61 tcMatchesFun :: Name -> Bool
  62              -> MatchGroup Name
  63              -> TcSigmaType                        -- Expected type of function
  64              -> TcM (HsWrapper, MatchGroup TcId)   -- Returns type of body
  65 tcMatchesFun fun_name inf matches exp_ty
  66   = do  {  -- Check that they all have the same no of arguments
  67            -- Location is in the monad, set the caller so that
  68            -- any inter-equation error messages get some vaguely
  69            -- sensible location.        Note: we have to do this odd
  70            -- ann-grabbing, because we don't always have annotations in
  71            -- hand when we call tcMatchesFun...
  72           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
  73         ; checkArgs fun_name matches
  74
  75         ; (wrap_gen, (wrap_fun, group))
  76             <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
  77                   -- Note [Polymorphic expected type for tcMatchesFun]
  78                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
  79                tcMatches match_ctxt pat_tys rhs_ty matches
  80         ; return (wrap_gen <.> wrap_fun, group) }
  81   where
  82     arity = matchGroupArity matches
  83     herald = ptext (sLit "The equation(s) for")
  84              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
  85     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
  86 \end{code}
  87
  88 @tcMatchesCase@ doesn't do the argument-count check because the
  89 parser guarantees that each equation has exactly one argument.
  90
  91 \begin{code}
  92 tcMatchesCase :: TcMatchCtxt            -- Case context
  93               -> TcRhoType              -- Type of scrutinee
  94               -> MatchGroup Name        -- The case alternatives
  95               -> TcRhoType              -- Type of whole case expressions
  96               -> TcM (MatchGroup TcId)  -- Translated alternatives
  97
  98 tcMatchesCase ctxt scrut_ty matches res_ty
  99   | isEmptyMatchGroup matches   -- Allow empty case expressions
 100   = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty))
 101
 102   | otherwise
 103   = tcMatches ctxt [scrut_ty] res_ty matches
 104
 105 tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
 106 tcMatchLambda match res_ty
 107   = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
 108     tcMatches match_ctxt pat_tys rhs_ty match
 109   where
 110     n_pats = matchGroupArity match
 111     herald = sep [ ptext (sLit "The lambda expression")
 112                          <+> quotes (pprSetDepth (PartWay 1) $
 113                              pprMatches (LambdaExpr :: HsMatchContext Name) match),
 114                         -- The pprSetDepth makes the abstraction print briefly
 115                 ptext (sLit "has")]
 116     match_ctxt = MC { mc_what = LambdaExpr,
 117                       mc_body = tcBody }
 118 \end{code}
 119
 120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 121
 122 \begin{code}
 123 tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
 124 -- Used for pattern bindings
 125 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 126   where
 127     match_ctxt = MC { mc_what = PatBindRhs,
 128                       mc_body = tcBody }
 129 \end{code}
 130
 131
 132 \begin{code}
 133 matchFunTys
 134   :: SDoc       -- See Note [Herald for matchExpecteFunTys] in TcUnify
 135   -> Arity
 136   -> TcRhoType
 137   -> ([TcSigmaType] -> TcRhoType -> TcM a)
 138   -> TcM (HsWrapper, a)
 139
 140 -- Written in CPS style for historical reasons;
 141 -- could probably be un-CPSd, like matchExpectedTyConApp
 142
 143 matchFunTys herald arity res_ty thing_inside
 144   = do  { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
 145         ; res <- thing_inside pat_tys res_ty
 146         ; return (coToHsWrapper (mkSymCo coi), res) }
 147 \end{code}
 148
 149 %************************************************************************
 150 %*                                                                      *
 151 \subsection{tcMatch}
 152 %*                                                                      *
 153 %************************************************************************
 154
 155 \begin{code}
 156 tcMatches :: TcMatchCtxt
 157           -> [TcSigmaType]      -- Expected pattern types
 158           -> TcRhoType          -- Expected result-type of the Match.
 159           -> MatchGroup Name
 160           -> TcM (MatchGroup TcId)
 161
 162 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 163   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 164          mc_body :: LHsExpr Name                -- Type checker for a body of
 165                                                 -- an alternative
 166                  -> TcRhoType
 167                  -> TcM (LHsExpr TcId) }
 168
 169 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 170   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
 171     do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 172         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 173
 174 -------------
 175 tcMatch :: TcMatchCtxt
 176         -> [TcSigmaType]        -- Expected pattern types
 177         -> TcRhoType            -- Expected result-type of the Match.
 178         -> LMatch Name
 179         -> TcM (LMatch TcId)
 180
 181 tcMatch ctxt pat_tys rhs_ty match
 182   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 183   where
 184     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 185       = add_match_ctxt match $
 186         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
 187                                 tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
 188            ; return (Match pats' Nothing grhss') }
 189
 190     tc_grhss ctxt Nothing grhss rhs_ty
 191       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 192
 193         -- Result type sigs are no longer supported
 194     tc_grhss _ (Just {}) _ _
 195       = panic "tc_ghrss"        -- Rejected by renamer
 196
 197         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 198         -- so we don't want to add "In the lambda abstraction \x->e"
 199     add_match_ctxt match thing_inside
 200         = case mc_what ctxt of
 201             LambdaExpr -> thing_inside
 202             m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 203
 204 -------------
 205 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
 206         -> TcM (GRHSs TcId)
 207
 208 -- Notice that we pass in the full res_ty, so that we get
 209 -- good inference from simple things like
 210 --      f = \(x::forall a.a->a) -> <stuff>
 211 -- We used to force it to be a monotype when there was more than one guard
 212 -- but we don't need to do that any more
 213
 214 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 215   = do  { (binds', grhss') <- tcLocalBinds binds $
 216                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 217
 218         ; return (GRHSs grhss' binds') }
 219
 220 -------------
 221 tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
 222
 223 tcGRHS ctxt res_ty (GRHS guards rhs)
 224   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 225                              mc_body ctxt rhs
 226         ; return (GRHS guards' rhs') }
 227   where
 228     stmt_ctxt  = PatGuard (mc_what ctxt)
 229 \end{code}
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 \begin{code}
 239 tcDoStmts :: HsStmtContext Name
 240           -> [LStmt Name]
 241           -> LHsExpr Name
 242           -> TcRhoType
 243           -> TcM (HsExpr TcId)          -- Returns a HsDo
 244 tcDoStmts ListComp stmts body res_ty
 245   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 246         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
 247                                      elt_ty $
 248                              tcBody body
 249         ; return $ mkHsWrapCo coi
 250                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 251
 252 tcDoStmts PArrComp stmts body res_ty
 253   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 254         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
 255                                      elt_ty $
 256                              tcBody body
 257         ; return $ mkHsWrapCo coi
 258                      (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 259
 260 tcDoStmts DoExpr stmts body res_ty
 261   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
 262                              tcBody body
 263         ; return (HsDo DoExpr stmts' body' res_ty) }
 264
 265 tcDoStmts MDoExpr stmts body res_ty
 266   = do  { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
 267                              tcBody body
 268         ; return (HsDo MDoExpr stmts' body' res_ty) }
 269
 270 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 271
 272 tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 273 tcBody body res_ty
 274   = do  { traceTc "tcBody" (ppr res_ty)
 275         ; body' <- tcMonoExpr body res_ty
 276         ; return body'
 277         }
 278 \end{code}
 279
 280
 281 %************************************************************************
 282 %*                                                                      *
 283 \subsection{tcStmts}
 284 %*                                                                      *
 285 %************************************************************************
 286
 287 \begin{code}
 288 type TcStmtChecker
 289   =  forall thing. HsStmtContext Name
 290                 -> Stmt Name
 291                 -> TcRhoType                    -- Result type for comprehension
 292                 -> (TcRhoType -> TcM thing)     -- Checker for what follows the stmt
 293                 -> TcM (Stmt TcId, thing)
 294
 295 tcStmts :: HsStmtContext Name
 296         -> TcStmtChecker        -- NB: higher-rank type
 297         -> [LStmt Name]
 298         -> TcRhoType
 299         -> (TcRhoType -> TcM thing)
 300         -> TcM ([LStmt TcId], thing)
 301
 302 -- Note the higher-rank type.  stmt_chk is applied at different
 303 -- types in the equations for tcStmts
 304
 305 tcStmts _ _ [] res_ty thing_inside
 306   = do  { thing <- thing_inside res_ty
 307         ; return ([], thing) }
 308
 309 -- LetStmts are handled uniformly, regardless of context
 310 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 311   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 312                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 313         ; return (L loc (LetStmt binds') : stmts', thing) }
 314
 315 -- For the vanilla case, handle the location-setting part
 316 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 317   = do  { (stmt', (stmts', thing)) <-
 318                 setSrcSpan loc                          $
 319                 addErrCtxt (pprStmtInCtxt ctxt stmt)    $
 320                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 321                 popErrCtxt                              $
 322                 tcStmts ctxt stmt_chk stmts res_ty'     $
 323                 thing_inside
 324         ; return (L loc stmt' : stmts', thing) }
 325
 326 --------------------------------
 327 --      Pattern guards
 328 tcGuardStmt :: TcStmtChecker
 329 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
 330   = do  { guard' <- tcMonoExpr guard boolTy
 331         ; thing  <- thing_inside res_ty
 332         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 333
 334 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 335   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
 336         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
 337                             thing_inside res_ty
 338         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 339
 340 tcGuardStmt _ stmt _ _
 341   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 342
 343
 344 --------------------------------
 345 --      List comprehensions and PArrays
 346
 347 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 348          -> TcStmtChecker
 349
 350 -- A generator, pat <- rhs
 351 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 352  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
 353         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
 354         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 355                             thing_inside res_ty
 356         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 357
 358 -- A boolean guard
 359 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
 360   = do  { rhs'  <- tcMonoExpr rhs boolTy
 361         ; thing <- thing_inside res_ty
 362         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 363
 364 -- A parallel set of comprehensions
 365 --      [ (g x, h x) | ... ; let g v = ...
 366 --                   | ... ; let h v = ... ]
 367 --
 368 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 369 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
 370 -- Similarly if we had an existential pattern match:
 371 --
 372 --      data T = forall a. Show a => C a
 373 --
 374 --      [ (show x, show y) | ... ; C x <- ...
 375 --                         | ... ; C y <- ... ]
 376 --
 377 -- Then we need the LIE from (show x, show y) to be simplified against
 378 -- the bindings for x and y.
 379 --
 380 -- It's difficult to do this in parallel, so we rely on the renamer to
 381 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 382 -- So the binders of the first parallel group will be in scope in the second
 383 -- group.  But that's fine; there's no shadowing to worry about.
 384
 385 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 386   = do  { (pairs', thing) <- loop bndr_stmts_s
 387         ; return (ParStmt pairs', thing) }
 388   where
 389     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 390     loop [] = do { thing <- thing_inside elt_ty
 391                  ; return ([], thing) }         -- matching in the branches
 392
 393     loop ((stmts, names) : pairs)
 394       = do { (stmts', (ids, pairs', thing))
 395                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 396                    do { ids <- tcLookupLocalIds names
 397                       ; (pairs', thing) <- loop pairs
 398                       ; return (ids, pairs', thing) }
 399            ; return ( (stmts', ids) : pairs', thing ) }
 400
 401 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
 402     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 403         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 404             let alphaListTy = mkTyConApp m_tc [alphaTy]
 405
 406             (usingExpr', maybeByExpr') <-
 407                 case maybeByExpr of
 408                     Nothing -> do
 409                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 410                         let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
 411                         usingExpr' <- tcPolyExpr usingExpr using_ty
 412                         return (usingExpr', Nothing)
 413                     Just byExpr -> do
 414                         -- We must infer a type such that e :: t and then check that
 415                         -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
 416                         (byExpr', tTy) <- tcInferRhoNC byExpr
 417                         let using_ty = mkForAllTy alphaTyVar $
 418                                        (alphaTy `mkFunTy` tTy)
 419                                        `mkFunTy` alphaListTy `mkFunTy` alphaListTy
 420                         usingExpr' <- tcPolyExpr usingExpr using_ty
 421                         return (usingExpr', Just byExpr')
 422
 423             binders' <- tcLookupLocalIds binders
 424             thing <- thing_inside elt_ty'
 425
 426             return (binders', usingExpr', maybeByExpr', thing)
 427
 428     return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
 429
 430 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
 431   = do { let (bndr_names, list_bndr_names) = unzip bindersMap
 432
 433        ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
 434             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 435                 (by', using_ty) <-
 436                    case by of
 437                      Nothing   -> -- check that using :: forall a. [a] -> [[a]]
 438                                   return (Nothing, mkForAllTy alphaTyVar $
 439                                                    alphaListTy `mkFunTy` alphaListListTy)
 440
 441                      Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
 442                                   -- where by :: t
 443                                   do { (by_e', t_ty) <- tcInferRhoNC by_e
 444                                      ; return (Just by_e', mkForAllTy alphaTyVar $
 445                                                            (alphaTy `mkFunTy` t_ty)
 446                                                            `mkFunTy` alphaListTy
 447                                                            `mkFunTy` alphaListListTy) }
 448                 -- Find the Ids (and hence types) of all old binders
 449                 bndr_ids <- tcLookupLocalIds bndr_names
 450
 451                 return (bndr_ids, by', using_ty, elt_ty')
 452
 453                 -- Ensure that every old binder of type b is linked up with
 454                 -- its new binder which should have type [b]
 455        ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
 456              bindersMap' = bndr_ids `zip` list_bndr_ids
 457              -- See Note [GroupStmt binder map] in HsExpr
 458
 459        ; using' <- case using of
 460                      Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
 461                      Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
 462
 463              -- Type check the thing in the environment with
 464              -- these new binders and return the result
 465        ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
 466        ; return (GroupStmt stmts' bindersMap' by' using', thing) }
 467   where
 468     alphaListTy = mkTyConApp m_tc [alphaTy]
 469     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 470
 471     mk_list_bndr :: Name -> TcId -> TcId
 472     mk_list_bndr list_bndr_name bndr_id
 473       = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
 474
 475 tcLcStmt _ _ stmt _ _
 476   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 477
 478 --------------------------------
 479 --      Do-notation
 480 -- The main excitement here is dealing with rebindable syntax
 481
 482 tcDoStmt :: TcStmtChecker
 483
 484 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 485   = do  {       -- Deal with rebindable syntax:
 486                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 487                 -- This level of generality is needed for using do-notation
 488                 -- in full generality; see Trac #1537
 489
 490                 -- I'd like to put this *after* the tcSyntaxOp
 491                 -- (see Note [Treat rebindable syntax first], but that breaks
 492                 -- the rigidity info for GADTs.  When we move to the new story
 493                 -- for GADTs, we can move this after tcSyntaxOp
 494           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 495         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
 496         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 497         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op
 498                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 499
 500                 -- If (but only if) the pattern can fail,
 501                 -- typecheck the 'fail' operator
 502         ; fail_op' <- if isIrrefutableHsPat pat
 503                       then return noSyntaxExpr
 504                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 505
 506         ; rhs' <- tcMonoExprNC rhs rhs_ty
 507         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
 508                            thing_inside new_res_ty
 509
 510         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 511
 512
 513 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
 514   = do  {       -- Deal with rebindable syntax;
 515                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 516                 -- See also Note [Treat rebindable syntax first]
 517           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 518         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 519         ; then_op' <- tcSyntaxOp DoOrigin then_op
 520                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 521
 522         ; rhs' <- tcMonoExprNC rhs rhs_ty
 523         ; thing <- thing_inside new_res_ty
 524         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 525
 526 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 527                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
 528                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
 529          res_ty thing_inside
 530   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
 531         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
 532         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
 533               tup_ty  = mkBoxedTupleTy tup_elt_tys
 534
 535         ; tcExtendIdEnv tup_ids $ do
 536         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
 537         ; (stmts', (ret_op', tup_rets))
 538                 <- tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
 539                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
 540                              -- Unify the types of the "final" Ids (which may
 541                              -- be polymorphic) with those of "knot-tied" Ids
 542                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
 543                       ; return (ret_op', tup_rets) }
 544
 545         ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
 546         ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
 547                                  (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
 548
 549         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 550         ; bind_op' <- tcSyntaxOp DoOrigin bind_op
 551                                  (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 552
 553         ; thing <- thing_inside new_res_ty
 554 --         ; lie_binds <- bindLocalMethods lie tup_ids
 555
 556         ; let rec_ids = takeList rec_names tup_ids
 557         ; later_ids <- tcLookupLocalIds later_names
 558         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
 559                                  ppr later_ids <+> ppr (map idType later_ids)]
 560         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 561                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
 562                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
 563                           , recS_rec_rets = tup_rets }, thing)
 564         }}
 565
 566 tcDoStmt _ stmt _ _
 567   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 568 \end{code}
 569
 570 Note [Treat rebindable syntax first]
 571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 572 When typechecking
 573         do { bar; ... } :: IO ()
 574 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 575 pushing info from the context into the RHS.  To do this, we check the
 576 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
 577 Otherwise the error shows up when cheking the rebindable syntax, and
 578 the expected/inferred stuff is back to front (see Trac #3613).
 579
 580 \begin{code}
 581 --------------------------------
 582 --      Mdo-notation
 583 -- The distinctive features here are
 584 --      (a) RecStmts, and
 585 --      (b) no rebindable syntax
 586
 587 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 588           -> TcStmtChecker
 589 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 590   = do  { (rhs', pat_ty) <- tc_rhs rhs
 591         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 592                             thing_inside res_ty
 593         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 594
 595 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
 596   = do  { (rhs', elt_ty) <- tc_rhs rhs
 597         ; thing          <- thing_inside res_ty
 598         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 599
 600 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
 601                                , recS_rec_ids = recNames }) res_ty thing_inside
 602   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 603         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 604         ; tcExtendIdEnv rec_ids                 $ do
 605         { (stmts', (later_ids, rec_rets))
 606                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
 607                         -- ToDo: res_ty not really right
 608                    do { rec_rets <- zipWithM tcCheckId recNames rec_tys
 609                       ; later_ids <- tcLookupLocalIds laterNames
 610                       ; return (later_ids, rec_rets) }
 611
 612         ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
 613                 -- NB:  The rec_ids for the recursive things
 614                 --      already scope over this part. This binding may shadow
 615                 --      some of them with polymorphic things with the same Name
 616                 --      (see note [RecStmt] in HsExpr)
 617
 618         ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
 619         }}
 620
 621 tcMDoStmt _ _ stmt _ _
 622   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 623 \end{code}
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628 \subsection{Errors and contexts}
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 633 number of args are used in each equation.
 634
 635 \begin{code}
 636 checkArgs :: Name -> MatchGroup Name -> TcM ()
 637 checkArgs fun (MatchGroup (match1:matches) _)
 638     | null bad_matches = return ()
 639     | otherwise
 640     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
 641                           ptext (sLit "have different numbers of arguments"),
 642                         nest 2 (ppr (getLoc match1)),
 643                         nest 2 (ppr (getLoc (head bad_matches)))])
 644   where
 645     n_args1 = args_in_match match1
 646     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 647
 648     args_in_match :: LMatch Name -> Int
 649     args_in_match (L _ (Match pats _ _)) = length pats
 650 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
 651 \end{code}
 652