X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=86522ad04548a307ce332a1b409de15346a64d63;hb=8a86866e9e382c1d4d06cad722ddbe965d09997c;hp=464ec76399de3116d2021d1affadcdc6c9fbf14b;hpb=3c58c25b1b99143c0ac03510423a95bc3bd41aa2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 464ec76..86522ad 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -21,7 +21,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, - lookupInst, lookupSimpleInst, LookupInstResult(..), + lookupInst, LookupInstResult(..), isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -39,19 +39,20 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcExpr ) 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 ) +import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType, 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, @@ -61,20 +62,18 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, 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 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(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames( fromIntegerName, fromRationalName, rationalTyConName ) -import Util ( equalLength ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import Outputable @@ -258,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 -> @@ -266,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 @@ -324,23 +323,14 @@ newMethodWithGivenTy orig id tys theta tau -- to simplify Insts tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst - -- Instantiate the specified class op, but *only* with the main - -- class dictionary. For example, given 'op' defined thus: - -- class Foo a where - -- op :: (?x :: String) => a -> a - -- (tcInstClassOp op T) should return an Inst with type - -- (?x :: String) => T -> T - -- That is, the class-op's context is still there. - -- This is really important in the use of tcInstClassOp in TcClassDcls.mkMethodBind tcInstClassOp inst_loc sel_id tys = let (tyvars,rho) = tcSplitForAllTys (idType sel_id) - rho_ty = substTyWith tyvars tys rho - (pred,tau) = tcSplitMethodTy rho_ty - -- Split off exactly one predicate (see the example above) + rho_ty = ASSERT( length tyvars == length tys ) + substTyWith tyvars tys rho + (preds,tau) = tcSplitPhiTy rho_ty in - ASSERT( isClassPred pred ) - newMethod inst_loc sel_id tys [pred] tau + newMethod inst_loc sel_id tys preds tau --------------------------- newMethod inst_loc id tys theta tau @@ -363,7 +353,13 @@ newOverloadedLit :: InstOrigin -> HsOverLit -> TcType -> TcM TcExpr -newOverloadedLit orig lit@(HsIntegral i fi) expected_ty +newOverloadedLit orig lit expected_ty + = 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 + new_over_lit orig lit expected_ty + +new_over_lit 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 @@ -376,7 +372,7 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty | otherwise = newLitInst orig lit expected_ty -newOverloadedLit orig lit@(HsFractional r fr) expected_ty +new_over_lit 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 -> @@ -391,9 +387,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 @@ -481,7 +474,7 @@ pprInsts insts = parens (sep (punctuate comma (map pprInst insts))) pprInstsInFull insts = vcat (map go insts) where - go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst) + go inst = sep [quotes (ppr inst), nest 2 (pprInstLoc (instLoc inst))] pprInst (LitInst u lit ty loc) = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u] @@ -514,11 +507,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} @@ -541,7 +534,7 @@ lookupInst :: Inst -> TcM (LookupInstResult s) -- Dictionaries -lookupInst dict@(Dict _ (ClassP clas tys) loc) +lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) = getDOpts `thenM` \ dflags -> tcGetInstEnv `thenM` \ inst_env -> case lookupInstEnv dflags inst_env clas tys of @@ -552,6 +545,10 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc) -- instance C X a => D X where ... -- (presumably there's a functional dependency in class C) -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. + getStage `thenM` \ use_stage -> + checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + (topIdLvl dfun_id) use_stage `thenM_` + traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) mk_ty_arg tv = case lookupSubstEnv tenv tv of @@ -617,28 +614,6 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) \end{code} -There is a second, simpler interface, when you want an instance of a -class at a given nullary type constructor. It just returns the -appropriate dictionary if it exists. It is used only when resolving -ambiguous dictionaries. - -\begin{code} -lookupSimpleInst :: Class - -> [Type] -- Look up (c,t) - -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s - -lookupSimpleInst clas tys - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - case lookupInstEnv dflags inst_env clas tys of - FoundInst tenv dfun - -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) - where - (_, rho) = tcSplitForAllTys (idType dfun) - (theta,_) = tcSplitPhiTy rho - - other -> returnM Nothing -\end{code} %************************************************************************