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