X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=9c59b43d7414cdc433afd980693c0168c7e20e09;hp=11f63656d1b57faca47eeb7bac14afa0a9ce702d;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 11f6365..9c59b43 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -15,38 +15,40 @@ import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, PolyType, failureFreePat, collectPatBinders ) -import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), - RenamedStmt(..), RenamedRecordBinds(..), +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, tcInstSigTyVars, +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 ( idType, dataConFieldLabels, dataConSig, Id(..), GenId ) +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, mkRhoTy, getTyVar_maybe, getFunTy_maybe, instantiateTy, @@ -54,13 +56,13 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, 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, @@ -68,7 +70,6 @@ import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromToClassOpKey, enumFromThenToClassOpKey, thenMClassOpKey, zeroClassOpKey ) ---import Name ( Name ) -- Instance import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) @@ -229,7 +230,7 @@ tcExpr in_expr@(SectionR op expr) 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} @@ -269,7 +270,8 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) 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} @@ -302,7 +304,7 @@ tcExpr (HsIf pred b1 b2 src_loc) tcExpr pred `thenTc` \ (pred',lie1,predTy) -> tcAddErrCtxt (predCtxt pred) ( - unifyTauTy predTy boolTy + unifyTauTy boolTy predTy ) `thenTc_` tcExpr b1 `thenTc` \ (b1',lie2,result_ty) -> @@ -375,7 +377,8 @@ tcExpr (RecordUpd record_expr rbinds) -- 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. @@ -468,7 +471,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) 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_` @@ -571,16 +574,15 @@ tcArg expected_arg_ty arg -- 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 - tcInstSigTyVars expected_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) -> - unifyTauTyLists (mkTyVarTys expected_tyvars) sig_tyvar_tys `thenTc_` + 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 @@ -593,22 +595,22 @@ tcArg expected_arg_ty arg -- 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) $ - checkSigTyVarsGivenGlobals - (tyVarsOfType expected_arg_ty) - 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 @@ -783,7 +785,7 @@ tcDoStmts stmts src_loc -- See comments with tcListComp on GeneratorQual get_m_arg exp_ty `thenTc` \ a -> - unifyTauTy a pat_ty `thenTc_` + 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) ->