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