X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=e2f1d0cd5ea2ba4fbacde26712fe6ba18e87d805;hp=4eb7b10450d06ff119314f4e509406b56d472a05;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=a346683b2ba5cc87a0db27eb1422158611327c54 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 4eb7b10..e2f1d0c 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -21,8 +21,8 @@ import qualified DsMeta #endif import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsCoerce, - mkHsApp ) + HsMatchContext(..), HsRecordBinds, mkHsWrap, hsExplicitTvs, + mkHsApp, mkLHsWrap ) import TcHsSyn ( hsLitType ) import TcRnMonad import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType, @@ -32,7 +32,7 @@ import BasicTypes ( Arity, isMarkedStrict ) import Inst ( newMethodFromName, newIPDict, instCall, newMethodWithGivenTy, instStupidTheta ) import TcBinds ( tcLocalBinds ) -import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField ) +import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField, tcExtendTyVarEnv2 ) import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody, TcMatchCtxt(..) ) @@ -45,14 +45,14 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst, mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe, - isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, + isSigmaTy, mkFunTy, mkTyConApp, exactTyVarsOfType, exactTyVarsOfTypes, zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar ) import {- Kind parts of -} Type ( argTypeKind ) -import Id ( Id, idType, recordSelectorFieldLabel, +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, @@ -76,7 +76,7 @@ import PrimOp ( tagToEnumKey ) import DynFlags import StaticFlags ( opt_NoMethodSharing ) import HscTypes ( TyThing(..) ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc ) import Util import ListSetOps ( assocMaybe ) import Maybes ( catMaybes ) @@ -111,10 +111,10 @@ tcPolyExpr expr res_ty tcPolyExprNC expr res_ty | isSigmaTy res_ty - = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr) + = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr) -- Note the recursive call to tcPolyExpr, because the -- type may have multiple layers of for-alls - ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) } + ; return (mkLHsWrap gen_fn expr') } | otherwise = tcMonoExpr expr res_ty @@ -190,7 +190,7 @@ tcExpr (HsIPVar ip) res_ty ; co_fn <- tcSubExp ip_ty res_ty ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty ; extendLIE inst - ; return (mkHsCoerce co_fn (HsIPVar ip')) } + ; return (mkHsWrap co_fn (HsIPVar ip')) } tcExpr (HsApp e1 e2) res_ty = go e1 [e2] @@ -204,13 +204,18 @@ tcExpr (HsApp e1 e2) res_ty tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty - ; return (mkHsCoerce co_fn (HsLam match')) } + ; return (mkHsWrap co_fn (HsLam match')) } tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - ; expr' <- tcPolyExpr expr sig_tc_ty + + -- Remember to extend the lexical type-variable environment + ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty -> + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + tcPolyExprNC expr res_ty) + ; co_fn <- tcSubExp sig_tc_ty res_ty - ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) } + ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } tcExpr (HsType ty) res_ty = failWithTc (text "Can't handle type argument:" <+> ppr ty) @@ -256,7 +261,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' -> tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) } + ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) } where doc = ptext SLIT("The section") <+> quotes (ppr in_expr) <+> ptext SLIT("takes one argument") @@ -496,7 +501,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty instStupidTheta RecordUpdOrigin theta' `thenM_` -- Phew! - returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) + returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) \end{code} @@ -686,7 +691,7 @@ tcIdApp fun_name n_args arg_checker res_ty -- tcFun work nicely for OpApp and Sections too ; fun' <- instFun orig fun res_subst tv_theta_prs ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn - ; return (mkHsCoerce co_fn' fun', args') } + ; return (mkHsWrap co_fn' fun', args') } \end{code} Note [Silly type synonyms in smart-app] @@ -729,7 +734,7 @@ tcId orig fun_name res_ty -- And pack up the results ; fun' <- instFun orig fun res_subst tv_theta_prs - ; return (mkHsCoerce co_fn fun') } + ; return (mkHsWrap co_fn fun') } -- Note [Push result type in] -- @@ -794,21 +799,11 @@ instFun orig fun subst tv_theta_prs go _ fun ((tys, theta) : prs) = do { co_fn <- instCall orig tys theta - ; go False (HsCoerce co_fn fun) prs } + ; go False (HsWrap co_fn fun) prs } - -- Hack Alert (want_method_inst)! -- See Note [No method sharing] - -- If f :: (%x :: T) => Int -> Int - -- Then if we have two separate calls, (f 3, f 4), we cannot - -- make a method constraint that then gets shared, thus: - -- let m = f %x in (m 3, m 4) - -- because that loses the linearity of the constraint. - -- The simplest thing to do is never to construct a method constraint - -- in the first place that has a linear implicit parameter in it. - want_method_inst theta = not (null theta) -- Overloaded - && not (any isLinearPred theta) -- Not linear + want_method_inst theta = not (null theta) -- Overloaded && not opt_NoMethodSharing - -- See Note [No method sharing] below \end{code} Note [Multiple instantiation] @@ -951,7 +946,7 @@ lookupFun orig id_name -> do { thLocalId orig id ty lvl ; case mb_co of Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars - Just co -> return (mkHsCoerce co (HsVar id), ty) } + Just co -> return (mkHsWrap co (HsVar id), ty) } other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) }