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