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                    matchCtxt, 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 ctxt (Just res_sig) grhss rhs_ty
 168       = do { addErr (ptext (sLit "Ignoring (deprecated) result type signature")
 169                         <+> ppr res_sig)
 170            ; tcGRHSs ctxt grhss rhs_ty }
 171
 172         -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
 173         -- so we don't want to add "In the lambda abstraction \x->e"
 174     add_match_ctxt match thing_inside
 175         = case mc_what ctxt of
 176             LambdaExpr -> thing_inside
 177             m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
 178
 179 -------------
 180 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
 181         -> TcM (GRHSs TcId)
 182
 183 -- Notice that we pass in the full res_ty, so that we get
 184 -- good inference from simple things like
 185 --      f = \(x::forall a.a->a) -> <stuff>
 186 -- We used to force it to be a monotype when there was more than one guard
 187 -- but we don't need to do that any more
 188
 189 tcGRHSs ctxt (GRHSs grhss binds) res_ty
 190   = do  { (binds', grhss') <- tcLocalBinds binds $
 191                               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
 192
 193         ; return (GRHSs grhss' binds') }
 194
 195 -------------
 196 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
 197
 198 tcGRHS ctxt res_ty (GRHS guards rhs)
 199   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
 200                              mc_body ctxt rhs
 201         ; return (GRHS guards' rhs') }
 202   where
 203     stmt_ctxt  = PatGuard (mc_what ctxt)
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 tcDoStmts :: HsStmtContext Name
 215           -> [LStmt Name]
 216           -> LHsExpr Name
 217           -> BoxyRhoType
 218           -> TcM (HsExpr TcId)          -- Returns a HsDo
 219 tcDoStmts ListComp stmts body res_ty
 220   = do  { (elt_ty, coi) <- boxySplitListTy res_ty
 221         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
 222                                      elt_ty $
 223                              tcBody body
 224         ; return $ mkHsWrapCoI coi
 225                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 226
 227 tcDoStmts PArrComp stmts body res_ty
 228   = do  { (elt_ty, coi) <- boxySplitPArrTy res_ty
 229         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
 230                                      elt_ty $
 231                              tcBody body
 232         ; return $ mkHsWrapCoI coi
 233                      (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 234
 235 tcDoStmts DoExpr stmts body res_ty
 236   = do  { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts
 237                                      res_ty $
 238                              tcBody body
 239         ; return (HsDo DoExpr stmts' body' res_ty) }
 240
 241 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
 242   = do  { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
 243         ; let res_ty' = mkAppTy m_ty elt_ty     -- The boxySplit consumes res_ty
 244               tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
 245                            tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 246
 247         ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
 248                                      res_ty' $
 249                              tcBody body
 250
 251         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 252         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 253         ; return $
 254             mkHsWrapCoI coi
 255               (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 256
 257 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 258
 259 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 260 tcBody body res_ty
 261   = do  { traceTc (text "tcBody" <+> ppr res_ty)
 262         ; body' <- tcPolyExpr body res_ty
 263         ; return body'
 264         }
 265 \end{code}
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection{tcStmts}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 type TcStmtChecker
 276   =  forall thing. HsStmtContext Name
 277                 -> Stmt Name
 278                 -> BoxyRhoType                  -- Result type for comprehension
 279                 -> (BoxyRhoType -> TcM thing)   -- Checker for what follows the stmt
 280                 -> TcM (Stmt TcId, thing)
 281
 282 tcStmts :: HsStmtContext Name
 283         -> TcStmtChecker        -- NB: higher-rank type
 284         -> [LStmt Name]
 285         -> BoxyRhoType
 286         -> (BoxyRhoType -> TcM thing)
 287         -> TcM ([LStmt TcId], thing)
 288
 289 -- Note the higher-rank type.  stmt_chk is applied at different
 290 -- types in the equations for tcStmts
 291
 292 tcStmts _ _ [] res_ty thing_inside
 293   = do  { thing <- thing_inside res_ty
 294         ; return ([], thing) }
 295
 296 -- LetStmts are handled uniformly, regardless of context
 297 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 298   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 299                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 300         ; return (L loc (LetStmt binds') : stmts', thing) }
 301
 302 -- For the vanilla case, handle the location-setting part
 303 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 304   = do  { (stmt', (stmts', thing)) <-
 305                 setSrcSpan loc                          $
 306                 addErrCtxt (stmtCtxt ctxt stmt)         $
 307                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 308                 popErrCtxt                              $
 309                 tcStmts ctxt stmt_chk stmts res_ty'     $
 310                 thing_inside
 311         ; return (L loc stmt' : stmts', thing) }
 312
 313 --------------------------------
 314 --      Pattern guards
 315 tcGuardStmt :: TcStmtChecker
 316 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
 317   = do  { guard' <- tcMonoExpr guard boolTy
 318         ; thing  <- thing_inside res_ty
 319         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 320
 321 tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
 322   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 323         ; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
 324         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 325
 326 tcGuardStmt _ stmt _ _
 327   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 328
 329
 330 --------------------------------
 331 --      List comprehensions and PArrays
 332
 333 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 334          -> TcStmtChecker
 335
 336 -- A generator, pat <- rhs
 337 tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
 338  = do   { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
 339                             tcMonoExpr rhs (mkTyConApp m_tc [ty])
 340         ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 341         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 342
 343 -- A boolean guard
 344 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
 345   = do  { rhs'  <- tcMonoExpr rhs boolTy
 346         ; thing <- thing_inside res_ty
 347         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 348
 349 -- A parallel set of comprehensions
 350 --      [ (g x, h x) | ... ; let g v = ...
 351 --                   | ... ; let h v = ... ]
 352 --
 353 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 354 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 355 -- Similarly if we had an existential pattern match:
 356 --
 357 --      data T = forall a. Show a => C a
 358 --
 359 --      [ (show x, show y) | ... ; C x <- ...
 360 --                         | ... ; C y <- ... ]
 361 --
 362 -- Then we need the LIE from (show x, show y) to be simplified against
 363 -- the bindings for x and y.
 364 --
 365 -- It's difficult to do this in parallel, so we rely on the renamer to
 366 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 367 -- So the binders of the first parallel group will be in scope in the second
 368 -- group.  But that's fine; there's no shadowing to worry about.
 369
 370 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 371   = do  { (pairs', thing) <- loop bndr_stmts_s
 372         ; return (ParStmt pairs', thing) }
 373   where
 374     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 375     loop [] = do { thing <- thing_inside elt_ty
 376                  ; return ([], thing) }         -- matching in the branches
 377
 378     loop ((stmts, names) : pairs)
 379       = do { (stmts', (ids, pairs', thing))
 380                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 381                    do { ids <- tcLookupLocalIds names
 382                       ; (pairs', thing) <- loop pairs
 383                       ; return (ids, pairs', thing) }
 384            ; return ( (stmts', ids) : pairs', thing ) }
 385
 386 tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty thing_inside = do
 387     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 388         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 389             let alphaListTy = mkTyConApp m_tc [alphaTy]
 390
 391             (usingExpr', maybeByExpr') <-
 392                 case maybeByExpr of
 393                     Nothing -> do
 394                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 395                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
 396                         return (usingExpr', Nothing)
 397                     Just byExpr -> do
 398                         -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
 399                         (byExpr', tTy) <- tcInferRho byExpr
 400                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
 401                         return (usingExpr', Just byExpr')
 402
 403             binders' <- tcLookupLocalIds binders
 404             thing <- thing_inside elt_ty'
 405
 406             return (binders', usingExpr', maybeByExpr', thing)
 407
 408     return (TransformStmt (stmts', binders') usingExpr' maybeByExpr', thing)
 409
 410 tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_inside = do
 411         (stmts', (bindersMap', groupByClause', thing)) <-
 412             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 413                 let alphaListTy = mkTyConApp m_tc [alphaTy]
 414                     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 415
 416                 groupByClause' <-
 417                     case groupByClause of
 418                         GroupByNothing usingExpr ->
 419                             -- We must validate that usingExpr :: forall a. [a] -> [[a]]
 420                             tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
 421                         GroupBySomething eitherUsingExpr byExpr -> do
 422                             -- We must infer a type such that byExpr :: t
 423                             (byExpr', tTy) <- tcInferRho byExpr
 424
 425                             -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
 426                             let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
 427                             eitherUsingExpr' <-
 428                                 case eitherUsingExpr of
 429                                     Left usingExpr  -> (tcPolyExpr usingExpr expectedUsingType) >>= (return . Left)
 430                                     Right usingExpr -> (tcPolyExpr (noLoc usingExpr) expectedUsingType) >>= (return . Right . unLoc)
 431                             return $ GroupBySomething eitherUsingExpr' byExpr'
 432
 433                 -- Find the IDs and types of all old binders
 434                 let (oldBinders, newBinders) = unzip bindersMap
 435                 oldBinders' <- tcLookupLocalIds oldBinders
 436
 437                 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
 438                 let newBinders' = zipWith associateNewBinder oldBinders' newBinders
 439
 440                 -- Type check the thing in the environment with these new binders and return the result
 441                 thing <- tcExtendIdEnv newBinders' (thing_inside elt_ty')
 442                 return (zipEqual "tcLcStmt: Old and new binder lists were not of the same length" oldBinders' newBinders', groupByClause', thing)
 443
 444         return (GroupStmt (stmts', bindersMap') groupByClause', thing)
 445     where
 446         associateNewBinder :: TcId -> Name -> TcId
 447         associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
 448
 449 tcLcStmt _ _ stmt _ _
 450   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 451
 452 --------------------------------
 453 --      Do-notation
 454 -- The main excitement here is dealing with rebindable syntax
 455
 456 tcDoStmt :: TcStmtChecker
 457
 458 tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 459   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 460                 -- We should use type *inference* for the RHS computations,
 461                 -- becuase of GADTs.
 462                 --      do { pat <- rhs; <rest> }
 463                 -- is rather like
 464                 --      case rhs of { pat -> <rest> }
 465                 -- We do inference on rhs, so that information about its type
 466                 -- can be refined when type-checking the pattern.
 467
 468         -- Deal with rebindable syntax:
 469         --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 470         -- This level of generality is needed for using do-notation
 471         -- in full generality; see Trac #1537
 472         ; ((bind_op', new_res_ty), pat_ty) <-
 473              withBox liftedTypeKind $ \ pat_ty ->
 474              withBox liftedTypeKind $ \ new_res_ty ->
 475              tcSyntaxOp DoOrigin bind_op
 476                         (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 477
 478                 -- If (but only if) the pattern can fail,
 479                 -- typecheck the 'fail' operator
 480         ; fail_op' <- if isIrrefutableHsPat pat
 481                       then return noSyntaxExpr
 482                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 483
 484         ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
 485
 486         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 487
 488
 489 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
 490   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 491
 492         -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
 493         ; (then_op', new_res_ty) <-
 494                 withBox liftedTypeKind $ \ new_res_ty ->
 495                 tcSyntaxOp DoOrigin then_op
 496                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 497
 498         ; thing <- thing_inside new_res_ty
 499         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 500
 501 tcDoStmt ctxt (RecStmt {}) _ _
 502   = failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
 503         -- This case can't be caught in the renamer
 504         -- see RnExpr.checkRecStmt
 505
 506 tcDoStmt _ stmt _ _
 507   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 508
 509 --------------------------------
 510 --      Mdo-notation
 511 -- The distinctive features here are
 512 --      (a) RecStmts, and
 513 --      (b) no rebindable syntax
 514
 515 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 516           -> TcStmtChecker
 517 tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
 518   = do  { (rhs', pat_ty) <- tc_rhs rhs
 519         ; (pat', thing)  <- tcLamPat pat pat_ty res_ty thing_inside
 520         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 521
 522 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
 523   = do  { (rhs', elt_ty) <- tc_rhs rhs
 524         ; thing          <- thing_inside res_ty
 525         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 526
 527 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
 528   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 529         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 530         ; tcExtendIdEnv rec_ids                 $ do
 531         { (stmts', (later_ids, rec_rets))
 532                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
 533                         -- ToDo: res_ty not really right
 534                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 535                       ; later_ids <- tcLookupLocalIds laterNames
 536                       ; return (later_ids, rec_rets) }
 537
 538         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
 539                 -- NB:  The rec_ids for the recursive things
 540                 --      already scope over this part. This binding may shadow
 541                 --      some of them with polymorphic things with the same Name
 542                 --      (see note [RecStmt] in HsExpr)
 543         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 544
 545         ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
 546         }}
 547   where
 548     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 549     tc_ret rec_name mono_ty
 550         = do { poly_id <- tcLookupId rec_name
 551                 -- poly_id may have a polymorphic type
 552                 -- but mono_ty is just a monomorphic type variable
 553              ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
 554              ; return (mkHsWrap co_fn (HsVar poly_id)) }
 555
 556 tcMDoStmt _ _ stmt _ _
 557   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 558
 559 \end{code}
 560
 561
 562 %************************************************************************
 563 %*                                                                      *
 564 \subsection{Errors and contexts}
 565 %*                                                                      *
 566 %************************************************************************
 567
 568 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 569 number of args are used in each equation.
 570
 571 \begin{code}
 572 checkArgs :: Name -> MatchGroup Name -> TcM ()
 573 checkArgs fun (MatchGroup (match1:matches) _)
 574     | null bad_matches = return ()
 575     | otherwise
 576     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
 577                           ptext (sLit "have different numbers of arguments"),
 578                         nest 2 (ppr (getLoc match1)),
 579                         nest 2 (ppr (getLoc (head bad_matches)))])
 580   where
 581     n_args1 = args_in_match match1
 582     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 583
 584     args_in_match :: LMatch Name -> Int
 585     args_in_match (L _ (Match pats _ _)) = length pats
 586 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
 587 \end{code}
 588
 589 \begin{code}
 590 matchCtxt :: HsMatchContext Name -> Match Name -> SDoc
 591 matchCtxt ctxt match  = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon)
 592                            4 (pprMatch ctxt match)
 593
 594 stmtCtxt :: HsStmtContext Name -> StmtLR Name Name -> SDoc
 595 stmtCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
 596                         4 (ppr stmt)
 597 \end{code}