From 00e85a3cb0dd8f268f6c40f898ac92d19ea90081 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 19 Nov 2002 12:34:56 +0000 Subject: [PATCH] [project @ 2002-11-19 12:34:55 by simonpj] More newMethod tidying up --- ghc/compiler/typecheck/Inst.lhs | 51 ++++++++++++--------------------- ghc/compiler/typecheck/TcInstDcls.lhs | 13 ++++----- ghc/compiler/typecheck/TcMonoType.lhs | 8 +++--- 3 files changed, 28 insertions(+), 44 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 35d1c55..201a93f 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -12,11 +12,10 @@ module Inst ( Inst, pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts, - newDictsFromOld, newDicts, cloneDict, - newMethod, newMethodFromName, newMethodWithGivenTy, - newMethodWith, tcInstClassOp, + newDictsFromOld, newDicts, cloneDict, newOverloadedLit, newIPDict, - tcInstCall, tcInstDataCon, tcSyntaxName, + newMethod, newMethodFromName, newMethodWithGivenTy, + tcInstClassOp, tcInstCall, tcInstDataCon, tcSyntaxName, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, @@ -58,7 +57,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, predHasFDs, getClassPredTys, getClassPredTys_maybe, mkPredName, - isInheritablePred, isIPPred, tcSplitFunTy_maybe, tcSplitPredTy_maybe, + isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) @@ -68,9 +67,7 @@ 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(..) ) @@ -300,7 +297,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,29 +304,19 @@ 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] - -newMethod :: InstOrigin - -> TcId - -> [TcType] - -> TcM Id -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 + getInstLoc origin `thenM` \ loc -> + tcInstClassOp loc id [ty] `thenM` \ inst -> + extendLIE inst `thenM_` + returnM (instToId inst) 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 (instToId inst) -------------------------------------------- --- tcInstClassOp, and newMethodWith 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 @@ -346,17 +332,16 @@ tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst -- 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 = ASSERT( equalLength tyvars tys ) - substTy (mkTopTyVarSubst tyvars tys) rho - Just (pred_ty,tau) = tcSplitFunTy_maybe rho_ty - Just pred = tcSplitPredTy_maybe pred_ty + (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) in ASSERT( isClassPred pred ) - newMethodWith inst_loc sel_id tys [pred] tau + newMethod inst_loc sel_id tys [pred] tau -newMethodWith inst_loc@(_,loc,_) id tys theta tau +--------------------------- +newMethod inst_loc@(_,loc,_) id tys theta tau = newUnique `thenM` \ new_uniq -> let meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc @@ -701,7 +686,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 -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 427ec92..4f670fa 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,8 +31,7 @@ import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, TyVarDetails(..) ) -import Inst ( InstOrigin(..), newMethod, tcInstClassOp, - newDicts, instToId, showLIE ) +import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcLookupClass, tcExtendTyVarEnv2, @@ -628,12 +627,12 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' -- Derived newtype instances tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' avail_insts op_items (NewTypeDerived rep_tys) - = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc -> - getLIE (mapAndUnzipM (do_one inst_loc) op_items) `thenM` \ ((meth_ids, meth_binds), lie) -> + = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc -> + mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) -> tcSimplifyCheck (ptext SLIT("newtype derived instance")) - inst_tyvars' avail_insts lie `thenM` \ lie_binds -> + inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds -> -- I don't think we have to do the checkSigTyVars thing @@ -646,11 +645,11 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst -> -- Make the *occurrence on the rhs* - newMethod InstanceDeclOrigin sel_id rep_tys' `thenM` \ rhs_id -> + tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst -> let meth_id = instToId meth_inst in - return (meth_id, VarMonoBind meth_id (HsVar rhs_id)) + return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst) -- Instantiate rep_tys with the relevant type variables rep_tys' = map (substTy subst) rep_tys diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index fb575ab..b45acab 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -40,7 +40,7 @@ import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..), liftedTypeKind, unliftedTypeKind, mkArrowKind, mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys ) -import Inst ( Inst, InstOrigin(..), newMethodWith, instToId ) +import Inst ( Inst, InstOrigin(..), newMethod, instToId ) import Id ( mkLocalId, idName, idType ) import Var ( TyVar, mkTyVar, tyVarKind ) @@ -622,9 +622,9 @@ mkTcSig poly_id src_loc tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') -> getInstLoc SignatureOrigin `thenM` \ inst_loc -> - newMethodWith inst_loc poly_id - (mkTyVarTys tyvars') - theta' tau' `thenM` \ inst -> + newMethod inst_loc poly_id + (mkTyVarTys tyvars') + theta' tau' `thenM` \ inst -> -- We make a Method even if it's not overloaded; no harm -- But do not extend the LIE! We're just making an Id. -- 1.7.10.4