X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=61bfd6018abc1b76481140600f17dc47fa8b2b3c;hb=dbaa3bb30eaf9d806357e41435dab32695c47842;hp=cd189a5475862c1b3b7e99d7ad486aac00957d84;hpb=115f0fae2f782836550a9419f739fd29c09e4f1b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index cd189a5..61bfd60 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -15,7 +15,8 @@ module Inst ( newDictsFromOld, newDicts, cloneDict, newOverloadedLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, - tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName, + tcInstClassOp, tcInstCall, tcInstDataCon, + tcSyntaxName, tcStdSyntaxName, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, @@ -26,7 +27,7 @@ module Inst ( isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, isTyVarDict, isStdClassTyVarDict, isMethodFor, - instBindingRequired, instCanBeGeneralised, + instBindingRequired, zonkInst, zonkInsts, instToId, instName, @@ -36,38 +37,38 @@ module Inst ( #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcExpr ) +import {-# SOURCE #-} TcExpr( tcCheckSigma ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) -import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr, - mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId +import TcHsSyn ( TcExpr, TcId, TcIdSet, + mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, + mkCoercion, ExprCoFn ) import TcRnMonad import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) -import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, +import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv), + SourceType(..), PredType, TyVarDetails(VanillaTv), tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, - tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp, + tcSplitPhiTy, mkGenTyConApp, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, - isClassPred, isTyVarClassPred, isLinearPred, predHasFDs, + isClassPred, isTyVarClassPred, isLinearPred, getClassPredTys, getClassPredTys_maybe, mkPredName, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) -import Class ( Class ) import DataCon ( DataCon,dataConSig ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) -import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) +import PrelInfo ( isStandardClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName ) import PprType ( pprPred, pprParendType ) -import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst ) +import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) @@ -101,11 +102,14 @@ dictPred inst = pprPanic "dictPred" (ppr inst) getDictClassTys (Dict _ pred _) = getClassPredTys pred -- fdPredsOfInst is used to get predicates that contain functional --- dependencies; i.e. should participate in improvement -fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred] - | otherwise = [] -fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta -fdPredsOfInst other = [] +-- dependencies *or* might do so. The "might do" part is because +-- a constraint (C a b) might have a superclass with FDs +-- Leaving these in is really important for the call to fdPredsOfInsts +-- in TcSimplify.inferLoop, because the result is fed to 'grow', +-- which is supposed to be conservative +fdPredsOfInst (Dict _ pred _) = [pred] +fdPredsOfInst (Method _ _ _ theta _ _) = theta +fdPredsOfInst other = [] -- LitInsts etc fdPredsOfInsts :: [Inst] -> [PredType] fdPredsOfInsts insts = concatMap fdPredsOfInst insts @@ -190,10 +194,6 @@ must be witnessed by an actual binding; the second tells whether an instBindingRequired :: Inst -> Bool instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas) instBindingRequired other = True - -instCanBeGeneralised :: Inst -> Bool -instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas) -instCanBeGeneralised other = True \end{code} @@ -257,7 +257,7 @@ newIPDict orig ip_name ty \begin{code} -tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType) +tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType) tcInstCall orig fun_ty -- fun_ty is usually a sigma-type = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) -> newDicts orig theta `thenM` \ dicts -> @@ -265,7 +265,7 @@ tcInstCall orig fun_ty -- fun_ty is usually a sigma-type let inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts) in - returnM (inst_fn, tau) + returnM (mkCoercion inst_fn, tau) tcInstDataCon :: InstOrigin -> DataCon -> TcM ([TcType], -- Types to instantiate at @@ -357,7 +357,7 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty | fi /= fromIntegerName -- Do not generate a LitInst for rebindable -- syntax. Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify - = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) -> + = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> returnM (HsApp expr (HsLit (HsInteger i))) | Just expr <- shortCutIntLit i expected_ty @@ -368,8 +368,8 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty newOverloadedLit orig lit@(HsFractional r fr) expected_ty | fr /= fromRationalName -- c.f. HsIntegral case - = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) -> - mkRatLit r `thenM` \ rat_lit -> + = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) -> + mkRatLit r `thenM` \ rat_lit -> returnM (HsApp expr rat_lit) | Just expr <- shortCutFracLit r expected_ty @@ -381,9 +381,6 @@ newOverloadedLit orig lit@(HsFractional r fr) expected_ty newLitInst orig lit expected_ty = getInstLoc orig `thenM` \ loc -> newUnique `thenM` \ new_uniq -> - zapToType expected_ty `thenM_` - -- The expected type might be a 'hole' type variable, - -- in which case we must zap it to an ordinary type variable let lit_inst = LitInst lit_id lit expected_ty loc lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty @@ -504,11 +501,11 @@ tidyMoreInsts env insts tidyInsts :: [Inst] -> (TidyEnv, [Inst]) tidyInsts insts = tidyMoreInsts emptyTidyEnv insts -showLIE :: String -> TcM () -- Debugging +showLIE :: SDoc -> TcM () -- Debugging showLIE str = do { lie_var <- getLIEVar ; lie <- readMutVar lie_var ; - traceTc (text str <+> pprInstsInFull (lieToList lie)) } + traceTc (str <+> pprInstsInFull (lieToList lie)) } \end{code} @@ -645,27 +642,37 @@ just use the expression inline. \begin{code} tcSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at - -> Name -> Name -- (Standard name, user name) - -> TcM (TcExpr, TcType) -- Suitable expression with its type + -> (Name, HsExpr Name) -- (Standard name, user name) + -> TcM (Name, TcExpr) -- (Standard name, suitable expression) -- NB: tcSyntaxName calls tcExpr, and hence can do unification. -- So we do not call it from lookupInst, which is called from tcSimplify -tcSyntaxName orig ty std_nm user_nm +tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm - = newMethodFromName orig ty std_nm `thenM` \ id -> - returnM (HsVar id, idType id) + = tcStdSyntaxName orig ty std_nm - | otherwise +tcSyntaxName orig ty (std_nm, user_nm_expr) = tcLookupId std_nm `thenM` \ std_id -> let -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) tau1 = substTyWith [tv] [ty] tau + -- Actually, the "tau-type" might be a sigma-type in the + -- case of locally-polymorphic methods. in - addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $ - tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn -> - returnM (user_fn, tau1) + addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $ + tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> + returnM (std_nm, expr) + +tcStdSyntaxName :: InstOrigin + -> TcType -- Type to instantiate it at + -> Name -- Standard name + -> TcM (Name, TcExpr) -- (Standard name, suitable expression) + +tcStdSyntaxName orig ty std_nm + = newMethodFromName orig ty std_nm `thenM` \ id -> + returnM (std_nm, HsVar id) syntaxNameCtxt name orig ty tidy_env = getInstLoc orig `thenM` \ inst_loc ->