X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FInst.lhs;h=cd189a5475862c1b3b7e99d7ad486aac00957d84;hb=81ca95c5d0bff83bc64a13b852822c19b3473616;hp=92d6aa3758a05865ea4e2198b7c3c981681a4daa;hpb=8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 92d6aa3..cd189a5 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -12,17 +12,16 @@ module Inst ( Inst, pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts, - newDictsFromOld, newDicts, cloneDict, - newMethod, newMethodFromName, newMethodWithGivenTy, - newMethodWith, newMethodAtLoc, + newDictsFromOld, newDicts, cloneDict, newOverloadedLit, newIPDict, - tcInstCall, tcInstDataCon, tcSyntaxName, + newMethod, newMethodFromName, newMethodWithGivenTy, + tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, - lookupInst, lookupSimpleInst, LookupInstResult(..), + lookupInst, LookupInstResult(..), isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -32,7 +31,7 @@ module Inst ( zonkInst, zonkInsts, instToId, instName, - InstOrigin(..), InstLoc, pprInstLoc + InstOrigin(..), InstLoc(..), pprInstLoc ) where #include "HsVersions.h" @@ -44,7 +43,7 @@ import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) 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 @@ -58,7 +57,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, predHasFDs, getClassPredTys, getClassPredTys_maybe, mkPredName, - isInheritablePred, isIPPred, + isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) @@ -68,16 +67,13 @@ 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, mkTopTyVarSubst - ) +import Subst ( emptyInScopeSet, mkSubst, 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 @@ -227,11 +223,13 @@ newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst] -newDictsAtLoc inst_loc@(_,loc,_) theta +newDictsAtLoc inst_loc theta = newUniqueSupply `thenM` \ us -> returnM (zipWith mk_dict (uniqsFromSupply us) theta) where - mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc + mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) + pred inst_loc + loc = instLocSrcLoc inst_loc -- For vanilla implicit parameters, there is only one in scope -- at any time, so we used to use the name of the implicit parameter itself @@ -240,7 +238,7 @@ newDictsAtLoc inst_loc@(_,loc,_) theta newIPDict :: InstOrigin -> IPName Name -> Type -> TcM (IPName Id, Inst) newIPDict orig ip_name ty - = getInstLoc orig `thenM` \ inst_loc@(_,loc,_) -> + = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) -> newUnique `thenM` \ uniq -> let pred = IParam ip_name ty @@ -300,7 +298,6 @@ tcInstDataCon orig data_con returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs') - newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId newMethodFromName origin ty name = tcLookupId name `thenM` \ id -> @@ -308,55 +305,42 @@ newMethodFromName origin ty name -- always a class op, but with -fno-implicit-prelude GHC is -- meant to find whatever thing is in scope, and that may -- be an ordinary function. - newMethod origin id [ty] `thenM` \ inst -> + getInstLoc origin `thenM` \ loc -> + tcInstClassOp loc id [ty] `thenM` \ inst -> + extendLIE inst `thenM_` returnM (instToId inst) -newMethod :: InstOrigin - -> TcId - -> [TcType] - -> TcM Inst -newMethod orig id tys - = -- Get the Id type and instantiate it at the specified types - let - (tyvars, rho) = tcSplitForAllTys (idType id) - rho_ty = substTyWith tyvars tys rho - (pred, tau) = tcSplitMethodTy rho_ty - in - newMethodWithGivenTy orig id tys [pred] tau - newMethodWithGivenTy orig id tys theta tau = getInstLoc orig `thenM` \ loc -> - newMethodWith loc id tys theta tau `thenM` \ inst -> + newMethod loc id tys theta tau `thenM` \ inst -> extendLIE inst `thenM_` - returnM inst + returnM (instToId inst) -------------------------------------------- --- newMethodWith and newMethodAtLoc do *not* drop the +-- tcInstClassOp, and newMethod do *not* drop the -- Inst into the LIE; they just returns the Inst -- This is important because they are used by TcSimplify -- to simplify Insts -newMethodWith inst_loc@(_,loc,_) id tys theta tau +tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst +tcInstClassOp inst_loc sel_id tys + = let + (tyvars,rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length tyvars == length tys ) + substTyWith tyvars tys rho + (preds,tau) = tcSplitPhiTy rho_ty + in + newMethod inst_loc sel_id tys preds tau + +--------------------------- +newMethod inst_loc id tys theta tau = newUnique `thenM` \ new_uniq -> let meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc inst = Method meth_id id tys theta tau inst_loc + loc = instLocSrcLoc inst_loc in returnM inst - -newMethodAtLoc :: InstLoc - -> Id -> [TcType] - -> TcM Inst -newMethodAtLoc inst_loc real_id tys - -- This actually builds the Inst - = -- Get the Id type and instantiate it at the specified types - let - (tyvars,rho) = tcSplitForAllTys (idType real_id) - rho_ty = ASSERT( equalLength tyvars tys ) - substTy (mkTopTyVarSubst tyvars tys) rho - (theta, tau) = tcSplitPhiTy rho_ty - in - newMethodWith inst_loc real_id tys theta tau \end{code} In newOverloadedLit we convert directly to an Int or Integer if we @@ -487,7 +471,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] @@ -547,7 +531,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 @@ -558,6 +542,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 @@ -606,7 +594,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) | otherwise = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant tcLookupId fromIntegerName `thenM` \ from_integer -> - newMethodAtLoc loc from_integer [ty] `thenM` \ method_inst -> + tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i)))) @@ -618,33 +606,11 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | otherwise = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant tcLookupId fromRationalName `thenM` \ from_rational -> - newMethodAtLoc loc from_rational [ty] `thenM` \ method_inst -> + tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> 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} %************************************************************************ @@ -695,7 +661,7 @@ tcSyntaxName orig ty std_nm user_nm let -- C.f. newMethodAtLoc ([tv], _, tau) = tcSplitSigmaTy (idType std_id) - tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau + tau1 = substTyWith [tv] [ty] tau in addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $ tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->