ghc/compiler/typecheck/TcMatches.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcMatches]{Typecheck some @Matches@}
   5
   6 \begin{code}
   7 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
   8                    tcMatchPats, matchCtxt, TcMatchCtxt(..),
   9                    tcStmts, tcDoStmts,
  10                    tcDoStmt, tcMDoStmt, tcGuardStmt,
  11                    tcThingWithSig
  12        ) where
  13
  14 #include "HsVersions.h"
  15
  16 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcCheckRho, tcInferRho, tcMonoExpr, tcCheckSigma )
  17
  18 import HsSyn            ( HsExpr(..), LHsExpr, MatchGroup(..),
  19                           Match(..), LMatch, GRHSs(..), GRHS(..),
  20                           Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
  21                           LPat, pprMatch, isIrrefutableHsPat,
  22                           pprMatchContext, pprStmtContext, pprMatchRhsContext,
  23                           collectPatsBinders, noSyntaxExpr
  24                         )
  25 import TcHsSyn          ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
  26
  27 import TcRnMonad
  28 import TcHsType         ( tcHsPatSigType, UserTypeCtxt(..) )
  29 import Inst             ( tcInstCall, newMethodFromName )
  30 import TcEnv            ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
  31                           tcExtendTyVarEnv )
  32 import TcPat            ( PatCtxt(..), tcPats )
  33 import TcMType          ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType )
  34 import TcType           ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
  35                           tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
  36                           liftedTypeKind, openTypeKind, mkFunTy, mkAppTy )
  37 import TcBinds          ( tcLocalBinds )
  38 import TcUnify          ( Expected(..), zapExpectedType, readExpectedType,
  39                           unifyTauTy, subFunTys, unifyTyConApp,
  40                           checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
  41                           unifyAppTy, zapToListTy, zapToTyConApp )
  42 import TcSimplify       ( bindInstsOfLocalFuns )
  43 import Name             ( Name )
  44 import TysWiredIn       ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
  45 import PrelNames        ( bindMName, returnMName, mfixName, thenMName, failMName )
  46 import Id               ( idType, mkLocalId )
  47 import TyCon            ( TyCon )
  48 import CoreFVs          ( idFreeTyVars )
  49 import VarSet
  50 import Util             ( isSingleton )
  51 import Outputable
  52 import SrcLoc           ( Located(..) )
  53
  54 import List             ( nub )
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{tcMatchesFun, tcMatchesCase}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  64 @FunMonoBind@.  The second argument is the name of the function, which
  65 is used in error messages.  It checks that all the equations have the
  66 same number of arguments before using @tcMatches@ to do the work.
  67
  68 \begin{code}
  69 tcMatchesFun :: Name
  70              -> MatchGroup Name
  71              -> Expected TcRhoType      -- Expected type of function
  72              -> TcM (MatchGroup TcId)   -- Returns type of body
  73
  74 tcMatchesFun fun_name matches exp_ty
  75   = do  {  -- Check that they all have the same no of arguments
  76            -- Location is in the monad, set the caller so that
  77            -- any inter-equation error messages get some vaguely
  78            -- sensible location.        Note: we have to do this odd
  79            -- ann-grabbing, because we don't always have annotations in
  80            -- hand when we call tcMatchesFun...
  81           checkTc (sameNoOfArgs matches) (varyingArgsErr fun_name matches)
  82
  83         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  84         -- because inconsistency between branches
  85         -- may show up as something wrong with the (non-existent) type signature
  86
  87                 -- This is one of two places places we call subFunTys
  88                 -- The point is that if expected_y is a "hole", we want
  89                 -- to make pat_tys and rhs_ty as "holes" too.
  90         ; exp_ty' <- zapExpectedBranches matches exp_ty
  91         ; subFunTys ctxt matches exp_ty'        $ \ pat_tys rhs_ty ->
  92           tcMatches match_ctxt pat_tys rhs_ty matches
  93         }
  94   where
  95     ctxt = FunRhs fun_name
  96     match_ctxt = MC { mc_what = ctxt, mc_body = tcMonoExpr }
  97 \end{code}
  98
  99 @tcMatchesCase@ doesn't do the argument-count check because the
 100 parser guarantees that each equation has exactly one argument.
 101
 102 \begin{code}
 103 tcMatchesCase :: TcMatchCtxt            -- Case context
 104               -> TcRhoType              -- Type of scrutinee
 105               -> MatchGroup Name        -- The case alternatives
 106               -> Expected TcRhoType     -- Type of whole case expressions
 107               -> TcM (MatchGroup TcId)  -- Translated alternatives
 108
 109 tcMatchesCase ctxt scrut_ty matches exp_ty
 110   = do  { exp_ty' <- zapExpectedBranches matches exp_ty
 111         ; tcMatches ctxt [Check scrut_ty] exp_ty' matches }
 112
 113 tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId)
 114 tcMatchLambda match exp_ty      -- One branch so no unifyBranches needed
 115   = subFunTys LambdaExpr match exp_ty   $ \ pat_tys rhs_ty ->
 116     tcMatches match_ctxt pat_tys rhs_ty match
 117   where
 118     match_ctxt = MC { mc_what = LambdaExpr,
 119                       mc_body = tcMonoExpr }
 120 \end{code}
 121
 122 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 123
 124 \begin{code}
 125 tcGRHSsPat :: GRHSs Name
 126            -> Expected TcRhoType
 127            -> TcM (GRHSs TcId)
 128 tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty
 129   where
 130     match_ctxt = MC { mc_what = PatBindRhs,
 131                       mc_body = tcMonoExpr }
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{tcMatch}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcMatches :: TcMatchCtxt
 143           -> [Expected TcRhoType]       -- Expected pattern types
 144           -> Expected TcRhoType         -- 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 an alternative
 151                  -> Expected TcRhoType
 152                  -> TcM (LHsExpr TcId) }
 153
 154 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 155   = do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
 156         ; pat_tys' <- mapM readExpectedType pat_tys
 157         ; rhs_ty'  <- readExpectedType rhs_ty
 158         ; return (MatchGroup matches' (mkFunTys pat_tys' rhs_ty')) }
 159
 160 -------------
 161 tcMatch :: TcMatchCtxt
 162         -> [Expected TcRhoType]         -- Expected pattern types
 163         -> Expected TcRhoType           -- 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
 170 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
 171   = addErrCtxt (matchCtxt (mc_what ctxt) match) $
 172     do  { (pats', grhss') <- tcMatchPats pats pat_tys rhs_ty $
 173                              tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
 174         ; returnM (Match pats' Nothing grhss') }
 175
 176
 177 -------------
 178 tc_grhss ctxt Nothing grhss rhs_ty
 179   = tcGRHSs ctxt grhss rhs_ty   -- No result signature
 180
 181 tc_grhss ctxt (Just res_sig) grhss rhs_ty
 182   = do  { (sig_tvs, sig_ty) <- tcHsPatSigType ResSigCtxt res_sig
 183         ; traceTc (text "tc_grhss" <+> ppr sig_tvs)
 184         ; (co_fn, grhss') <- tcExtendTyVarEnv sig_tvs $
 185                              tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty
 186
 187                 -- Push the coercion down to the right hand sides,
 188                 -- because there is no convenient place to hang it otherwise.
 189         ; if isIdCoercion co_fn then
 190                 return grhss'
 191           else
 192                 return (lift_grhss co_fn grhss') }
 193
 194 -------------
 195 lift_grhss co_fn (GRHSs grhss binds)
 196   = GRHSs (map (fmap lift_grhs) grhss) binds
 197   where
 198     lift_grhs (GRHS stmts rhs) = GRHS stmts (fmap (co_fn <$>) rhs)
 199
 200 -------------
 201 tcGRHSs :: TcMatchCtxt -> GRHSs Name
 202         -> Expected TcRhoType
 203         -> TcM (GRHSs TcId)
 204
 205   -- Special case when there is just one equation with a degenerate
 206   -- guard; then we pass in the full Expected type, so that we get
 207   -- good inference from simple things like
 208   --    f = \(x::forall a.a->a) -> <stuff>
 209   -- This is a consequence of the fact that tcStmts takes a TcType,
 210   -- not a Expected TcType, a decision we could revisit if necessary
 211 tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty
 212   = do  { (binds', rhs') <- tcLocalBinds binds  $
 213                             mc_body ctxt rhs exp_ty
 214         ; returnM (GRHSs [L loc1 (GRHS [] rhs')] binds') }
 215
 216 tcGRHSs ctxt (GRHSs grhss binds) exp_ty
 217   = do  { exp_ty' <- zapExpectedType exp_ty openTypeKind
 218                         -- Even if there is only one guard, we zap the RHS type to
 219                         -- a monotype.  Reason: it makes tcStmts much easier,
 220                         -- and even a one-armed guard has a notional second arm
 221
 222         ; (binds', grhss') <- tcLocalBinds binds $
 223                               mappM (wrapLocM (tcGRHS ctxt exp_ty')) grhss
 224
 225         ; returnM (GRHSs grhss' binds') }
 226
 227 -------------
 228 tcGRHS :: TcMatchCtxt -> TcRhoType
 229         -> GRHS Name -> TcM (GRHS TcId)
 230
 231 tcGRHS ctxt exp_ty' (GRHS guards rhs)
 232   = do  { (guards', rhs') <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
 233                              addErrCtxt (grhsCtxt match_ctxt rhs) $
 234                              tcCheckRho rhs exp_ty'
 235         ; return (GRHS guards' rhs') }
 236   where
 237     match_ctxt = mc_what ctxt
 238     stmt_ctxt  = PatGuard match_ctxt
 239 \end{code}
 240
 241
 242 \begin{code}
 243 tcThingWithSig :: TcSigmaType           -- Type signature
 244                -> (TcRhoType -> TcM r)  -- How to type check the thing inside
 245                -> Expected TcRhoType    -- Overall expected result type
 246                -> TcM (ExprCoFn, r)
 247 -- Used for expressions with a type signature, and for result type signatures
 248
 249 tcThingWithSig sig_ty thing_inside res_ty
 250   | not (isSigmaTy sig_ty)
 251   = thing_inside sig_ty         `thenM` \ result ->
 252     tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
 253     returnM (co_fn, result)
 254
 255   | otherwise   -- The signature has some outer foralls
 256   =     -- Must instantiate the outer for-alls of sig_tc_ty
 257         -- else we risk instantiating a ? res_ty to a forall-type
 258         -- which breaks the invariant that tcMonoExpr only returns phi-types
 259     tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
 260     tcInstCall InstSigOrigin sig_ty             `thenM` \ (inst_fn, _, inst_sig_ty) ->
 261     tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
 262     returnM (co_fn <.> inst_fn <.> gen_fn,  result)
 263         -- Note that we generalise, then instantiate. Ah well.
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection{tcMatchPats}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 tcMatchPats :: [LPat Name]
 275             -> [Expected TcSigmaType]   -- Pattern types
 276             -> Expected TcRhoType       -- Result type;
 277                                         -- used only to check existential escape
 278             -> TcM a
 279             -> TcM ([LPat TcId], a)
 280 -- Typecheck the patterns, extend the environment to bind the variables,
 281 -- do the thing inside, use any existentially-bound dictionaries to
 282 -- discharge parts of the returning LIE, and deal with pattern type
 283 -- signatures
 284
 285 tcMatchPats pats tys body_ty thing_inside
 286   = do  { (pats', ex_tvs, res) <- tcPats LamPat pats tys thing_inside
 287         ; tcCheckExistentialPat pats' ex_tvs tys body_ty
 288         ; returnM (pats', res) }
 289
 290 tcCheckExistentialPat :: [LPat TcId]            -- Patterns (just for error message)
 291                       -> [TcTyVar]              -- Existentially quantified tyvars bound by pattern
 292                       -> [Expected TcSigmaType] -- Types of the patterns
 293                       -> Expected TcRhoType     -- Type of the body of the match
 294                                                 -- Tyvars in either of these must not escape
 295                       -> TcM ()
 296         -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
 297         -- For example, we must reject this program:
 298         --      data C = forall a. C (a -> Int)
 299         --      f (C g) x = g x
 300         -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 301
 302 tcCheckExistentialPat pats [] pat_tys body_ty
 303   = return ()   -- Short cut for case when there are no existentials
 304
 305 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
 306   = do  { tys <- mapM readExpectedType (body_ty : pat_tys)
 307         ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $
 308           checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs }
 309 \end{code}
 310
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 tcDoStmts :: HsStmtContext Name
 320           -> [LStmt Name]
 321           -> LHsExpr Name
 322           -> Expected TcRhoType
 323           -> TcM (HsExpr TcId)          -- Returns a HsDo
 324 tcDoStmts ListComp stmts body res_ty
 325   = do  { elt_ty <- zapToListTy res_ty
 326         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
 327                              addErrCtxt (doBodyCtxt ListComp body) $
 328                              tcCheckRho body elt_ty
 329         ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 330
 331 tcDoStmts PArrComp stmts body res_ty
 332   = do  { [elt_ty] <- zapToTyConApp parrTyCon res_ty
 333         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
 334                              addErrCtxt (doBodyCtxt PArrComp body) $
 335                              tcCheckRho body elt_ty
 336         ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 337
 338 tcDoStmts DoExpr stmts body res_ty
 339   = do  { res_ty'   <- zapExpectedType res_ty liftedTypeKind
 340         ; (m_ty, _) <- unifyAppTy res_ty'
 341         ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
 342                              addErrCtxt (doBodyCtxt DoExpr body) $
 343                              tcCheckRho body res_ty'
 344         ; return (HsDo DoExpr stmts' body' res_ty') }
 345
 346 tcDoStmts cxt@(MDoExpr _) stmts body res_ty
 347   = do  { res_ty'   <- zapExpectedType res_ty liftedTypeKind
 348         ; (m_ty, _) <- unifyAppTy res_ty'
 349         ; let tc_rhs rhs = do   { (rhs', rhs_ty) <- tcInferRho rhs
 350                                 ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
 351                                 ; unifyTauTy m_ty n_ty
 352                                 ; return (rhs', pat_ty) }
 353
 354         ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
 355                              addErrCtxt (doBodyCtxt cxt body) $
 356                              tcCheckRho body res_ty'
 357
 358         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 359         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 360         ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 361
 362 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 363 \end{code}
 364
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsection{tcStmts}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 type TcStmtChecker
 374   = forall thing.  HsStmtContext Name
 375                    -> Stmt Name
 376                    -> TcM thing
 377                    -> TcM (Stmt TcId, thing)
 378
 379 tcStmts :: HsStmtContext Name
 380         -> TcStmtChecker        -- NB: higher-rank type
 381         -> [LStmt Name]
 382         -> TcM thing
 383         -> TcM ([LStmt TcId], thing)
 384
 385 -- Note the higher-rank type.  stmt_chk is applied at different
 386 -- types in the equations for tcStmts
 387
 388 tcStmts ctxt stmt_chk [] thing_inside
 389   = do  { thing <- thing_inside
 390         ; return ([], thing) }
 391
 392 -- LetStmts are handled uniformly, regardless of context
 393 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
 394   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
 395                                       tcStmts ctxt stmt_chk stmts thing_inside
 396         ; return (L loc (LetStmt binds') : stmts', thing) }
 397
 398 -- For the vanilla case, handle the location-setting part
 399 tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
 400   = do  { (stmt', (stmts', thing)) <-
 401                 setSrcSpan loc                  $
 402                 addErrCtxt (stmtCtxt ctxt stmt) $
 403                 stmt_chk ctxt stmt              $
 404                 popErrCtxt                      $
 405                 tcStmts ctxt stmt_chk stmts     $
 406                 thing_inside
 407         ; return (L loc stmt' : stmts', thing) }
 408
 409 --------------------------------
 410 --      Pattern guards
 411 tcGuardStmt :: TcType -> TcStmtChecker
 412 tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
 413   = do  { guard' <- tcCheckRho guard boolTy
 414         ; thing  <- thing_inside
 415         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 416
 417 tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
 418   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 419         ; (pat', thing)  <- tcBindPat pat rhs_ty res_ty thing_inside
 420         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 421
 422 tcGuardStmt res_ty ctxt stmt thing_inside
 423   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 424
 425
 426 --------------------------------
 427 --      List comprehensions and PArrays
 428
 429 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 430          -> TcType      -- The element type of the list or PArray
 431          -> TcStmtChecker
 432
 433 -- A generator, pat <- rhs
 434 tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
 435   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 436         ; [pat_ty]       <- unifyTyConApp m_tc rhs_ty
 437         ; (pat', thing)  <- tcBindPat pat pat_ty elt_ty thing_inside
 438         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 439
 440 -- A boolean guard
 441 tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
 442   = do  { rhs'  <- tcCheckRho rhs boolTy
 443         ; thing <- thing_inside
 444         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 445
 446 -- A parallel set of comprehensions
 447 --      [ (g x, h x) | ... ; let g v = ...
 448 --                   | ... ; let h v = ... ]
 449 --
 450 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 451 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 452 -- Similarly if we had an existential pattern match:
 453 --
 454 --      data T = forall a. Show a => C a
 455 --
 456 --      [ (show x, show y) | ... ; C x <- ...
 457 --                         | ... ; C y <- ... ]
 458 --
 459 -- Then we need the LIE from (show x, show y) to be simplified against
 460 -- the bindings for x and y.
 461 --
 462 -- It's difficult to do this in parallel, so we rely on the renamer to
 463 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 464 -- So the binders of the first parallel group will be in scope in the second
 465 -- group.  But that's fine; there's no shadowing to worry about.
 466
 467 tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
 468   = do  { (pairs', thing) <- loop bndr_stmts_s
 469         ; return (ParStmt pairs', thing) }
 470   where
 471     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 472     loop [] = do { thing <- thing_inside
 473                  ; return ([], thing) }
 474
 475     loop ((stmts, names) : pairs)
 476       = do { (stmts', (ids, pairs', thing))
 477                 <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
 478                    do { ids <- tcLookupLocalIds names
 479                       ; (pairs', thing) <- loop pairs
 480                       ; return (ids, pairs', thing) }
 481            ; return ( (stmts', ids) : pairs', thing ) }
 482
 483 tcLcStmt m_tc elt_ty ctxt stmt thing_inside
 484   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 485
 486 --------------------------------
 487 --      Do-notation
 488 -- The main excitement here is dealing with rebindable syntax
 489
 490 tcDoStmt :: TcType              -- Monad type,  m
 491          -> TcType              -- Result type, m b
 492          -> TcStmtChecker
 493         -- BindStmt
 494 tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
 495   = do  {       -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
 496         ; (rhs', rhs_ty) <- tcInferRho rhs
 497                 -- We should use type *inference* for the RHS computations, becuase of GADTs.
 498                 --      do { pat <- rhs; <rest> }
 499                 -- is rather like
 500                 --      case rhs of { pat -> <rest> }
 501                 -- We do inference on rhs, so that information about its type can be refined
 502                 -- when type-checking the pattern.
 503
 504         ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
 505         ; unifyTauTy m_ty n_ty
 506         ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
 507
 508         ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
 509
 510         -- Rebindable syntax stuff
 511         ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
 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 res_ty)
 517         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 518
 519
 520 tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
 521   = do  {       -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
 522           a_ty <- newTyFlexiVarTy liftedTypeKind
 523         ; let rhs_ty  = mkAppTy m_ty a_ty
 524               then_ty = mkFunTys [rhs_ty, res_ty] res_ty
 525         ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
 526         ; rhs' <- tcCheckSigma rhs rhs_ty
 527         ; thing <- thing_inside
 528         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 529
 530 tcDoStmt m_ty res_ty ctxt stmt thing_inside
 531   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 532
 533 --------------------------------
 534 --      Mdo-notation
 535 -- The distinctive features here are
 536 --      (a) RecStmts, and
 537 --      (b) no rebindable syntax
 538
 539 tcMDoStmt :: TcType             -- Result type, m b
 540           -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 541           -> TcStmtChecker
 542 tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
 543   = do  { (rhs', pat_ty) <- tc_rhs rhs
 544         ; (pat', thing)  <- tcBindPat pat pat_ty res_ty thing_inside
 545         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 546
 547 tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
 548   = do  { (rhs', elt_ty) <- tc_rhs rhs
 549         ; thing          <- thing_inside
 550         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 551
 552 tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
 553   = do  { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
 554         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 555         ; tcExtendIdEnv rec_ids                 $ do
 556         { (stmts', (later_ids, rec_rets))
 557                 <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
 558                         -- ToDo: res_ty not really right
 559                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 560                       ; later_ids <- tcLookupLocalIds laterNames
 561                       ; return (later_ids, rec_rets) }
 562
 563         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
 564                 -- NB:  The rec_ids for the recursive things
 565                 --      already scope over this part. This binding may shadow
 566                 --      some of them with polymorphic things with the same Name
 567                 --      (see note [RecStmt] in HsExpr)
 568         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 569
 570         ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
 571         }}
 572   where
 573     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 574     tc_ret rec_name mono_ty
 575         = tcLookupId rec_name                           `thenM` \ poly_id ->
 576                 -- poly_id may have a polymorphic type
 577                 -- but mono_ty is just a monomorphic type variable
 578           tcSubExp (Check mono_ty) (idType poly_id)     `thenM` \ co_fn ->
 579           returnM (co_fn <$> HsVar poly_id)
 580
 581 tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
 582   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 583
 584 -----------------
 585 tcBindPat :: LPat Name -> TcType
 586           -> TcType     -- Result type; used only to check existential escape
 587           -> TcM a
 588           -> TcM (LPat TcId, a)
 589 tcBindPat pat pat_ty res_ty thing_inside
 590   = do  { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
 591                                         (Check res_ty) thing_inside
 592         ; return (pat', thing) }
 593 \end{code}
 594
 595
 596 %************************************************************************
 597 %*                                                                      *
 598 \subsection{Errors and contexts}
 599 %*                                                                      *
 600 %************************************************************************
 601
 602 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 603 number of args are used in each equation.
 604
 605 \begin{code}
 606 sameNoOfArgs :: MatchGroup Name -> Bool
 607 sameNoOfArgs (MatchGroup matches _)
 608    = isSingleton (nub (map args_in_match matches))
 609   where
 610     args_in_match :: LMatch Name -> Int
 611     args_in_match (L _ (Match pats _ _)) = length pats
 612 \end{code}
 613
 614 \begin{code}
 615 varyingArgsErr name matches
 616   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 617
 618 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 619                            4 (pprMatch ctxt match)
 620
 621 grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
 622                        4 (ppr rhs)
 623
 624 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
 625 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
 626                           4 (ppr body)
 627
 628 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
 629                         4 (ppr stmt)
 630
 631 sigPatCtxt bound_ids bound_tvs tys tidy_env
 632   =     -- tys is (body_ty : pat_tys)
 633     mapM zonkTcType tys         `thenM` \ tys' ->
 634     let
 635         (env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 636         (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
 637     in
 638     returnM (env1,
 639                  sep [ptext SLIT("When checking an existential match that binds"),
 640                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 641                       ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 642                       ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 643                 ])
 644   where
 645     show_ids = filter is_interesting bound_ids
 646     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 647
 648     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 649         -- Don't zonk the types so we get the separate, un-unified versions
 650 \end{code}