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