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, tcStmtsAndThen, 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') <- tcStmtsAndThen 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           -> TcRhoType
 245           -> TcM (HsExpr TcId)          -- Returns a HsDo
 246 tcDoStmts ListComp stmts res_ty
 247   = do  { (coi, elt_ty) <- matchExpectedListTy res_ty
 248         ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
 249         ; return $ mkHsWrapCoI coi
 250                      (HsDo ListComp stmts' (mkListTy elt_ty)) }
 251
 252 tcDoStmts PArrComp stmts res_ty
 253   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
 254         ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
 255         ; return $ mkHsWrapCoI coi
 256                      (HsDo PArrComp stmts' (mkPArrTy elt_ty)) }
 257
 258 tcDoStmts DoExpr stmts res_ty
 259   = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
 260         ; return (HsDo DoExpr stmts' res_ty) }
 261
 262 tcDoStmts MDoExpr stmts res_ty
 263   = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
 264         ; return (HsDo MDoExpr stmts' res_ty) }
 265
 266 tcDoStmts MonadComp stmts res_ty
 267   = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
 268         ; return (HsDo MonadComp stmts' 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         -> TcM [LStmt TcId]
 300 tcStmts ctxt stmt_chk stmts res_ty
 301   = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
 302                         const (return ())
 303        ; return stmts' }
 304
 305 tcStmtsAndThen :: 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 tcStmtsAndThen _ _ [] res_ty thing_inside
 316   = do  { thing <- thing_inside res_ty
 317         ; return ([], thing) }
 318
 319 -- LetStmts are handled uniformly, regardless of context
 320 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 321   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 322                                       tcStmtsAndThen 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 tcStmtsAndThen 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                 tcStmtsAndThen 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 tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
 361   = do { body' <- tcMonoExprNC body elt_ty
 362        ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
 363        ; return (LastStmt body' noSyntaxExpr, thing) }
 364
 365 -- A generator, pat <- rhs
 366 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
 367  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
 368         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
 369         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 370                             thing_inside elt_ty
 371         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 372
 373 -- A boolean guard
 374 tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
 375   = do  { rhs'  <- tcMonoExpr rhs boolTy
 376         ; thing <- thing_inside elt_ty
 377         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 378
 379 -- A parallel set of comprehensions
 380 --      [ (g x, h x) | ... ; let g v = ...
 381 --                   | ... ; let h v = ... ]
 382 --
 383 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 384 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
 385 -- Similarly if we had an existential pattern match:
 386 --
 387 --      data T = forall a. Show a => C a
 388 --
 389 --      [ (show x, show y) | ... ; C x <- ...
 390 --                         | ... ; C y <- ... ]
 391 --
 392 -- Then we need the LIE from (show x, show y) to be simplified against
 393 -- the bindings for x and y.
 394 --
 395 -- It's difficult to do this in parallel, so we rely on the renamer to
 396 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 397 -- So the binders of the first parallel group will be in scope in the second
 398 -- group.  But that's fine; there's no shadowing to worry about.
 399
 400 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
 401   = do  { (pairs', thing) <- loop bndr_stmts_s
 402         ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
 403   where
 404     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 405     loop [] = do { thing <- thing_inside elt_ty
 406                  ; return ([], thing) }         -- matching in the branches
 407
 408     loop ((stmts, names) : pairs)
 409       = do { (stmts', (ids, pairs', thing))
 410                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 411                    do { ids <- tcLookupLocalIds names
 412                       ; (pairs', thing) <- loop pairs
 413                       ; return (ids, pairs', thing) }
 414            ; return ( (stmts', ids) : pairs', thing ) }
 415
 416 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_ty thing_inside = do
 417     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 418         tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 419             let alphaListTy = mkTyConApp m_tc [alphaTy]
 420
 421             (usingExpr', maybeByExpr') <-
 422                 case maybeByExpr of
 423                     Nothing -> do
 424                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 425                         let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
 426                         usingExpr' <- tcPolyExpr usingExpr using_ty
 427                         return (usingExpr', Nothing)
 428                     Just byExpr -> do
 429                         -- We must infer a type such that e :: t and then check that
 430                         -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
 431                         (byExpr', tTy) <- tcInferRhoNC byExpr
 432                         let using_ty = mkForAllTy alphaTyVar $
 433                                        (alphaTy `mkFunTy` tTy)
 434                                        `mkFunTy` alphaListTy `mkFunTy` alphaListTy
 435                         usingExpr' <- tcPolyExpr usingExpr using_ty
 436                         return (usingExpr', Just byExpr')
 437
 438             binders' <- tcLookupLocalIds binders
 439             thing <- thing_inside elt_ty'
 440
 441             return (binders', usingExpr', maybeByExpr', thing)
 442
 443     return (TransformStmt stmts' binders' usingExpr' maybeByExpr' noSyntaxExpr noSyntaxExpr, thing)
 444
 445 tcLcStmt m_tc ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs =  bindersMap
 446                               , grpS_by = by, grpS_using = using
 447                               , grpS_explicit = explicit }) elt_ty thing_inside
 448   = do { let (bndr_names, list_bndr_names) = unzip bindersMap
 449
 450        ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
 451             tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 452                 (by', using_ty) <-
 453                    case by of
 454                      Nothing   -> -- check that using :: forall a. [a] -> [[a]]
 455                                   return (Nothing, mkForAllTy alphaTyVar $
 456                                                    alphaListTy `mkFunTy` alphaListListTy)
 457
 458                      Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
 459                                   -- where by :: t
 460                                   do { (by_e', t_ty) <- tcInferRhoNC by_e
 461                                      ; return (Just by_e', mkForAllTy alphaTyVar $
 462                                                            (alphaTy `mkFunTy` t_ty)
 463                                                            `mkFunTy` alphaListTy
 464                                                            `mkFunTy` alphaListListTy) }
 465                 -- Find the Ids (and hence types) of all old binders
 466                 bndr_ids <- tcLookupLocalIds bndr_names
 467
 468                 return (bndr_ids, by', using_ty, elt_ty')
 469
 470                 -- Ensure that every old binder of type b is linked up with
 471                 -- its new binder which should have type [b]
 472        ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
 473              bindersMap' = bndr_ids `zip` list_bndr_ids
 474              -- See Note [GroupStmt binder map] in HsExpr
 475
 476        ; using' <- tcPolyExpr using using_ty
 477
 478              -- Type check the thing in the environment with
 479              -- these new binders and return the result
 480        ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
 481        ; return (emptyGroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
 482                                 , grpS_by = by', grpS_using = using'
 483                                 , grpS_explicit = explicit }, thing) }
 484   where
 485     alphaListTy = mkTyConApp m_tc [alphaTy]
 486     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 487
 488     mk_list_bndr :: Name -> TcId -> TcId
 489     mk_list_bndr list_bndr_name bndr_id
 490       = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
 491
 492 tcLcStmt _ _ stmt _ _
 493   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 494
 495
 496 --------------------------------
 497 --      Monad comprehensions
 498
 499 tcMcStmt :: TcStmtChecker
 500
 501 tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
 502   = do  { a_ty       <- newFlexiTyVarTy liftedTypeKind
 503         ; return_op' <- tcSyntaxOp MCompOrigin return_op
 504                                    (a_ty `mkFunTy` res_ty)
 505         ; body'      <- tcMonoExprNC body a_ty
 506         ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
 507         ; return (LastStmt body' return_op', thing) }
 508
 509 -- Generators for monad comprehensions ( pat <- rhs )
 510 --
 511 --   [ body | q <- gen ]  ->  gen :: m a
 512 --                            q   ::   a
 513 --
 514
 515 tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 516  = do   { rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 517         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
 518         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 519
 520            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 521         ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op
 522                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 523
 524            -- If (but only if) the pattern can fail, typecheck the 'fail' operator
 525         ; fail_op' <- if isIrrefutableHsPat pat
 526                       then return noSyntaxExpr
 527                       else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
 528
 529         ; rhs' <- tcMonoExprNC rhs rhs_ty
 530         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
 531                            thing_inside new_res_ty
 532
 533         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 534
 535 -- Boolean expressions.
 536 --
 537 --   [ body | stmts, expr ]  ->  expr :: m Bool
 538 --
 539 tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
 540   = do  { -- Deal with rebindable syntax:
 541           --    guard_op :: test_ty -> rhs_ty
 542           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
 543           -- Where test_ty is, for example, Bool
 544           test_ty    <- newFlexiTyVarTy liftedTypeKind
 545         ; rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 546         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 547         ; rhs'       <- tcMonoExpr rhs test_ty
 548         ; guard_op'  <- tcSyntaxOp MCompOrigin guard_op
 549                                    (mkFunTy test_ty rhs_ty)
 550         ; then_op'   <- tcSyntaxOp MCompOrigin then_op
 551                                    (mkFunTys [rhs_ty, new_res_ty] res_ty)
 552         ; thing      <- thing_inside new_res_ty
 553         ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
 554
 555 -- Transform statements.
 556 --
 557 --   [ body | stmts, then f ]       ->  f :: forall a. m a -> m a
 558 --   [ body | stmts, then f by e ]  ->  f :: forall a. (a -> t) -> m a -> m a
 559 --
 560 tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) res_ty thing_inside
 561   = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
 562        ; m1_ty      <- newFlexiTyVarTy star_star_kind
 563        ; m2_ty      <- newFlexiTyVarTy star_star_kind
 564        ; n_ty       <- newFlexiTyVarTy star_star_kind
 565        ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
 566        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 567        ; let m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
 568
 569              -- 'stmts' returns a result of type (m1_ty tuple_ty),
 570              -- typically something like [(Int,Bool,Int)]
 571              -- We don't know what tuple_ty is yet, so we use a variable
 572         ; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <-
 573               tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
 574                   { (usingExpr', maybeByExpr') <-
 575                         case maybeByExpr of
 576                             Nothing -> do
 577                                 -- We must validate that usingExpr :: forall a. m a -> m a
 578                                 let using_ty = mkForAllTy alphaTyVar $
 579                                                (m_ty `mkAppTy` alphaTy)
 580                                                `mkFunTy`
 581                                                (m_ty `mkAppTy` alphaTy)
 582                                 usingExpr' <- tcPolyExpr usingExpr using_ty
 583                                 return (usingExpr', Nothing)
 584                             Just byExpr -> do
 585                                 -- We must infer a type such that e :: t and then check that
 586                                 -- usingExpr :: forall a. (a -> t) -> m a -> m a
 587                                 (byExpr', tTy) <- tcInferRhoNC byExpr
 588                                 let using_ty = mkForAllTy alphaTyVar $
 589                                                (alphaTy `mkFunTy` tTy)
 590                                                `mkFunTy`
 591                                                (m_ty `mkAppTy` alphaTy)
 592                                                `mkFunTy`
 593                                                (m_ty `mkAppTy` alphaTy)
 594                                 usingExpr' <- tcPolyExpr usingExpr using_ty
 595                                 return (usingExpr', Just byExpr')
 596
 597                   ; bndr_ids <- tcLookupLocalIds binders
 598
 599                   -- `return` and `>>=` are used to pass around/modify our
 600                   -- binders, so we know their types:
 601                   --
 602                   --   return :: (a,b,c,..) -> m (a,b,c,..)
 603                   --   (>>=)  :: m (a,b,c,..)
 604                   --          -> ( (a,b,c,..) -> m (a,b,c,..) )
 605                   --          -> m (a,b,c,..)
 606                   --
 607                   ; let bndr_ty   = mkBigCoreVarTupTy bndr_ids
 608                         m_bndr_ty = m_ty `mkAppTy` bndr_ty
 609
 610                   ; return_op' <- tcSyntaxOp MCompOrigin return_op
 611                                       (bndr_ty `mkFunTy` m_bndr_ty)
 612
 613                   ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op $
 614                                       m_bndr_ty `mkFunTy` (bndr_ty `mkFunTy` res_ty)
 615                                                 `mkFunTy` res_ty
 616
 617                   -- Unify types of the inner comprehension and the binders type
 618                   ; _ <- unifyType res_ty' m_bndr_ty
 619
 620                   -- Typecheck the `thing` with out old type (which is the type
 621                   -- of the final result of our comprehension)
 622                   ; thing <- thing_inside res_ty
 623
 624                   ; return (bndr_ids, usingExpr', maybeByExpr', return_op', bind_op', thing) }
 625
 626         ; return (TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op', thing) }
 627
 628 -- Grouping statements
 629 --
 630 --   [ body | stmts, then group by e ]
 631 --     ->  e :: t
 632 --   [ body | stmts, then group by e using f ]
 633 --     ->  e :: t
 634 --         f :: forall a. (a -> t) -> m a -> m (m a)
 635 --   [ body | stmts, then group using f ]
 636 --     ->  f :: forall a. m a -> m (m a)
 637 --
 638 tcMcStmt ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap
 639                          , grpS_by = by, grpS_using = using, grpS_explicit = explicit
 640                          , grpS_ret = return_op, grpS_bind = bind_op
 641                          , grpS_fmap = fmap_op }) res_ty thing_inside
 642   = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
 643        ; m1_ty      <- newFlexiTyVarTy star_star_kind
 644        ; m2_ty      <- newFlexiTyVarTy star_star_kind
 645        ; n_ty       <- newFlexiTyVarTy star_star_kind
 646        ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind
 647        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 648        ; let (bndr_names, n_bndr_names) = unzip bindersMap
 649              m1_tup_ty = m1_ty `mkAppTy` tup_ty_var
 650
 651              -- 'stmts' returns a result of type (m1_ty tuple_ty),
 652              -- typically something like [(Int,Bool,Int)]
 653              -- We don't know what tuple_ty is yet, so we use a variable
 654        ; (stmts', (bndr_ids, by_e_ty, return_op')) <-
 655             tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do
 656                 { by_e_ty <- case by of
 657                                Nothing -> return Nothing
 658                                Just e  -> do { e_ty <- tcInferRhoNC e; return (Just e_ty) }
 659
 660                 -- Find the Ids (and hence types) of all old binders
 661                 ; bndr_ids <- tcLookupLocalIds bndr_names
 662
 663                 -- 'return' is only used for the binders, so we know its type.
 664                 --
 665                 --   return :: (a,b,c,..) -> m (a,b,c,..)
 666                 ; return_op' <- tcSyntaxOp MCompOrigin return_op $
 667                                 (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
 668
 669                 ; return (bndr_ids, by_e_ty, return_op') }
 670
 671
 672
 673        ; let tup_ty       = mkBigCoreVarTupTy bndr_ids  -- (a,b,c)
 674              using_arg_ty = m1_ty `mkAppTy` tup_ty      -- m1 (a,b,c)
 675              n_tup_ty     = n_ty  `mkAppTy` tup_ty      -- n (a,b,c)
 676              using_res_ty = m2_ty `mkAppTy` n_tup_ty    -- m2 (n (a,b,c))
 677              using_fun_ty = using_arg_ty `mkFunTy` using_arg_ty
 678
 679           -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
 680           -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
 681
 682        --------------- Typecheck the 'bind' function -------------
 683        ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
 684                                 using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty)
 685                                              `mkFunTy` res_ty
 686
 687        --------------- Typecheck the 'using' function -------------
 688        ; let poly_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy`
 689                                      (m2_ty `mkAppTy` (n_ty `mkAppTy` alphaTy))
 690              using_poly_ty = case by_e_ty of
 691                Nothing       -> mkForAllTy alphaTyVar poly_fun_ty
 692                                 -- using :: forall a. m1 a -> m2 (n a)
 693
 694                Just (_,t_ty) -> mkForAllTy alphaTyVar $
 695                                 (alphaTy `mkFunTy` t_ty) `mkFunTy` poly_fun_ty
 696                                 -- using :: forall a. (a->t) -> m1 a -> m2 (n a)
 697                                 -- where by :: t
 698
 699        ; using' <- tcPolyExpr using using_poly_ty
 700        ; coi <- unifyType (applyTy using_poly_ty tup_ty)
 701                           (case by_e_ty of
 702                              Nothing       -> using_fun_ty
 703                              Just (_,t_ty) -> (tup_ty `mkFunTy` t_ty) `mkFunTy` using_fun_ty)
 704        ; let final_using = fmap (mkHsWrapCoI coi . HsWrap (WpTyApp tup_ty)) using'
 705
 706        --------------- Typecheck the 'fmap' function -------------
 707        ; fmap_op' <- fmap unLoc . tcPolyExpr (noLoc fmap_op) $
 708                          mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
 709                          (alphaTy `mkFunTy` betaTy)
 710                          `mkFunTy` (n_ty `mkAppTy` alphaTy)
 711                          `mkFunTy` (n_ty `mkAppTy` betaTy)
 712
 713        ; let mk_n_bndr :: Name -> TcId -> TcId
 714              mk_n_bndr n_bndr_name bndr_id
 715                 = mkLocalId n_bndr_name (n_ty `mkAppTy` idType bndr_id)
 716
 717              -- Ensure that every old binder of type `b` is linked up with its
 718              -- new binder which should have type `n b`
 719              -- See Note [GroupStmt binder map] in HsExpr
 720              n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
 721              bindersMap' = bndr_ids `zip` n_bndr_ids
 722
 723        -- Type check the thing in the environment with these new binders and
 724        -- return the result
 725        ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty)
 726
 727        ; return (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap'
 728                            , grpS_by = fmap fst by_e_ty, grpS_using = final_using
 729                            , grpS_ret = return_op', grpS_bind = bind_op'
 730                            , grpS_fmap = fmap_op', grpS_explicit = explicit }, thing) }
 731
 732 -- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking
 733 -- of `ParStmt`s.
 734 --
 735 -- Note: The `mzip` function will get typechecked via:
 736 --
 737 --   ParStmt [st1::t1, st2::t2, st3::t3]
 738 --
 739 --   mzip :: m st1
 740 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
 741 --        -> m (st1, (st2, st3))
 742 --
 743 tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
 744   = do  { (_,(m_ty,_)) <- matchExpectedAppTy res_ty
 745         -- ToDo: what if the coercion isn't the identity?
 746
 747         ; (pairs', thing) <- loop m_ty bndr_stmts_s
 748
 749         ; let mzip_ty  = mkForAllTys [alphaTyVar, betaTyVar] $
 750                          (m_ty `mkAppTy` alphaTy)
 751                          `mkFunTy`
 752                          (m_ty `mkAppTy` betaTy)
 753                          `mkFunTy`
 754                          (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
 755         ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
 756
 757         -- Typecheck bind:
 758         ; let tys      = map (mkBigCoreVarTupTy . snd) pairs'
 759               tuple_ty = mk_tuple_ty tys
 760
 761         ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
 762                          (m_ty `mkAppTy` tuple_ty)
 763                          `mkFunTy`
 764                          (tuple_ty `mkFunTy` res_ty)
 765                          `mkFunTy`
 766                          res_ty
 767
 768         ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
 769                             mkForAllTy alphaTyVar $
 770                             alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
 771
 772         ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
 773
 774  where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
 775
 776        -- loop :: Type                                  -- m_ty
 777        --      -> [([LStmt Name], [Name])]
 778        --      -> TcM ([([LStmt TcId], [TcId])], thing)
 779        loop _ [] = do { thing <- thing_inside res_ty
 780                       ; return ([], thing) }           -- matching in the branches
 781
 782        loop m_ty ((stmts, names) : pairs)
 783          = do { -- type dummy since we don't know all binder types yet
 784                 ty_dummy <- newFlexiTyVarTy liftedTypeKind
 785               ; (stmts', (ids, pairs', thing))
 786                    <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
 787                       do { ids <- tcLookupLocalIds names
 788                          ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids)
 789                          ; (pairs', thing) <- loop m_ty pairs
 790                          ; return (ids, pairs', thing) }
 791               ; return ( (stmts', ids) : pairs', thing ) }
 792
 793 tcMcStmt _ stmt _ _
 794   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
 795
 796 --------------------------------
 797 --      Do-notation
 798 -- The main excitement here is dealing with rebindable syntax
 799
 800 tcDoStmt :: TcStmtChecker
 801
 802 tcDoStmt _ (LastStmt body _) res_ty thing_inside
 803   = do { body' <- tcMonoExprNC body res_ty
 804        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
 805        ; return (LastStmt body' noSyntaxExpr, thing) }
 806
 807 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 808   = do  {       -- Deal with rebindable syntax:
 809                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 810                 -- This level of generality is needed for using do-notation
 811                 -- in full generality; see Trac #1537
 812
 813                 -- I'd like to put this *after* the tcSyntaxOp
 814                 -- (see Note [Treat rebindable syntax first], but that breaks
 815                 -- the rigidity info for GADTs.  When we move to the new story
 816                 -- for GADTs, we can move this after tcSyntaxOp
 817           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 818         ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
 819         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 820         ; bind_op'   <- tcSyntaxOp DoOrigin bind_op
 821                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 822
 823                 -- If (but only if) the pattern can fail,
 824                 -- typecheck the 'fail' operator
 825         ; fail_op' <- if isIrrefutableHsPat pat
 826                       then return noSyntaxExpr
 827                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 828
 829         ; rhs' <- tcMonoExprNC rhs rhs_ty
 830         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
 831                            thing_inside new_res_ty
 832
 833         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 834
 835
 836 tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
 837   = do  {       -- Deal with rebindable syntax;
 838                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 839                 -- See also Note [Treat rebindable syntax first]
 840           rhs_ty     <- newFlexiTyVarTy liftedTypeKind
 841         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 842         ; then_op' <- tcSyntaxOp DoOrigin then_op
 843                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 844
 845         ; rhs' <- tcMonoExprNC rhs rhs_ty
 846         ; thing <- thing_inside new_res_ty
 847         ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
 848
 849 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 850                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
 851                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
 852          res_ty thing_inside
 853   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
 854         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
 855         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
 856               tup_ty  = mkBoxedTupleTy tup_elt_tys
 857
 858         ; tcExtendIdEnv tup_ids $ do
 859         { stmts_ty <- newFlexiTyVarTy liftedTypeKind
 860         ; (stmts', (ret_op', tup_rets))
 861                 <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
 862                    do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
 863                              -- Unify the types of the "final" Ids (which may
 864                              -- be polymorphic) with those of "knot-tied" Ids
 865                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
 866                       ; return (ret_op', tup_rets) }
 867
 868         ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
 869         ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
 870                                  (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
 871
 872         ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
 873         ; bind_op' <- tcSyntaxOp DoOrigin bind_op
 874                                  (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 875
 876         ; thing <- thing_inside new_res_ty
 877 --         ; lie_binds <- bindLocalMethods lie tup_ids
 878
 879         ; let rec_ids = takeList rec_names tup_ids
 880         ; later_ids <- tcLookupLocalIds later_names
 881         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
 882                                  ppr later_ids <+> ppr (map idType later_ids)]
 883         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 884                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
 885                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
 886                           , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
 887         }}
 888
 889 tcDoStmt _ stmt _ _
 890   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 891 \end{code}
 892
 893 Note [Treat rebindable syntax first]
 894 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 895 When typechecking
 896         do { bar; ... } :: IO ()
 897 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 898 pushing info from the context into the RHS.  To do this, we check the
 899 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
 900 Otherwise the error shows up when cheking the rebindable syntax, and
 901 the expected/inferred stuff is back to front (see Trac #3613).
 902
 903 \begin{code}
 904 --------------------------------
 905 --      Mdo-notation
 906 -- The distinctive features here are
 907 --      (a) RecStmts, and
 908 --      (b) no rebindable syntax
 909
 910 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 911           -> TcStmtChecker
 912 -- Used only by TcArrows... should be gotten rid of
 913 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 914   = do  { (rhs', pat_ty) <- tc_rhs rhs
 915         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
 916                             thing_inside res_ty
 917         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 918
 919 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside
 920   = do  { (rhs', elt_ty) <- tc_rhs rhs
 921         ; thing          <- thing_inside res_ty
 922         ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
 923
 924 tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
 925                                , recS_rec_ids = recNames }) res_ty thing_inside
 926   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 927         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 928         ; tcExtendIdEnv rec_ids $ do
 929         { (stmts', (later_ids, rec_rets))
 930                 <- tcStmtsAndThen ctxt (tcMDoStmt tc_rhs) stmts res_ty  $ \ _res_ty' ->
 931                         -- ToDo: res_ty not really right
 932                    do { rec_rets <- zipWithM tcCheckId recNames rec_tys
 933                       ; later_ids <- tcLookupLocalIds laterNames
 934                       ; return (later_ids, rec_rets) }
 935
 936         ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
 937                 -- NB:  The rec_ids for the recursive things
 938                 --      already scope over this part. This binding may shadow
 939                 --      some of them with polymorphic things with the same Name
 940                 --      (see note [RecStmt] in HsExpr)
 941
 942         ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 943                                , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
 944                                , recS_ret_ty = res_ty }, thing)
 945         }}
 946
 947 tcMDoStmt _ _ stmt _ _
 948   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 949 \end{code}
 950
 951
 952 %************************************************************************
 953 %*                                                                      *
 954 \subsection{Errors and contexts}
 955 %*                                                                      *
 956 %************************************************************************
 957
 958 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 959 number of args are used in each equation.
 960
 961 \begin{code}
 962 checkArgs :: Name -> MatchGroup Name -> TcM ()
 963 checkArgs fun (MatchGroup (match1:matches) _)
 964     | null bad_matches = return ()
 965     | otherwise
 966     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
 967                           ptext (sLit "have different numbers of arguments"),
 968                         nest 2 (ppr (getLoc match1)),
 969                         nest 2 (ppr (getLoc (head bad_matches)))])
 970   where
 971     n_args1 = args_in_match match1
 972     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 973
 974     args_in_match :: LMatch Name -> Int
 975     args_in_match (L _ (Match pats _ _)) = length pats
 976 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
 977 \end{code}
 978