compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcMatches: Typecheck some @Matches@
   7
   8 \begin{code}
   9 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
  10                    TcMatchCtxt(..),
  11                    tcStmts, tcDoStmts, tcBody,
  12                    tcDoStmt, tcMDoStmt, tcGuardStmt
  13        ) where
  14
  15 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, 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
  40 #include "HsVersions.h"
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection{tcMatchesFun, tcMatchesCase}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  50 @FunMonoBind@.  The second argument is the name of the function, which
  51 is used in error messages.  It checks that all the equations have the
  52 same number of arguments before using @tcMatches@ to do the work.
  53
  54 \begin{code}
  55 tcMatchesFun :: Name -> Bool
  56              -> MatchGroup Name
  57              -> BoxyRhoType             -- Expected type of function
  58              -> TcM (HsWrapper, MatchGroup TcId)        -- Returns type of body
  59
  60 tcMatchesFun fun_name inf matches exp_ty
  61   = do  {  -- Check that they all have the same no of arguments
  62            -- Location is in the monad, set the caller so that
  63            -- any inter-equation error messages get some vaguely
  64            -- sensible location.        Note: we have to do this odd
  65            -- ann-grabbing, because we don't always have annotations in
  66            -- hand when we call tcMatchesFun...
  67           checkArgs fun_name matches
  68
  69         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  70         -- because inconsistency between branches
  71         -- may show up as something wrong with the (non-existent) type signature
  72
  73                 -- This is one of two places places we call subFunTys
  74                 -- The point is that if expected_y is a "hole", we want
  75                 -- to make pat_tys and rhs_ty as "holes" too.
  76         ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
  77           tcMatches match_ctxt pat_tys rhs_ty matches
  78         }
  79   where
  80     doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
  81           <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
  82     n_pats = matchGroupArity matches
  83     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
  84 \end{code}
  85
  86 @tcMatchesCase@ doesn't do the argument-count check because the
  87 parser guarantees that each equation has exactly one argument.
  88
  89 \begin{code}
  90 tcMatchesCase :: TcMatchCtxt            -- Case context
  91               -> TcRhoType              -- Type of scrutinee
  92               -> MatchGroup Name        -- The case alternatives
  93               -> BoxyRhoType            -- Type of whole case expressions
  94               -> TcM (MatchGroup TcId)  -- Translated alternatives
  95
  96 tcMatchesCase ctxt scrut_ty matches res_ty
  97   | isEmptyMatchGroup matches
  98   =       -- Allow empty case expressions
  99     do {  -- Make sure we follow the invariant that res_ty is filled in
 100           res_ty' <- refineBoxToTau res_ty
 101        ;  return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
 102
 103   | otherwise
 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 Nothing $ \ 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 (PartWay 1) $
 114                              pprMatches (LambdaExpr :: HsMatchContext Name) match),
 115                         -- The pprSetDepth makes the abstraction print briefly
 116                 ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))]
 117     match_ctxt = MC { mc_what = LambdaExpr,
 118                       mc_body = tcBody }
 119 \end{code}
 120
 121 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 122
 123 \begin{code}
 124 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
 125 -- Used for pattern bindings
 126 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 127   where
 128     match_ctxt = MC { mc_what = PatBindRhs,
 129                       mc_body = tcBody }
 130 \end{code}
 131
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection{tcMatch}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 \begin{code}
 140 tcMatches :: TcMatchCtxt
 141           -> [BoxySigmaType]            -- Expected pattern types
 142           -> BoxyRhoType                -- Expected result-type of the Match.
 143           -> MatchGroup Name
 144           -> TcM (MatchGroup TcId)
 145
 146 data TcMatchCtxt        -- c.f. TcStmtCtxt, also in this module
 147   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
 148          mc_body :: LHsExpr Name                -- Type checker for a body of
 149                                                 -- an alternative
 150                  -> BoxyRhoType
 151                  -> TcM (LHsExpr TcId) }
 152
 153 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 154   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
 155     do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 156         ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
 157
 158 -------------
 159 tcMatch :: TcMatchCtxt
 160         -> [BoxySigmaType]      -- Expected pattern types
 161         -> BoxyRhoType          -- Expected result-type of the Match.
 162         -> LMatch Name
 163         -> TcM (LMatch TcId)
 164
 165 tcMatch ctxt pat_tys rhs_ty match
 166   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
 167   where
 168     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 169       = add_match_ctxt match $
 170         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
 171                                 tc_grhss ctxt maybe_rhs_sig grhss
 172            ; return (Match pats' Nothing grhss') }
 173
 174     tc_grhss ctxt Nothing grhss rhs_ty
 175       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
 176
 177         -- Result type sigs are no longer supported
 178     tc_grhss _ (Just {}) _ _
 179       = panic "tc_ghrss"        -- Rejected by renamer
 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 (pprMatchInCtxt 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 _ _ _ = 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' <- tcMonoExpr 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 _ _ [] 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 (pprStmtInCtxt 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 _ (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) <- tcInferRhoNC rhs    -- Stmt has a context already
 332         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
 333         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 334
 335 tcGuardStmt _ stmt _ _
 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)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
 350         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 351
 352 -- A boolean guard
 353 tcLcStmt _ _ (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) <- tcInferRhoNC 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) <- tcInferRhoNC 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 _ _ stmt _ _
 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) <- tcInferRhoNC 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) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
 494
 495         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 496
 497
 498 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
 499   = do  { (rhs', rhs_ty) <- tcInferRhoNC 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 {}) _ _
 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 _ stmt _ _
 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 _ _) res_ty thing_inside
 527   = do  { (rhs', pat_ty) <- tc_rhs rhs
 528         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
 529         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 530
 531 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) 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 _ _ stmt _ _
 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 _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
 596 \end{code}
 597