compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcMatches: Typecheck some @Matches@
   7
   8 \begin{code}
   9 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
  10                    TcMatchCtxt(..),
  11                    tcStmts, tcDoStmts, tcBody,
  12                    tcDoStmt, tcMDoStmt, tcGuardStmt
  13        ) where
  14
  15 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC,
  16                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
  17
  18 import HsSyn
  19 import TcRnMonad
  20 import Inst
  21 import TcEnv
  22 import TcPat
  23 import TcMType
  24 import TcType
  25 import TcBinds
  26 import TcUnify
  27 import TcSimplify
  28 import Name
  29 import TysWiredIn
  30 import PrelNames
  31 import Id
  32 import TyCon
  33 import TysPrim
  34 import Outputable
  35 import Util
  36 import SrcLoc
  37 import FastString
  38
  39 import Control.Monad
  40
  41 #include "HsVersions.h"
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection{tcMatchesFun, tcMatchesCase}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  51 @FunMonoBind@.  The second argument is the name of the function, which
  52 is used in error messages.  It checks that all the equations have the
  53 same number of arguments before using @tcMatches@ to do the work.
  54
  55 \begin{code}
  56 tcMatchesFun :: Name -> Bool
  57              -> MatchGroup Name
  58              -> BoxyRhoType             -- Expected type of function
  59              -> TcM (HsWrapper, MatchGroup TcId)        -- Returns type of body
  60
  61 tcMatchesFun fun_name inf matches exp_ty
  62   = do  {  -- Check that they all have the same no of arguments
  63            -- Location is in the monad, set the caller so that
  64            -- any inter-equation error messages get some vaguely
  65            -- sensible location.        Note: we have to do this odd
  66            -- ann-grabbing, because we don't always have annotations in
  67            -- hand when we call tcMatchesFun...
  68           traceTc (text "tcMatchesFun" <+> (ppr fun_name $$ ppr exp_ty))
  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 res_ty $
 248                              tcBody body
 249         ; return (HsDo DoExpr stmts' body' res_ty) }
 250
 251 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
 252   = do  { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
 253         ; let res_ty' = mkAppTy m_ty elt_ty     -- The boxySplit consumes res_ty
 254               tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
 255                            tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 256
 257         ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
 258                                      res_ty' $
 259                              tcBody body
 260
 261         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 262         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 263         ; return $
 264             mkHsWrapCoI coi
 265               (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 266
 267 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 268
 269 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 270 tcBody body res_ty
 271   = do  { traceTc (text "tcBody" <+> ppr res_ty)
 272         ; body' <- tcMonoExpr body res_ty
 273         ; return body'
 274         }
 275 \end{code}
 276
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection{tcStmts}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 type TcStmtChecker
 286   =  forall thing. HsStmtContext Name
 287                 -> Stmt Name
 288                 -> BoxyRhoType                  -- Result type for comprehension
 289                 -> (BoxyRhoType -> TcM thing)   -- Checker for what follows the stmt
 290                 -> TcM (Stmt TcId, thing)
 291
 292 tcStmts :: HsStmtContext Name
 293         -> TcStmtChecker        -- NB: higher-rank type
 294         -> [LStmt Name]
 295         -> BoxyRhoType
 296         -> (BoxyRhoType -> TcM thing)
 297         -> TcM ([LStmt TcId], thing)
 298
 299 -- Note the higher-rank type.  stmt_chk is applied at different
 300 -- types in the equations for tcStmts
 301
 302 tcStmts _ _ [] res_ty thing_inside
 303   = do  { thing <- thing_inside res_ty
 304         ; return ([], thing) }
 305
 306 -- LetStmts are handled uniformly, regardless of context
 307 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
 308   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 309                                       tcStmts ctxt stmt_chk stmts res_ty thing_inside
 310         ; return (L loc (LetStmt binds') : stmts', thing) }
 311
 312 -- For the vanilla case, handle the location-setting part
 313 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 314   = do  { (stmt', (stmts', thing)) <-
 315                 setSrcSpan loc                          $
 316                 addErrCtxt (pprStmtInCtxt ctxt stmt)    $
 317                 stmt_chk ctxt stmt res_ty               $ \ res_ty' ->
 318                 popErrCtxt                              $
 319                 tcStmts ctxt stmt_chk stmts res_ty'     $
 320                 thing_inside
 321         ; return (L loc stmt' : stmts', thing) }
 322
 323 --------------------------------
 324 --      Pattern guards
 325 tcGuardStmt :: TcStmtChecker
 326 tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
 327   = do  { guard' <- tcMonoExpr guard boolTy
 328         ; thing  <- thing_inside res_ty
 329         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 330
 331 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 332   = do  { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
 333         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
 334         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 335
 336 tcGuardStmt _ stmt _ _
 337   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 338
 339
 340 --------------------------------
 341 --      List comprehensions and PArrays
 342
 343 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 344          -> TcStmtChecker
 345
 346 -- A generator, pat <- rhs
 347 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 348  = do   { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
 349                             tcMonoExpr rhs (mkTyConApp m_tc [ty])
 350         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
 351         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 352
 353 -- A boolean guard
 354 tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
 355   = do  { rhs'  <- tcMonoExpr rhs boolTy
 356         ; thing <- thing_inside res_ty
 357         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 358
 359 -- A parallel set of comprehensions
 360 --      [ (g x, h x) | ... ; let g v = ...
 361 --                   | ... ; let h v = ... ]
 362 --
 363 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 364 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 365 -- Similarly if we had an existential pattern match:
 366 --
 367 --      data T = forall a. Show a => C a
 368 --
 369 --      [ (show x, show y) | ... ; C x <- ...
 370 --                         | ... ; C y <- ... ]
 371 --
 372 -- Then we need the LIE from (show x, show y) to be simplified against
 373 -- the bindings for x and y.
 374 --
 375 -- It's difficult to do this in parallel, so we rely on the renamer to
 376 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 377 -- So the binders of the first parallel group will be in scope in the second
 378 -- group.  But that's fine; there's no shadowing to worry about.
 379
 380 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
 381   = do  { (pairs', thing) <- loop bndr_stmts_s
 382         ; return (ParStmt pairs', thing) }
 383   where
 384     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 385     loop [] = do { thing <- thing_inside elt_ty
 386                  ; return ([], thing) }         -- matching in the branches
 387
 388     loop ((stmts, names) : pairs)
 389       = do { (stmts', (ids, pairs', thing))
 390                 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 391                    do { ids <- tcLookupLocalIds names
 392                       ; (pairs', thing) <- loop pairs
 393                       ; return (ids, pairs', thing) }
 394            ; return ( (stmts', ids) : pairs', thing ) }
 395
 396 tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
 397     (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
 398         tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 399             let alphaListTy = mkTyConApp m_tc [alphaTy]
 400
 401             (usingExpr', maybeByExpr') <-
 402                 case maybeByExpr of
 403                     Nothing -> do
 404                         -- We must validate that usingExpr :: forall a. [a] -> [a]
 405                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
 406                         return (usingExpr', Nothing)
 407                     Just byExpr -> do
 408                         -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
 409                         (byExpr', tTy) <- tcInferRhoNC byExpr
 410                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
 411                         return (usingExpr', Just byExpr')
 412
 413             binders' <- tcLookupLocalIds binders
 414             thing <- thing_inside elt_ty'
 415
 416             return (binders', usingExpr', maybeByExpr', thing)
 417
 418     return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
 419
 420 tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
 421   = do { let (bndr_names, list_bndr_names) = unzip bindersMap
 422
 423        ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
 424             tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
 425                 (by', using_ty) <- case by of
 426                                      Nothing   -> -- check that using :: forall a. [a] -> [[a]]
 427                                                   return (Nothing, mkForAllTy alphaTyVar $
 428                                                                    alphaListTy `mkFunTy` alphaListListTy)
 429
 430                                      Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
 431                                                   -- where by :: t
 432                                                   do { (by_e', t_ty) <- tcInferRhoNC by_e
 433                                                      ; return (Just by_e', mkForAllTy alphaTyVar $
 434                                                                            (alphaTy `mkFunTy` t_ty)
 435                                                                               `mkFunTy` alphaListTy
 436                                                                               `mkFunTy` alphaListListTy) }
 437                 -- Find the Ids (and hence types) of all old binders
 438                 bndr_ids <- tcLookupLocalIds bndr_names
 439
 440                 return (bndr_ids, by', using_ty, elt_ty')
 441
 442                 -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
 443        ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
 444              bindersMap' = bndr_ids `zip` list_bndr_ids
 445              -- See Note [GroupStmt binder map] in HsExpr
 446
 447        ; using' <- case using of
 448                      Left  e -> do { e' <- tcPolyExpr e         using_ty; return (Left  e') }
 449                      Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
 450
 451              -- Type check the thing in the environment with these new binders and return the result
 452        ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
 453        ; return (GroupStmt stmts' bindersMap' by' using', thing) }
 454   where
 455     alphaListTy = mkTyConApp m_tc [alphaTy]
 456     alphaListListTy = mkTyConApp m_tc [alphaListTy]
 457
 458     mk_list_bndr :: Name -> TcId -> TcId
 459     mk_list_bndr list_bndr_name bndr_id = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
 460
 461 tcLcStmt _ _ stmt _ _
 462   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 463
 464 --------------------------------
 465 --      Do-notation
 466 -- The main excitement here is dealing with rebindable syntax
 467
 468 tcDoStmt :: TcStmtChecker
 469
 470 tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 471   = do  {       -- Deal with rebindable syntax:
 472                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
 473                 -- This level of generality is needed for using do-notation
 474                 -- in full generality; see Trac #1537
 475
 476                 -- I'd like to put this *after* the tcSyntaxOp
 477                 -- (see Note [Treat rebindable syntax first], but that breaks
 478                 -- the rigidity info for GADTs.  When we move to the new story
 479                 -- for GADTs, we can move this after tcSyntaxOp
 480           (rhs', rhs_ty) <- tcInferRhoNC rhs
 481
 482         ; ((bind_op', new_res_ty), pat_ty) <-
 483              withBox liftedTypeKind $ \ pat_ty ->
 484              withBox liftedTypeKind $ \ new_res_ty ->
 485              tcSyntaxOp DoOrigin bind_op
 486                              (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 487
 488                 -- If (but only if) the pattern can fail,
 489                 -- typecheck the 'fail' operator
 490         ; fail_op' <- if isIrrefutableHsPat pat
 491                       then return noSyntaxExpr
 492                       else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 493
 494                 -- We should typecheck the RHS *before* the pattern,
 495                 -- because of GADTs.
 496                 --      do { pat <- rhs; <rest> }
 497                 -- is rather like
 498                 --      case rhs of { pat -> <rest> }
 499                 -- We do inference on rhs, so that information about its type
 500                 -- can be refined when type-checking the pattern.
 501
 502         ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
 503
 504         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 505
 506
 507 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
 508   = do  {       -- Deal with rebindable syntax;
 509                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 510                 -- See also Note [Treat rebindable syntax first]
 511           ((then_op', rhs_ty), new_res_ty) <-
 512                 withBox liftedTypeKind $ \ new_res_ty ->
 513                 withBox liftedTypeKind $ \ rhs_ty ->
 514                 tcSyntaxOp DoOrigin then_op
 515                            (mkFunTys [rhs_ty, new_res_ty] res_ty)
 516
 517         ; rhs' <- tcMonoExprNC rhs rhs_ty
 518         ; thing <- thing_inside new_res_ty
 519         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 520
 521 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 522                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
 523                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
 524          res_ty thing_inside
 525   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
 526         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
 527         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
 528               tup_ty  = mkBoxedTupleTy tup_elt_tys
 529
 530         ; tcExtendIdEnv tup_ids $ do
 531         { ((stmts', (ret_op', tup_rets)), stmts_ty)
 532                 <- withBox liftedTypeKind $ \ stmts_ty ->
 533                    tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
 534                    do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys
 535                       ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
 536                       ; return (ret_op', tup_rets) }
 537
 538         ; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty ->
 539                                      tcSyntaxOp DoOrigin mfix_op
 540                                         (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
 541
 542         ; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty ->
 543                                     tcSyntaxOp DoOrigin bind_op
 544                                         (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 545
 546         ; (thing,lie) <- getLIE (thing_inside new_res_ty)
 547         ; lie_binds <- bindInstsOfLocalFuns lie tup_ids
 548
 549         ; let rec_ids = takeList rec_names tup_ids
 550         ; later_ids <- tcLookupLocalIds later_names
 551         ; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids),
 552                                          ppr later_ids <+> ppr (map idType later_ids)])
 553         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
 554                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
 555                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
 556                           , recS_rec_rets = tup_rets, recS_dicts = lie_binds }, thing)
 557         }}
 558   where
 559     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 560     tc_ret rec_name mono_ty
 561         = do { poly_id <- tcLookupId rec_name
 562                 -- poly_id may have a polymorphic type
 563                 -- but mono_ty is just a monomorphic type variable
 564              ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
 565              ; return (mkHsWrap co_fn (HsVar poly_id)) }
 566
 567 tcDoStmt _ stmt _ _
 568   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 569 \end{code}
 570
 571 Note [Treat rebindable syntax first]
 572 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 573 When typechecking
 574         do { bar; ... } :: IO ()
 575 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 576 pushing info from the context into the RHS.  To do this, we check the
 577 rebindable syntax first, and push that information into (tcMonoExprNC rhs).
 578 Otherwise the error shows up when cheking the rebindable syntax, and
 579 the expected/inferred stuff is back to front (see Trac #3613).
 580
 581 \begin{code}
 582 --------------------------------
 583 --      Mdo-notation
 584 -- The distinctive features here are
 585 --      (a) RecStmts, and
 586 --      (b) no rebindable syntax
 587
 588 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 589           -> TcStmtChecker
 590 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
 591   = do  { (rhs', pat_ty) <- tc_rhs rhs
 592         ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
 593         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 594
 595 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
 596   = do  { (rhs', elt_ty) <- tc_rhs rhs
 597         ; thing          <- thing_inside res_ty
 598         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 599
 600 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
 601   = do  { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
 602         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 603         ; tcExtendIdEnv rec_ids                 $ do
 604         { (stmts', (later_ids, rec_rets))
 605                 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
 606                         -- ToDo: res_ty not really right
 607                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 608                       ; later_ids <- tcLookupLocalIds laterNames
 609                       ; return (later_ids, rec_rets) }
 610
 611         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
 612                 -- NB:  The rec_ids for the recursive things
 613                 --      already scope over this part. This binding may shadow
 614                 --      some of them with polymorphic things with the same Name
 615                 --      (see note [RecStmt] in HsExpr)
 616         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 617
 618         ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
 619         }}
 620   where
 621     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 622     tc_ret rec_name mono_ty
 623         = do { poly_id <- tcLookupId rec_name
 624                 -- poly_id may have a polymorphic type
 625                 -- but mono_ty is just a monomorphic type variable
 626              ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
 627              ; return (mkHsWrap co_fn (HsVar poly_id)) }
 628
 629 tcMDoStmt _ _ stmt _ _
 630   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 631
 632 \end{code}
 633
 634
 635 %************************************************************************
 636 %*                                                                      *
 637 \subsection{Errors and contexts}
 638 %*                                                                      *
 639 %************************************************************************
 640
 641 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 642 number of args are used in each equation.
 643
 644 \begin{code}
 645 checkArgs :: Name -> MatchGroup Name -> TcM ()
 646 checkArgs fun (MatchGroup (match1:matches) _)
 647     | null bad_matches = return ()
 648     | otherwise
 649     = failWithTc (vcat [ptext (sLit "Equations for") <+> quotes (ppr fun) <+>
 650                           ptext (sLit "have different numbers of arguments"),
 651                         nest 2 (ppr (getLoc match1)),
 652                         nest 2 (ppr (getLoc (head bad_matches)))])
 653   where
 654     n_args1 = args_in_match match1
 655     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 656
 657     args_in_match :: LMatch Name -> Int
 658     args_in_match (L _ (Match pats _ _)) = length pats
 659 checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
 660 \end{code}
 661