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