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