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, glueBindsOnGRHSs, 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          ( tcBindsAndThen )
  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   = tcBindsAndThen glueBindsOnGRHSs binds       $
 213     mc_body ctxt rhs exp_ty                     `thenM` \ rhs' ->
 214     returnM (GRHSs [L loc1 (GRHS [] rhs')] [])
 215
 216 tcGRHSs ctxt (GRHSs grhss binds) exp_ty
 217   = tcBindsAndThen glueBindsOnGRHSs binds       $
 218     do  { exp_ty' <- zapExpectedType exp_ty openTypeKind
 219                 -- Even if there is only one guard, we zap the RHS type to
 220                 -- a monotype.  Reason: it makes tcStmts much easier,
 221                 -- and even a one-armed guard has a notional second arm
 222
 223         ; let match_ctxt = mc_what ctxt
 224               stmt_ctxt  = PatGuard match_ctxt
 225               tc_grhs (GRHS guards rhs)
 226                 = do  { (guards', rhs')
 227                             <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
 228                                addErrCtxt (grhsCtxt match_ctxt rhs) $
 229                                tcCheckRho rhs exp_ty'
 230                       ; return (GRHS guards' rhs') }
 231
 232         ; grhss' <- mappM (wrapLocM tc_grhs) grhss
 233         ; returnM (GRHSs grhss' []) }
 234 \end{code}
 235
 236
 237 \begin{code}
 238 tcThingWithSig :: TcSigmaType           -- Type signature
 239                -> (TcRhoType -> TcM r)  -- How to type check the thing inside
 240                -> Expected TcRhoType    -- Overall expected result type
 241                -> TcM (ExprCoFn, r)
 242 -- Used for expressions with a type signature, and for result type signatures
 243
 244 tcThingWithSig sig_ty thing_inside res_ty
 245   | not (isSigmaTy sig_ty)
 246   = thing_inside sig_ty         `thenM` \ result ->
 247     tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
 248     returnM (co_fn, result)
 249
 250   | otherwise   -- The signature has some outer foralls
 251   =     -- Must instantiate the outer for-alls of sig_tc_ty
 252         -- else we risk instantiating a ? res_ty to a forall-type
 253         -- which breaks the invariant that tcMonoExpr only returns phi-types
 254     tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
 255     tcInstCall InstSigOrigin sig_ty             `thenM` \ (inst_fn, _, inst_sig_ty) ->
 256     tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
 257     returnM (co_fn <.> inst_fn <.> gen_fn,  result)
 258         -- Note that we generalise, then instantiate. Ah well.
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{tcMatchPats}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268 \begin{code}
 269 tcMatchPats :: [LPat Name]
 270             -> [Expected TcSigmaType]   -- Pattern types
 271             -> Expected TcRhoType       -- Result type;
 272                                         -- used only to check existential escape
 273             -> TcM a
 274             -> TcM ([LPat TcId], a)
 275 -- Typecheck the patterns, extend the environment to bind the variables,
 276 -- do the thing inside, use any existentially-bound dictionaries to
 277 -- discharge parts of the returning LIE, and deal with pattern type
 278 -- signatures
 279
 280 tcMatchPats pats tys body_ty thing_inside
 281   = do  { (pats', ex_tvs, res) <- tcPats LamPat pats tys thing_inside
 282         ; tcCheckExistentialPat pats' ex_tvs tys body_ty
 283         ; returnM (pats', res) }
 284
 285 tcCheckExistentialPat :: [LPat TcId]            -- Patterns (just for error message)
 286                       -> [TcTyVar]              -- Existentially quantified tyvars bound by pattern
 287                       -> [Expected TcSigmaType] -- Types of the patterns
 288                       -> Expected TcRhoType     -- Type of the body of the match
 289                                                 -- Tyvars in either of these must not escape
 290                       -> TcM ()
 291         -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
 292         -- For example, we must reject this program:
 293         --      data C = forall a. C (a -> Int)
 294         --      f (C g) x = g x
 295         -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
 296
 297 tcCheckExistentialPat pats [] pat_tys body_ty
 298   = return ()   -- Short cut for case when there are no existentials
 299
 300 tcCheckExistentialPat pats ex_tvs pat_tys body_ty
 301   = do  { tys <- mapM readExpectedType (body_ty : pat_tys)
 302         ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $
 303           checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs }
 304 \end{code}
 305
 306
 307 %************************************************************************
 308 %*                                                                      *
 309 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 310 %*                                                                      *
 311 %************************************************************************
 312
 313 \begin{code}
 314 tcDoStmts :: HsStmtContext Name
 315           -> [LStmt Name]
 316           -> LHsExpr Name
 317           -> Expected TcRhoType
 318           -> TcM (HsExpr TcId)          -- Returns a HsDo
 319 tcDoStmts ListComp stmts body res_ty
 320   = do  { elt_ty <- zapToListTy res_ty
 321         ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
 322                              addErrCtxt (doBodyCtxt ListComp body) $
 323                              tcCheckRho body elt_ty
 324         ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 325
 326 tcDoStmts PArrComp stmts body res_ty
 327   = do  { [elt_ty] <- zapToTyConApp parrTyCon res_ty
 328         ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
 329                              addErrCtxt (doBodyCtxt PArrComp body) $
 330                              tcCheckRho body elt_ty
 331         ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
 332
 333 tcDoStmts DoExpr stmts body res_ty
 334   = do  { res_ty'   <- zapExpectedType res_ty liftedTypeKind
 335         ; (m_ty, _) <- unifyAppTy res_ty'
 336         ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
 337                              addErrCtxt (doBodyCtxt DoExpr body) $
 338                              tcCheckRho body res_ty'
 339         ; return (HsDo DoExpr stmts' body' res_ty') }
 340
 341 tcDoStmts cxt@(MDoExpr _) stmts body res_ty
 342   = do  { res_ty'   <- zapExpectedType res_ty liftedTypeKind
 343         ; (m_ty, _) <- unifyAppTy res_ty'
 344         ; let tc_rhs rhs = do   { (rhs', rhs_ty) <- tcInferRho rhs
 345                                 ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
 346                                 ; unifyTauTy m_ty n_ty
 347                                 ; return (rhs', pat_ty) }
 348
 349         ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
 350                              addErrCtxt (doBodyCtxt cxt body) $
 351                              tcCheckRho body res_ty'
 352
 353         ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
 354         ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
 355         ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
 356
 357 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 358 \end{code}
 359
 360
 361 %************************************************************************
 362 %*                                                                      *
 363 \subsection{tcStmts}
 364 %*                                                                      *
 365 %************************************************************************
 366
 367 \begin{code}
 368 type TcStmtChecker
 369   = forall thing.  HsStmtContext Name
 370                    -> Stmt Name
 371                    -> TcM thing
 372                    -> TcM (Stmt TcId, thing)
 373
 374 tcStmts :: HsStmtContext Name
 375         -> TcStmtChecker        -- NB: higher-rank type
 376         -> [LStmt Name]
 377         -> TcM thing
 378         -> TcM ([LStmt TcId], thing)
 379
 380 -- Note the higher-rank type.  stmt_chk is applied at different
 381 -- types in the equations for tcStmts
 382
 383 tcStmts ctxt stmt_chk [] thing_inside
 384   = do  { thing <- thing_inside
 385         ; return ([], thing) }
 386
 387 -- LetStmts are handled uniformly, regardless of context
 388 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
 389   = tcBindsAndThen      -- No error context, but a binding group is
 390         glue_binds      -- rather a large thing for an error context anyway
 391         binds
 392         (tcStmts ctxt stmt_chk stmts thing_inside)
 393   where
 394     glue_binds binds (stmts, thing) = (L loc (LetStmt [binds]) : stmts, thing)
 395
 396
 397 -- For the vanilla case, handle the location-setting part
 398 tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
 399   = do  { (stmt', (stmts', thing)) <-
 400                 setSrcSpan loc                  $
 401                 addErrCtxt (stmtCtxt ctxt stmt) $
 402                 stmt_chk ctxt stmt              $
 403                 popErrCtxt                      $
 404                 tcStmts ctxt stmt_chk stmts     $
 405                 thing_inside
 406         ; return (L loc stmt' : stmts', thing) }
 407
 408 --------------------------------
 409 --      Pattern guards
 410 tcGuardStmt :: TcType -> TcStmtChecker
 411 tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
 412   = do  { guard' <- tcCheckRho guard boolTy
 413         ; thing  <- thing_inside
 414         ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 415
 416 tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
 417   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 418         ; (pat', thing)  <- tcBindPat pat rhs_ty res_ty thing_inside
 419         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 420
 421 tcGuardStmt res_ty ctxt stmt thing_inside
 422   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
 423
 424
 425 --------------------------------
 426 --      List comprehensions and PArrays
 427
 428 tcLcStmt :: TyCon       -- The list/Parray type constructor ([] or PArray)
 429          -> TcType      -- The element type of the list or PArray
 430          -> TcStmtChecker
 431
 432 -- A generator, pat <- rhs
 433 tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
 434   = do  { (rhs', rhs_ty) <- tcInferRho rhs
 435         ; [pat_ty]       <- unifyTyConApp m_tc rhs_ty
 436         ; (pat', thing)  <- tcBindPat pat pat_ty elt_ty thing_inside
 437         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 438
 439 -- A boolean guard
 440 tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
 441   = do  { rhs'  <- tcCheckRho rhs boolTy
 442         ; thing <- thing_inside
 443         ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
 444
 445 -- A parallel set of comprehensions
 446 --      [ (g x, h x) | ... ; let g v = ...
 447 --                   | ... ; let h v = ... ]
 448 --
 449 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
 450 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 451 -- Similarly if we had an existential pattern match:
 452 --
 453 --      data T = forall a. Show a => C a
 454 --
 455 --      [ (show x, show y) | ... ; C x <- ...
 456 --                         | ... ; C y <- ... ]
 457 --
 458 -- Then we need the LIE from (show x, show y) to be simplified against
 459 -- the bindings for x and y.
 460 --
 461 -- It's difficult to do this in parallel, so we rely on the renamer to
 462 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
 463 -- So the binders of the first parallel group will be in scope in the second
 464 -- group.  But that's fine; there's no shadowing to worry about.
 465
 466 tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
 467   = do  { (pairs', thing) <- loop bndr_stmts_s
 468         ; return (ParStmt pairs', thing) }
 469   where
 470     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
 471     loop [] = do { thing <- thing_inside
 472                  ; return ([], thing) }
 473
 474     loop ((stmts, names) : pairs)
 475       = do { (stmts', (ids, pairs', thing))
 476                 <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
 477                    do { ids <- tcLookupLocalIds names
 478                       ; (pairs', thing) <- loop pairs
 479                       ; return (ids, pairs', thing) }
 480            ; return ( (stmts', ids) : pairs', thing ) }
 481
 482 tcLcStmt m_tc elt_ty ctxt stmt thing_inside
 483   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
 484
 485 --------------------------------
 486 --      Do-notation
 487 -- The main excitement here is dealing with rebindable syntax
 488
 489 tcDoStmt :: TcType              -- Monad type,  m
 490          -> TcType              -- Result type, m b
 491          -> TcStmtChecker
 492         -- BindStmt
 493 tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
 494   = do  {       -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
 495         ; (rhs', rhs_ty) <- tcInferRho rhs
 496                 -- We should use type *inference* for the RHS computations, becuase of GADTs.
 497                 --      do { pat <- rhs; <rest> }
 498                 -- is rather like
 499                 --      case rhs of { pat -> <rest> }
 500                 -- We do inference on rhs, so that information about its type can be refined
 501                 -- when type-checking the pattern.
 502
 503         ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
 504         ; unifyTauTy m_ty n_ty
 505         ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
 506
 507         ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
 508
 509         -- Rebindable syntax stuff
 510         ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
 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 res_ty)
 516         ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 517
 518
 519 tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
 520   = do  {       -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
 521           a_ty <- newTyFlexiVarTy liftedTypeKind
 522         ; let rhs_ty  = mkAppTy m_ty a_ty
 523               then_ty = mkFunTys [rhs_ty, res_ty] res_ty
 524         ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
 525         ; rhs' <- tcCheckSigma rhs rhs_ty
 526         ; thing <- thing_inside
 527         ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
 528
 529 tcDoStmt m_ty res_ty ctxt stmt thing_inside
 530   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 531
 532 --------------------------------
 533 --      Mdo-notation
 534 -- The distinctive features here are
 535 --      (a) RecStmts, and
 536 --      (b) no rebindable syntax
 537
 538 tcMDoStmt :: TcType             -- Result type, m b
 539           -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType))       -- RHS inference
 540           -> TcStmtChecker
 541 tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
 542   = do  { (rhs', pat_ty) <- tc_rhs rhs
 543         ; (pat', thing)  <- tcBindPat pat pat_ty res_ty thing_inside
 544         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 545
 546 tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
 547   = do  { (rhs', elt_ty) <- tc_rhs rhs
 548         ; thing          <- thing_inside
 549         ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
 550
 551 tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
 552   = do  { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
 553         ; let rec_ids = zipWith mkLocalId recNames rec_tys
 554         ; tcExtendIdEnv rec_ids                 $ do
 555         { (stmts', (later_ids, rec_rets))
 556                 <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
 557                         -- ToDo: res_ty not really right
 558                    do { rec_rets <- zipWithM tc_ret recNames rec_tys
 559                       ; later_ids <- tcLookupLocalIds laterNames
 560                       ; return (later_ids, rec_rets) }
 561
 562         ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
 563                 -- NB:  The rec_ids for the recursive things
 564                 --      already scope over this part. This binding may shadow
 565                 --      some of them with polymorphic things with the same Name
 566                 --      (see note [RecStmt] in HsExpr)
 567         ; lie_binds <- bindInstsOfLocalFuns lie later_ids
 568
 569         ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
 570         }}
 571   where
 572     -- Unify the types of the "final" Ids with those of "knot-tied" Ids
 573     tc_ret rec_name mono_ty
 574         = tcLookupId rec_name                           `thenM` \ poly_id ->
 575                 -- poly_id may have a polymorphic type
 576                 -- but mono_ty is just a monomorphic type variable
 577           tcSubExp (Check mono_ty) (idType poly_id)     `thenM` \ co_fn ->
 578           returnM (co_fn <$> HsVar poly_id)
 579
 580 tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
 581   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
 582
 583 -----------------
 584 tcBindPat :: LPat Name -> TcType
 585           -> TcType     -- Result type; used only to check existential escape
 586           -> TcM a
 587           -> TcM (LPat TcId, a)
 588 tcBindPat pat pat_ty res_ty thing_inside
 589   = do  { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
 590                                         (Check res_ty) thing_inside
 591         ; return (pat', thing) }
 592 \end{code}
 593
 594
 595 %************************************************************************
 596 %*                                                                      *
 597 \subsection{Errors and contexts}
 598 %*                                                                      *
 599 %************************************************************************
 600
 601 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 602 number of args are used in each equation.
 603
 604 \begin{code}
 605 sameNoOfArgs :: MatchGroup Name -> Bool
 606 sameNoOfArgs (MatchGroup matches _)
 607    = isSingleton (nub (map args_in_match matches))
 608   where
 609     args_in_match :: LMatch Name -> Int
 610     args_in_match (L _ (Match pats _ _)) = length pats
 611 \end{code}
 612
 613 \begin{code}
 614 varyingArgsErr name matches
 615   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 616
 617 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
 618                            4 (pprMatch ctxt match)
 619
 620 grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
 621                        4 (ppr rhs)
 622
 623 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
 624 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
 625                           4 (ppr body)
 626
 627 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
 628                         4 (ppr stmt)
 629
 630 sigPatCtxt bound_ids bound_tvs tys tidy_env
 631   =     -- tys is (body_ty : pat_tys)
 632     mapM zonkTcType tys         `thenM` \ tys' ->
 633     let
 634         (env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 635         (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
 636     in
 637     returnM (env1,
 638                  sep [ptext SLIT("When checking an existential match that binds"),
 639                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 640                       ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 641                       ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 642                 ])
 643   where
 644     show_ids = filter is_interesting bound_ids
 645     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 646
 647     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 648         -- Don't zonk the types so we get the separate, un-unified versions
 649 \end{code}