\begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
- matchCtxt,
- tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
- tcMatchPats,
- TcStmtCtxt(..), TcMatchCtxt(..)
+ tcMatchPats, matchCtxt, TcMatchCtxt(..),
+ tcStmts, tcDoStmts,
+ tcDoStmt, tcMDoStmt, tcGuardStmt,
+ tcThingWithSig
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho, tcMonoExpr )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcCheckRho, tcInferRho, tcMonoExpr, tcCheckSigma )
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
- ReboundNames, LPat,
- pprMatch, isDoExpr,
- pprMatchContext, pprStmtContext, pprStmtResultContext,
- collectPatsBinders, glueBindsOnGRHSs
+ LPat, pprMatch, isIrrefutableHsPat,
+ pprMatchContext, pprStmtContext, pprMatchRhsContext,
+ collectPatsBinders, glueBindsOnGRHSs, noSyntaxExpr
)
import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
import TcRnMonad
import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) )
-import Inst ( tcSyntaxName, tcInstCall )
+import Inst ( tcInstCall, newMethodFromName )
import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
tcExtendTyVarEnv )
import TcPat ( PatCtxt(..), tcPats )
-import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType, isRigidType )
+import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType )
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
- tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkTyConApp,
- liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy )
+ tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
+ liftedTypeKind, openTypeKind, mkFunTy, mkAppTy )
import TcBinds ( tcBindsAndThen )
import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
- unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
+ unifyTauTy, subFunTys, unifyTyConApp,
checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
- unifyAppTy )
+ unifyAppTy, zapToListTy, zapToTyConApp )
+import TcSimplify ( bindInstsOfLocalFuns )
import Name ( Name )
-import TysWiredIn ( boolTy, parrTyCon, listTyCon )
+import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
+import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
import Id ( idType, mkLocalId )
+import TyCon ( TyCon )
import CoreFVs ( idFreeTyVars )
import VarSet
-import Util ( isSingleton, notNull )
+import Util ( isSingleton )
import Outputable
-import SrcLoc ( Located(..), noLoc )
+import SrcLoc ( Located(..) )
import List ( nub )
\end{code}
lift_grhss co_fn (GRHSs grhss binds)
= GRHSs (map (fmap lift_grhs) grhss) binds
where
- lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
-
- lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
- lift_stmt stmt = stmt
+ lift_grhs (GRHS stmts rhs) = GRHS stmts (fmap (co_fn <$>) rhs)
-------------
tcGRHSs :: TcMatchCtxt -> GRHSs Name
-- f = \(x::forall a.a->a) -> <stuff>
-- This is a consequence of the fact that tcStmts takes a TcType,
-- not a Expected TcType, a decision we could revisit if necessary
-tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds) exp_ty
+tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
- returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [])
+ returnM (GRHSs [L loc1 (GRHS [] rhs')] [])
tcGRHSs ctxt (GRHSs grhss binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
- zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
- -- Even if there is only one guard, we zap the RHS type to
- -- a monotype. Reason: it makes tcStmts much easier,
- -- and even a one-armed guard has a notional second arm
- let
- stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
- sc_rhs = tcInferRho,
- sc_body = sc_body,
- sc_ty = exp_ty' }
- sc_body body = mc_body ctxt body (Check exp_ty')
-
- tc_grhs (GRHS guarded)
- = tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
- returnM (GRHS guarded')
- in
- mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' [])
+ do { exp_ty' <- zapExpectedType exp_ty openTypeKind
+ -- Even if there is only one guard, we zap the RHS type to
+ -- a monotype. Reason: it makes tcStmts much easier,
+ -- and even a one-armed guard has a notional second arm
+
+ ; let match_ctxt = mc_what ctxt
+ stmt_ctxt = PatGuard match_ctxt
+ tc_grhs (GRHS guards rhs)
+ = do { (guards', rhs')
+ <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
+ addErrCtxt (grhsCtxt match_ctxt rhs) $
+ tcCheckRho rhs exp_ty'
+ ; return (GRHS guards' rhs') }
+
+ ; grhss' <- mappM (wrapLocM tc_grhs) grhss
+ ; returnM (GRHSs grhss' []) }
\end{code}
-- signatures
tcMatchPats pats tys body_ty thing_inside
- = do { do_refinement <- can_refine body_ty
- ; (pats', ex_tvs, res) <- tcPats (LamPat do_refinement) pats tys thing_inside
+ = do { (pats', ex_tvs, res) <- tcPats LamPat pats tys thing_inside
; tcCheckExistentialPat pats' ex_tvs tys body_ty
; returnM (pats', res) }
- where
- -- Do GADT refinement if we are doing checking (not inference)
- -- and the body_ty is completely rigid
- -- ToDo: explain why
- can_refine (Infer _) = return False
- can_refine (Check ty) = isRigidType ty
tcCheckExistentialPat :: [LPat TcId] -- Patterns (just for error message)
-> [TcTyVar] -- Existentially quantified tyvars bound by pattern
\begin{code}
tcDoStmts :: HsStmtContext Name
- -> [LStmt Name] -> ReboundNames Name
- -> TcRhoType -- To keep it simple, we don't have an "expected" type here
- -> TcM ([LStmt TcId], ReboundNames TcId)
-tcDoStmts PArrComp stmts method_names res_ty
- = do { [elt_ty] <- unifyTyConApp parrTyCon res_ty
- ; stmts' <- tcComprehension PArrComp parrTyCon elt_ty stmts
- ; return (stmts', [{- unused -}]) }
-
-tcDoStmts ListComp stmts method_names res_ty
- = unifyListTy res_ty ` thenM` \ elt_ty ->
- tcComprehension ListComp listTyCon elt_ty stmts `thenM` \ stmts' ->
- returnM (stmts', [{- unused -}])
-
-tcDoStmts do_or_mdo stmts method_names res_ty
- = newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
- newTyFlexiVarTy liftedTypeKind `thenM` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
- let
- ctxt = SC { sc_what = do_or_mdo,
- sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
- ; rhs_elt_ty <- unifyAppTy m_ty rhs_ty
- ; return (rhs', rhs_elt_ty) },
- sc_body = \ body -> tcCheckRho body res_ty,
- sc_ty = res_ty }
- in
- tcStmts ctxt stmts `thenM` \ stmts' ->
-
- -- Build the then and zero methods in case we need them
- -- It's important that "then" and "return" appear just once in the final LIE,
- -- not only for typechecker efficiency, but also because otherwise during
- -- simplification we end up with silly stuff like
- -- then = case d of (t,r) -> t
- -- then = then
- -- where the second "then" sees that it already exists in the "available" stuff.
- mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
-
- returnM (stmts', methods)
-
-tcComprehension do_or_lc m_tycon elt_ty stmts
- = tcStmts ctxt stmts
- where
- ctxt = SC { sc_what = do_or_lc,
- sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [rhs_elt_ty] <- unifyTyConApp m_tycon rhs_ty
- ; return (rhs', rhs_elt_ty) },
- sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no m_tycon here!
- sc_ty = mkTyConApp m_tycon [elt_ty] }
+ -> [LStmt Name]
+ -> LHsExpr Name
+ -> Expected TcRhoType
+ -> TcM (HsExpr TcId) -- Returns a HsDo
+tcDoStmts ListComp stmts body res_ty
+ = do { elt_ty <- zapToListTy res_ty
+ ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
+ addErrCtxt (doBodyCtxt ListComp body) $
+ tcCheckRho body elt_ty
+ ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+
+tcDoStmts PArrComp stmts body res_ty
+ = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
+ ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
+ addErrCtxt (doBodyCtxt PArrComp body) $
+ tcCheckRho body elt_ty
+ ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
+
+tcDoStmts DoExpr stmts body res_ty
+ = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
+ ; (m_ty, _) <- unifyAppTy res_ty'
+ ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
+ addErrCtxt (doBodyCtxt DoExpr body) $
+ tcCheckRho body res_ty'
+ ; return (HsDo DoExpr stmts' body' res_ty') }
+
+tcDoStmts cxt@(MDoExpr _) stmts body res_ty
+ = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
+ ; (m_ty, _) <- unifyAppTy res_ty'
+ ; let tc_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
+ ; unifyTauTy m_ty n_ty
+ ; return (rhs', pat_ty) }
+
+ ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
+ addErrCtxt (doBodyCtxt cxt body) $
+ tcCheckRho body res_ty'
+
+ ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
+ ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
+ ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
+
+tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
\end{code}
%* *
%************************************************************************
-Typechecking statements is rendered a bit tricky by parallel list comprehensions:
-
- [ (g x, h x) | ... ; let g v = ...
- | ... ; let h v = ... ]
-
-It's possible that g,h are overloaded, so we need to feed the LIE from the
-(g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
-Similarly if we had an existential pattern match:
-
- data T = forall a. Show a => C a
-
- [ (show x, show y) | ... ; C x <- ...
- | ... ; C y <- ... ]
-
-Then we need the LIE from (show x, show y) to be simplified against
-the bindings for x and y.
-
-It's difficult to do this in parallel, so we rely on the renamer to
-ensure that g,h and x,y don't duplicate, and simply grow the environment.
-So the binders of the first parallel group will be in scope in the second
-group. But that's fine; there's no shadowing to worry about.
-
\begin{code}
-tcStmts ctxt stmts
- = ASSERT( notNull stmts )
- tcStmtsAndThen (:) ctxt stmts (returnM [])
-
-data TcStmtCtxt
- = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
- sc_rhs :: LHsExpr Name -> TcM (LHsExpr TcId, TcType), -- Type inference for RHS computations
- sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation
- sc_ty :: TcType } -- Return type; used *only* to check
- -- for escape in existential patterns
- -- We use type *inference* for the RHS computations, becuase of GADTs.
- -- do { pat <- rhs; <rest> }
- -- is rather like
- -- case rhs of { pat -> <rest> }
- -- We do inference on rhs, so that information about its type can be refined
- -- when type-checking the pattern.
-
-tcStmtsAndThen
- :: (LStmt TcId -> thing -> thing) -- Combiner
- -> TcStmtCtxt
+type TcStmtChecker
+ = forall thing. HsStmtContext Name
+ -> Stmt Name
+ -> TcM thing
+ -> TcM (Stmt TcId, thing)
+
+tcStmts :: HsStmtContext Name
+ -> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
-> TcM thing
- -> TcM thing
+ -> TcM ([LStmt TcId], thing)
- -- Base case
-tcStmtsAndThen combine ctxt [] thing_inside
- = thing_inside
+-- Note the higher-rank type. stmt_chk is applied at different
+-- types in the equations for tcStmts
-tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
- = tcStmtAndThen combine ctxt stmt $
- tcStmtsAndThen combine ctxt stmts $
- thing_inside
+tcStmts ctxt stmt_chk [] thing_inside
+ = do { thing <- thing_inside
+ ; return ([], thing) }
- -- LetStmt
-tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside
- = tcBindsAndThen -- No error context, but a binding group is
- (glue_binds combine) -- rather a large thing for an error context anyway
+-- LetStmts are handled uniformly, regardless of context
+tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
+ = tcBindsAndThen -- No error context, but a binding group is
+ glue_binds -- rather a large thing for an error context anyway
binds
- thing_inside
-
- -- BindStmt
-tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
- = setSrcSpan src_loc $
- addErrCtxt (stmtCtxt ctxt stmt) $
- do { (exp', pat_ty) <- sc_rhs ctxt exp
- ; ([pat'], thing) <- tcMatchPats [pat] [Check pat_ty] (Check (sc_ty ctxt)) $
- popErrCtxt thing_inside
- ; return (combine (L src_loc (BindStmt pat' exp')) thing) }
-
- -- ExprStmt
-tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
- = setSrcSpan src_loc (
- addErrCtxt (stmtCtxt ctxt stmt) $
- if isDoExpr (sc_what ctxt)
- then -- do or mdo; the expression is a computation
- sc_rhs ctxt exp `thenM` \ (exp', exp_ty) ->
- returnM (L src_loc (ExprStmt exp' exp_ty))
- else -- List comprehensions, pattern guards; expression is a boolean
- tcCheckRho exp boolTy `thenM` \ exp' ->
- returnM (L src_loc (ExprStmt exp' boolTy))
- ) `thenM` \ stmt' ->
-
- thing_inside `thenM` \ thing ->
- returnM (combine stmt' thing)
-
-
- -- ParStmt
-tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
- = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
- returnM (combine (L src_loc (ParStmt pairs')) thing)
+ (tcStmts ctxt stmt_chk stmts thing_inside)
where
- loop [] = thing_inside `thenM` \ thing ->
- returnM ([], thing)
-
- loop ((stmts, bndrs) : pairs)
- = tcStmtsAndThen combine_par ctxt stmts $
- -- Notice we pass on ctxt; the result type is used only
- -- to get escaping type variables for checkExistentialPat
- tcLookupLocalIds bndrs `thenM` \ bndrs' ->
- loop pairs `thenM` \ (pairs', thing) ->
- returnM (([], bndrs') : pairs', thing)
-
- combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
-
- -- RecStmt
-tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
--- gaw 2004
- = newTyFlexiVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
- let
- rec_ids = zipWith mkLocalId recNames recTys
- in
- tcExtendIdEnv rec_ids $
- tcStmtsAndThen combine_rec ctxt stmts (
- zipWithM tc_ret recNames recTys `thenM` \ rec_rets ->
- tcLookupLocalIds laterNames `thenM` \ later_ids ->
- returnM ([], (later_ids, rec_rets))
- ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
-
- tcExtendIdEnv later_ids $
- -- NB: The rec_ids for the recursive things
- -- already scope over this part
- thing_inside `thenM` \ thing ->
+ glue_binds binds (stmts, thing) = (L loc (LetStmt [binds]) : stmts, thing)
+
+
+-- For the vanilla case, handle the location-setting part
+tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
+ = do { (stmt', (stmts', thing)) <-
+ setSrcSpan loc $
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ stmt_chk ctxt stmt $
+ popErrCtxt $
+ tcStmts ctxt stmt_chk stmts $
+ thing_inside
+ ; return (L loc stmt' : stmts', thing) }
+
+--------------------------------
+-- Pattern guards
+tcGuardStmt :: TcType -> TcStmtChecker
+tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
+ = do { guard' <- tcCheckRho guard boolTy
+ ; thing <- thing_inside
+ ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
+
+tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; (pat', thing) <- tcBindPat pat rhs_ty res_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcGuardStmt res_ty ctxt stmt thing_inside
+ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
+
+
+--------------------------------
+-- List comprehensions and PArrays
+
+tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
+ -> TcType -- The element type of the list or PArray
+ -> TcStmtChecker
+
+-- A generator, pat <- rhs
+tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp m_tc rhs_ty
+ ; (pat', thing) <- tcBindPat pat pat_ty elt_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+-- A boolean guard
+tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
+ = do { rhs' <- tcCheckRho rhs boolTy
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
+
+-- A parallel set of comprehensions
+-- [ (g x, h x) | ... ; let g v = ...
+-- | ... ; let h v = ... ]
+--
+-- It's possible that g,h are overloaded, so we need to feed the LIE from the
+-- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
+-- Similarly if we had an existential pattern match:
+--
+-- data T = forall a. Show a => C a
+--
+-- [ (show x, show y) | ... ; C x <- ...
+-- | ... ; C y <- ... ]
+--
+-- Then we need the LIE from (show x, show y) to be simplified against
+-- the bindings for x and y.
+--
+-- It's difficult to do this in parallel, so we rely on the renamer to
+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
+-- So the binders of the first parallel group will be in scope in the second
+-- group. But that's fine; there's no shadowing to worry about.
+
+tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
+ = do { (pairs', thing) <- loop bndr_stmts_s
+ ; return (ParStmt pairs', thing) }
+ where
+ -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop [] = do { thing <- thing_inside
+ ; return ([], thing) }
+
+ loop ((stmts, names) : pairs)
+ = do { (stmts', (ids, pairs', thing))
+ <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
+ do { ids <- tcLookupLocalIds names
+ ; (pairs', thing) <- loop pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+tcLcStmt m_tc elt_ty ctxt stmt thing_inside
+ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+--------------------------------
+-- Do-notation
+-- The main excitement here is dealing with rebindable syntax
+
+tcDoStmt :: TcType -- Monad type, m
+ -> TcType -- Result type, m b
+ -> TcStmtChecker
+ -- BindStmt
+tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
+ = do { -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
+ ; (rhs', rhs_ty) <- tcInferRho rhs
+ -- We should use type *inference* for the RHS computations, becuase of GADTs.
+ -- do { pat <- rhs; <rest> }
+ -- is rather like
+ -- case rhs of { pat -> <rest> }
+ -- We do inference on rhs, so that information about its type can be refined
+ -- when type-checking the pattern.
+
+ ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
+ ; unifyTauTy m_ty n_ty
+ ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
+
+ ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+
+ -- Rebindable syntax stuff
+ ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
+ -- If (but only if) the pattern can fail,
+ -- typecheck the 'fail' operator
+ ; fail_op' <- if isIrrefutableHsPat pat'
+ then return noSyntaxExpr
+ else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
+ ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+
+
+tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
+ = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
+ a_ty <- newTyFlexiVarTy liftedTypeKind
+ ; let rhs_ty = mkAppTy m_ty a_ty
+ then_ty = mkFunTys [rhs_ty, res_ty] res_ty
+ ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
+ ; rhs' <- tcCheckSigma rhs rhs_ty
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+
+tcDoStmt m_ty res_ty ctxt stmt thing_inside
+ = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
+
+--------------------------------
+-- Mdo-notation
+-- The distinctive features here are
+-- (a) RecStmts, and
+-- (b) no rebindable syntax
+
+tcMDoStmt :: TcType -- Result type, m b
+ -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
+ -> TcStmtChecker
+tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
+ = do { (rhs', pat_ty) <- tc_rhs rhs
+ ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
+ = do { (rhs', elt_ty) <- tc_rhs rhs
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
+
+tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
+ = do { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
+ ; let rec_ids = zipWith mkLocalId recNames rec_tys
+ ; tcExtendIdEnv rec_ids $ do
+ { (stmts', (later_ids, rec_rets))
+ <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
+ -- ToDo: res_ty not really right
+ do { rec_rets <- zipWithM tc_ret recNames rec_tys
+ ; later_ids <- tcLookupLocalIds laterNames
+ ; return (later_ids, rec_rets) }
+
+ ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part. This binding may shadow
+ -- some of them with polymorphic things with the same Name
+ -- (see note [RecStmt] in HsExpr)
+ ; lie_binds <- bindInstsOfLocalFuns lie later_ids
- returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing)
+ ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
+ }}
where
- combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
-
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
tc_ret rec_name mono_ty
= tcLookupId rec_name `thenM` \ poly_id ->
-- poly_id may have a polymorphic type
-- but mono_ty is just a monomorphic type variable
tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
- returnM (L src_loc (co_fn <$> HsVar poly_id))
-
- -- Result statements
-tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside
- = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
- thing_inside `thenM` \ thing ->
- returnM (combine (L src_loc (ResultStmt exp')) thing)
-
-
-------------------------------
-glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing
- -- ToDo: fix the noLoc
+ returnM (co_fn <$> HsVar poly_id)
+
+tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
+ = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
+
+-----------------
+tcBindPat :: LPat Name -> TcType
+ -> TcType -- Result type; used only to check existential escape
+ -> TcM a
+ -> TcM (LPat TcId, a)
+tcBindPat pat pat_ty res_ty thing_inside
+ = do { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
+ (Check res_ty) thing_inside
+ ; return (pat', thing) }
\end{code}
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
- 4 (pprMatch ctxt match)
+matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
+ 4 (pprMatch ctxt match)
+
+grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
+ 4 (ppr rhs)
+
+doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
+doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
+ 4 (ppr body)
-stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
- where
- pp_ctxt = case stmt of
- ResultStmt _ -> pprStmtResultContext
- other -> pprStmtContext
+stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
+ 4 (ppr stmt)
sigPatCtxt bound_ids bound_tvs tys tidy_env
= -- tys is (body_ty : pat_tys)
projects / ghc-hetmet.git / blobdiff