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