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