module TcExpr ( tcExpr ) where
-import Ubiq
+IMP_Ubiq()
-import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
+import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
- irrefutablePat, collectPatBinders )
-import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
- RenamedStmt(..), RenamedRecordBinds(..),
+ failureFreePat, collectPatBinders )
+import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
+ SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
RnName{-instance Outputable-}
)
-import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
- TcIdOcc(..), TcRecordBinds(..),
+import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
+ TcIdOcc(..), SYN_IE(TcRecordBinds),
mkHsTyApp
)
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
- LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
+ SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars
+ tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
+ tcExtendGlobalTyVars
)
+import SpecEnv ( SpecEnv )
import TcMatches ( tcMatchesCase, tcMatch )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
-import TcType ( TcType(..), TcMaybe(..),
- tcInstId, tcInstType, tcInstTheta, tcInstTyVars,
+import TcType ( SYN_IE(TcType), TcMaybe(..),
+ tcInstId, tcInstType, tcInstSigTcType,
+ tcInstSigType, tcInstTcType, tcInstTheta,
newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
-import Class ( Class(..), classSig )
+import Class ( SYN_IE(Class), classSig )
import FieldLabel ( fieldLabelName )
-import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
+import Id ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
+import GenSpecEtc ( checkSigTyVars )
import Name ( Name{-instance Eq-} )
-import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
+import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
getTyVar_maybe, getFunTy_maybe, instantiateTy,
splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
getAppDataTyCon, maybeAppDataTyCon
)
-import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
+import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy
+ floatPrimTy, addrPrimTy, realWorldTy
)
import TysWiredIn ( addrTy,
boolTy, charTy, stringTy, mkListTy,
- mkTupleTy, mkPrimIoTy
+ mkTupleTy, mkPrimIoTy, stDataCon
)
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- monadClassKey, monadZeroClassKey
+ thenMClassOpKey, zeroClassOpKey
)
---import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
tcAddErrCtxt (sectionRAppCtxt in_expr) $
- unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
+ unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty `thenTc_`
returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
\end{code}
mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (CCall lbl args' may_gc is_asm result_ty,
+ returnTc (HsCon stDataCon [realWorldTy, result_ty] [CCall lbl args' may_gc is_asm result_ty],
+ -- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
mkPrimIoTy result_ty)
\end{code}
tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
tcAddErrCtxt (predCtxt pred) (
- unifyTauTy predTy boolTy
+ unifyTauTy boolTy predTy
) `thenTc_`
tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
\end{code}
\begin{code}
-tcExpr (HsDo stmts src_loc)
- = -- get the Monad and MonadZero classes
- -- create type consisting of a fresh monad tyvar
- tcAddSrcLoc src_loc $
- newTyVarTy monadKind `thenNF_Tc` \ m ->
- tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
-
- -- create dictionaries for monad and possibly monadzero
- (if monad then
- tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
- newDicts DoOrigin [(monadClass, m)]
- else
- returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
- ) `thenNF_Tc` \ (m_lie, [m_id]) ->
- (if mzero then
- tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
- newDicts DoOrigin [(monadZeroClass, m)]
- else
- returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
- ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
-
- returnTc (HsDoOut stmts' m_id mz_id src_loc,
- lie `plusLIE` m_lie `plusLIE` mz_lie,
- do_ty)
- where
- monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
+tcExpr expr@(HsDo stmts src_loc)
+ = tcDoStmts stmts src_loc
\end{code}
\begin{code}
-- Check that the field names are plausible
zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
let
- (tycon, inst_tys, data_cons) = _trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
+ (tycon, inst_tys, data_cons) = --trace "TcExpr.getAppDataTyCon" $
+ getAppDataTyCon record_ty'
-- The record binds are non-empty (syntax); so at least one field
-- label will have been unified with record_ty by tcRecordBinds;
-- field labels must be of data type; hencd the getAppDataTyCon must succeed.
-- Check the tau-type part
tcSetErrCtxt (exprSigCtxt in_expr) $
- tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
+ tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
- unifyTauTy tau_ty sig_tau' `thenTc_`
+ unifyTauTy sig_tau' tau_ty `thenTc_`
-- Check the type variables of the signature
checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
-- of instantiating a function involving rank-2 polymorphism, so there
-- isn't any danger of using the same tyvars twice
-- The argument type shouldn't be overloaded type (hence ASSERT)
+
+ -- To ensure that the forall'd type variables don't get unified with each
+ -- other or any other types, we make fresh *signature* type variables
+ -- and unify them with the tyvars.
+ tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
let
- (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
+ (sig_theta, sig_tau) = splitRhoTy sig_rho
in
- ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
-
+ ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
+
-- Type-check the arg and unify with expected type
tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
- unifyTauTy expected_tau actual_arg_ty `thenTc_` (
+ unifyTauTy sig_tau actual_arg_ty `thenTc_`
-- Check that the arg_tyvars havn't been constrained
-- The interesting bit here is that we must include the free variables
-- So now s' isn't unconstrained because it's linked to a.
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
- tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
- tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
- checkSigTyVarsGivenGlobals
- (env_tyvars `unionTyVarSets` free_tyvars)
- expected_tyvars expected_tau `thenTc_`
-
- -- Check that there's no overloading involved
- -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
- -- but which, on simplification, don't actually need a dictionary involving
- -- the tyvar. So we have to do a proper simplification right here.
- tcSimplifyRank2 (mkTyVarSet expected_tyvars)
- lie_arg `thenTc` \ (free_insts, inst_binds) ->
-
- -- This HsLet binds any Insts which came out of the simplification.
- -- It's a bit out of place here, but using AbsBind involves inventing
- -- a couple of new names which seems worse.
- returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
+
+ tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
+ tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
+ checkSigTyVars sig_tyvars sig_tau
+ ) `thenTc_`
+
+ -- Check that there's no overloading involved
+ -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
+ -- but which, on simplification, don't actually need a dictionary involving
+ -- the tyvar. So we have to do a proper simplification right here.
+ tcSimplifyRank2 (mkTyVarSet sig_tyvars)
+ lie_arg `thenTc` \ (free_insts, inst_binds) ->
+
+ -- This HsLet binds any Insts which came out of the simplification.
+ -- It's a bit out of place here, but using AbsBind involves inventing
+ -- a couple of new names which seems worse.
+ returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
)
where
= -- Look up the Id and instantiate its type
tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
- (case maybe_local of
- Just tc_id -> let
- (tyvars, rho) = splitForAllTy (idType tc_id)
- in
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) ->
- let
- rho' = instantiateTy tenv rho
- in
- returnNF_Tc (TcId tc_id, arg_tys', rho')
-
- Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
- let
- (tyvars, rho) = splitForAllTy (idType id)
- in
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
- tcInstType tenv rho `thenNF_Tc` \ rho' ->
- returnNF_Tc (RealId id, arg_tys, rho')
-
- ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
-
- -- Is it overloaded?
- case splitRhoTy rho of
- ([], tau) -> -- Not overloaded, so just make a type application
- returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
-
- (theta, tau) -> -- Overloaded, so make a Method inst
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
- returnNF_Tc (HsVar meth_id, lie, tau)
-\end{code}
+ case maybe_local of
+ Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
+ let
+ (tyvars, rho) = splitForAllTy inst_ty
+ in
+ instantiate_it2 (RealId id) tyvars rho
+ where
+ -- The instantiate_it loop runs round instantiating the Id.
+ -- It has to be a loop because we are now prepared to entertain
+ -- types like
+ -- f:: forall a. Eq a => forall b. Baz b => tau
+ -- We want to instantiate this to
+ -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
+ instantiate_it tc_id_occ ty
+ = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
+ instantiate_it2 tc_id_occ tyvars rho
+
+ instantiate_it2 tc_id_occ tyvars rho
+ | null theta -- Is it overloaded?
+ = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+ | otherwise -- Yes, it's overloaded
+ = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+ tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
+ instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
+
+ where
+ (theta, tau) = splitRhoTy rho
+ arg_tys = mkTyVarTys tyvars
+\end{code}
%************************************************************************
%* *
-\subsection{@tcQuals@ typchecks list comprehension qualifiers}
+\subsection{@tcQuals@ typechecks list-comprehension qualifiers}
%* *
%************************************************************************
%************************************************************************
\begin{code}
-tcDoStmts :: Bool -- True => require a monad
- -> TcType s -- m
- -> [RenamedStmt]
- -> TcM s (([TcStmt s],
- Bool, -- True => Monad
- Bool), -- True => MonadZero
- LIE s,
- TcType s)
-
-tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
- = tcAddSrcLoc src_loc $
- tcSetErrCtxt (stmtCtxt stmt) $
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- (if monad then
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty
- else
- returnTc ()
- ) `thenTc_`
- returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
-
-tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
- = tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (ExprStmt exp' src_loc, exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
- = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
-
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+tcDoStmts stmts src_loc
+ = -- get the Monad and MonadZero classes
+ -- create type consisting of a fresh monad tyvar
+ tcAddSrcLoc src_loc $
+ newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
+
+
+ -- Build the then and zero methods in case we need them
+ tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
+ tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ newMethod DoOrigin
+ (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
+ newMethod DoOrigin
+ (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
+
+ let
+ get_m_arg ty
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
+ unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
+ returnTc arg_ty
+
+ go [stmt@(ExprStmt exp src_loc)]
+ = tcAddSrcLoc src_loc $
+ tcSetErrCtxt (stmtCtxt stmt) $
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
+
+ go (stmt@(ExprStmt exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ get_m_arg exp_ty `thenTc` \ a ->
+ returnTc (a, exp', exp_lie)
+ )) `thenTc` \ (a, exp', exp_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (ExprStmtOut exp' src_loc a b : stmts',
+ exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
+ stmts_ty)
+
+ go (stmt@(BindStmt pat exp src_loc) : stmts)
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
-- See comments with tcListComp on GeneratorQual
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy a pat_ty `thenTc_`
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
- )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero || not failure_free),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts monad m (LetStmt binds : stmts)
- = tcBindsAndThen -- No error context, but a binding group is
- combine -- rather a large thing for an error context anyway
- binds
- (tcDoStmts monad m stmts)
- where
- combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
+ get_m_arg exp_ty `thenTc` \ a ->
+ unifyTauTy pat_ty a `thenTc_`
+ returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
+ )) `thenTc` \ (a, pat', exp', stmt_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
+ stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
+ (if failureFreePat pat' then emptyLIE else mz_lie),
+ stmts_ty)
+
+ go (LetStmt binds : stmts)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (go stmts)
+ where
+ combine binds' stmts' = LetStmt binds' : stmts'
+ in
+ go stmts `thenTc` \ (stmts', final_lie, final_ty) ->
+ returnTc (HsDoOut stmts' then_id zero_id src_loc,
+ final_lie,
+ final_ty)
\end{code}
Game plan for record bindings
projects / ghc-hetmet.git / blobdiff