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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
  17                    matchCtxt, TcMatchCtxt(..),
  18                    tcStmts, tcDoStmts, tcBody,
  19                    tcDoStmt, tcMDoStmt, tcGuardStmt
  20        ) where
  21
  22 #include "HsVersions.h"
  23
  24 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
  25
  26 import HsSyn
  27 import TcRnMonad
  28 import TcGadt
  29 import Inst
  30 import TcEnv
  31 import TcPat
  32 import TcMType
  33 import TcType
  34 import TcBinds
  35 import TcUnify
  36 import TcSimplify
  37 import Name
  38 import TysWiredIn
  39 import PrelNames
  40 import Id
  41 import TyCon
  42 import TysPrim
  43 import Outputable
  44 import Util
  45 import SrcLoc
  46
  47 import Control.Monad
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{tcMatchesFun, tcMatchesCase}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  57 @FunMonoBind@.  The second argument is the name of the function, which
  58 is used in error messages.  It checks that all the equations have the
  59 same number of arguments before using @tcMatches@ to do the work.
  60
  61 \begin{code}
  62 tcMatchesFun :: Name -> Bool
  63              -> MatchGroup Name
  64              -> BoxyRhoType             -- Expected type of function
  65              -> TcM (HsWrapper, MatchGroup TcId)        -- Returns type of body
  66
  67 tcMatchesFun fun_name inf matches exp_ty
  68   = do  {  -- Check that they all have the same no of arguments
  69            -- Location is in the monad, set the caller so that
  70            -- any inter-equation error messages get some vaguely
  71            -- sensible location.        Note: we have to do this odd
  72            -- ann-grabbing, because we don't always have annotations in
  73            -- hand when we call tcMatchesFun...
  74           checkArgs fun_name matches
  75
  76         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  77         -- because inconsistency between branches
  78         -- may show up as something wrong with the (non-existent) type signature
  79
  80                 -- This is one of two places places we call subFunTys
  81                 -- The point is that if expected_y is a "hole", we want
  82                 -- to make pat_tys and rhs_ty as "holes" too.
  83         ; subFunTys doc n_pats exp_ty     $ \ pat_tys rhs_ty ->
  84           tcMatches match_ctxt pat_tys rhs_ty matches
  85         }
  86   where
  87     doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
  88           <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
  89     n_pats = matchGroupArity matches
  90     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
  91 \end{code}
  92
  93 @tcMatchesCase@ doesn't do the argument-count check because the
  94 parser guarantees that each equation has exactly one argument.
  95
  96 \begin{code}
  97 tcMatchesCase :: TcMatchCtxt            -- Case context
  98               -> TcRhoType              -- Type of scrutinee
  99               -> MatchGroup Name        -- The case alternatives
 100               -> BoxyRhoType            -- Type of whole case expressions
 101               -> TcM (MatchGroup TcId)  -- Translated alternatives
 102
 103 tcMatchesCase ctxt scrut_ty matches res_ty
 104   = tcMatches ctxt [scrut_ty] res_ty matches
 105
 106 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
 107 tcMatchLambda match res_ty
 108   = subFunTys doc n_pats res_ty         $ \ pat_tys rhs_ty ->
 109     tcMatches match_ctxt pat_tys rhs_ty match
 110   where
 111     n_pats = matchGroupArity match
 112     doc = sep [ ptext SLIT("The lambda expression")
 113                  <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match),
 114                         -- The pprSetDepth makes the abstraction print briefly
 115                 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
 116     match_ctxt = MC { mc_what = LambdaExpr,
 117                       mc_body = tcBody }
 118 \end{code}
 119
 120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 121
 122 \begin{code}
 123 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
 124 -- Used for pattern bindings
 125 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 126   where
 127     match_ctxt = MC { mc_what = PatBindRhs,
 128                       mc_body = tcBody }
 129 \end{code}
 130
 131
 132 %************************************************************************
 133 %*                                                                      *
 134 \subsection{tcMatch}
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 \begin{code}
 139 tcMatches :: TcMatchCtxt
 140           -> [BoxySigmaType]            -- Expected pattern types
 141           -> BoxyRhoType                -- Expected result-type of the Match.
 142           -> MatchGroup Name
 143           -> TcM (MatchGroup TcId)
 144
 145 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 146   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 147          mc_body :: LHsExpr Name                -- Type checker for a body of
 148                                                 -- an alternative
 149                  -> BoxyRhoType
 150                  -> TcM (LHsExpr TcId) }
 151
 152 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 153   = do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 154         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 155
 156 -------------
 157 tcMatch :: TcMatchCtxt
 158         -> [BoxySigmaType]      -- Expected pattern types
 159         -> BoxyRhoType          -- Expected result-type of the Match.
 160         -> LMatch Name
 161         -> TcM (LMatch TcId)
 162
 163 tcMatch ctxt pat_tys rhs_ty match
 164   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 165   where
 166     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 167       = add_match_ctxt match $
 168         do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
 169                                 tc_grhss ctxt maybe_rhs_sig grhss
 170            ; return (Match pats' Nothing grhss') }
 171
 172     tc_grhss ctxt Nothing grhss rhs_ty
 173       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 174
 175         -- Result type sigs are no longer supported
 176     tc_grhss ctxt (Just res_sig) grhss rhs_ty
 177       = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
 178                         <+> ppr res_sig)
 179            ; tcGRHSs ctxt grhss rhs_ty }
 180
 181         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 182         -- so we don't want to add "In the lambda abstraction \x->e"
 183     add_match_ctxt match thing_inside
 184         = case mc_what ctxt of
 185             LambdaExpr -> thing_inside
 186             m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
 187
 188 -------------
 189 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
 190         -> TcM (GRHSs TcId)
 191
 192 -- Notice that we pass in the full res_ty, so that we get
 193 -- good inference from simple things like
 194 --      f = \(x::forall a.a->a) -> <stuff>
 195 -- We used to force it to be a monotype when there was more than one guard
 196 -- but we don't need to do that any more
 197
 198 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 199   = do  { (binds', grhss') <- tcLocalBinds binds $
 200                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 201
 202         ; return (GRHSs grhss' binds') }
 203
 204 -------------
 205 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
 206
 207 tcGRHS ctxt res_ty (GRHS guards rhs)
 208   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 209                              mc_body ctxt rhs
 210         ; return (GRHS guards' rhs') }
 211   where
 212     stmt_ctxt  = PatGuard (mc_what ctxt)
 213 \end{code}
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 tcDoStmts :: HsStmtContext Name
 224           -> [LStmt Name]
 225           -> LHsExpr Name
 226           -> BoxyRhoType
 227           -> TcM (HsExpr TcId)          -- Returns a HsDo
 228 tcDoStmts ListComp stmts body res_ty
 229   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 230         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
 231                                      elt_ty $
 232                              tcBody body
 233         ; return $ mkHsWrapCoI coi
 234                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 235
 236 tcDoStmts PArrComp stmts body res_ty
 237   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 238         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
 239                                      elt_ty $
 240                              tcBody body
 241         ; return $ mkHsWrapCoI coi
 242                      (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 243
 244 tcDoStmts DoExpr stmts body res_ty
 245   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
 246                                      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 stmts body res_ty = 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' <- tcPolyExpr 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 ctxt stmt_chk [] 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 (stmtCtxt 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 ctxt (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) <- tcInferRho rhs
 332         ; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
 333         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 334
 335 tcGuardStmt ctxt stmt res_ty thing_inside
 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)  <- tcLamPat pat pat_ty res_ty thing_inside
 350         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 351
 352 -- A boolean guard
 353 tcLcStmt m_tc ctxt (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) <- tcInferRho 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) groupByClause) elt_ty thing_inside = do
 420         (stmts', (bindersMap', groupByClause', thing)) <-
 421             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 422                 let alphaListTy = mkTyConApp m_tc [alphaTy]
 423                     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 424
 425                 groupByClause' <-
 426                     case groupByClause of
 427                         GroupByNothing usingExpr ->
 428                             -- We must validate that usingExpr :: forall a. [a] -> [[a]]
 429                             tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
 430                         GroupBySomething eitherUsingExpr byExpr -> do
 431                             -- We must infer a type such that byExpr :: t
 432                             (byExpr', tTy) <- tcInferRho byExpr
 433
 434                             -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
 435                             let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
 436                             eitherUsingExpr' <-
 437                                 case eitherUsingExpr of
 438                                     Left usingExpr  -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
 439                                     Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
 440                             return $ GroupBySomething eitherUsingExpr' byExpr'
 441
 442                 -- Find the IDs and types of all old binders
 443                 let (oldBinders, newBinders) = unzip bindersMap
 444                 oldBinders' <- tcLookupLocalIds oldBinders
 445
 446                 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
 447                 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
 448
 449                 -- Type check the thing in the environment with these new binders and return the result
 450                 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
 451                 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
 452
 453         return (GroupStmt (stmts', bindersMap') groupByClause', thing)
 454     where
 455         associateNewBinder :: TcId -> Name -> TcId
 456         associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
 457
 458 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
 459   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 460
 461 --------------------------------
 462 --      Do-notation
 463 -- The main excitement here is dealing with rebindable syntax
 464
 465 tcDoStmt :: TcStmtChecker
 466
 467 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 468   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 469                 -- We should use type *inference* for the RHS computations,
 470                 -- becuase of GADTs.
 471                 --      do { pat <- rhs; <rest> }
 472                 -- is rather like
 473                 --      case rhs of { pat -> <rest> }
 474                 -- We do inference on rhs, so that information about its type
 475                 -- can be refined when type-checking the pattern.
 476
 477         -- Deal with rebindable syntax:
 478         --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 479         -- This level of generality is needed for using do-notation
 480         -- in full generality; see Trac #1537
 481         ; ((bind_op', new_res_ty), pat_ty) <-
 482              withBox liftedTypeKind $ \ pat_ty ->
 483              withBox liftedTypeKind $ \ new_res_ty ->
 484              tcSyntaxOp DoOrigin bind_op
 485                         (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 486
 487                 -- If (but only if) the pattern can fail,
 488                 -- typecheck the 'fail' operator
 489         ; fail_op' <- if isIrrefutableHsPat pat
 490                       then return noSyntaxExpr
 491                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 492
 493         ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
 494
 495         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 496
 497
 498 tcDoStmt ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 499   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 500
 501         -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
 502         ; (then_op', new_res_ty) <-
 503                 withBox liftedTypeKind $ \ new_res_ty ->
 504                 tcSyntaxOp DoOrigin then_op
 505                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 506
 507         ; thing <- thing_inside new_res_ty
 508         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 509
 510 tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
 511   = failWithTc (ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
 512         -- This case can't be caught in the renamer
 513         -- see RnExpr.checkRecStmt
 514
 515 tcDoStmt ctxt stmt res_ty thing_inside
 516   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 517
 518 --------------------------------
 519 --      Mdo-notation
 520 -- The distinctive features here are
 521 --      (a) RecStmts, and
 522 --      (b) no rebindable syntax
 523
 524 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 525           -> TcStmtChecker
 526 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 527   = do  { (rhs', pat_ty) <- tc_rhs rhs
 528         ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 529         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 530
 531 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
 532   = do  { (rhs', elt_ty) <- tc_rhs rhs
 533         ; thing          <- thing_inside res_ty
 534         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 535
 536 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
 537   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 538         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 539         ; tcExtendIdEnv rec_ids                 $ do
 540         { (stmts', (later_ids, rec_rets))
 541                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
 542                         -- ToDo: res_ty not really right
 543                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 544                       ; later_ids <- tcLookupLocalIds laterNames
 545                       ; return (later_ids, rec_rets) }
 546
 547         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
 548                 -- NB:  The rec_ids for the recursive things
 549                 --      already scope over this part. This binding may shadow
 550                 --      some of them with polymorphic things with the same Name
 551                 --      (see note [RecStmt] in HsExpr)
 552         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 553
 554         ; return (RecStmt stmts' later_ids rec_ids rec_rets 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 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
 566   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 567
 568 \end{code}
 569
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection{Errors and contexts}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 578 number of args are used in each equation.
 579
 580 \begin{code}
 581 checkArgs :: Name -> MatchGroup Name -> TcM ()
 582 checkArgs fun (MatchGroup (match1:matches) _)
 583     | null bad_matches = return ()
 584     | otherwise
 585     = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
 586                           ptext SLIT("have different numbers of arguments"),
 587                         nest 2 (ppr (getLoc match1)),
 588                         nest 2 (ppr (getLoc (head bad_matches)))])
 589   where
 590     n_args1 = args_in_match match1
 591     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 592
 593     args_in_match :: LMatch Name -> Int
 594     args_in_match (L _ (Match pats _ _)) = length pats
 595 checkArgs fun other = panic "TcPat.checkArgs"   -- Matches always non-empty
 596 \end{code}
 597
 598 \begin{code}
 599 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 600                            4 (pprMatch ctxt match)
 601
 602 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
 603                         4 (ppr stmt)
 604 \end{code}