From 4e84be0ce335385e094ba12d284855b510a36f53 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 18 Nov 2002 14:25:55 +0000 Subject: [PATCH] [project @ 2002-11-18 14:25:50 by simonpj] ---------------------------------------- Class ops that do not introduce for-alls ---------------------------------------- MERGE TO STABLE (if poss) The handling of class ops that do not add an extra for-all was utterly bogus. For example: class C a where fc :: (?p :: String) => a; class D a where fd :: (Ord a) => [a] -> [a] De-bogus-ing means a) Being careful when taking apart the class op type in MkIface.tcClassOpSig b) Ditto when making the method Id in an instance binding. Hence new function Inst.tcInstClassOp, and its calls in TcInstDcls, and TcClassDcls --- ghc/compiler/main/MkIface.lhs | 10 ++++++-- ghc/compiler/typecheck/Inst.lhs | 45 +++++++++++++++++++-------------- ghc/compiler/typecheck/TcClassDcl.lhs | 4 +-- ghc/compiler/typecheck/TcInstDcls.lhs | 10 +++++--- ghc/compiler/typecheck/TcSimplify.lhs | 6 ++--- 5 files changed, 45 insertions(+), 30 deletions(-) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index b4178db..5025473 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -55,7 +55,7 @@ import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) import Class ( classExtraBigSig, classTyCon, DefMeth(..) ) import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead ) +import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead ) import SrcLoc ( noSrcLoc ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, @@ -248,7 +248,13 @@ ifaceTyThing (AClass clas) = cls_decl = ASSERT(sel_tyvars == clas_tyvars) ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc where - (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id) + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) + op_ty = tcFunResultTy rho_ty def_meth' = case def_meth of NoDefMeth -> NoDefMeth GenDefMeth -> GenDefMeth diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index ccd8e43..35d1c55 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -14,7 +14,7 @@ module Inst ( newDictsFromOld, newDicts, cloneDict, newMethod, newMethodFromName, newMethodWithGivenTy, - newMethodWith, newMethodAtLoc, + newMethodWith, tcInstClassOp, newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon, tcSyntaxName, @@ -58,7 +58,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, predHasFDs, getClassPredTys, getClassPredTys_maybe, mkPredName, - isInheritablePred, isIPPred, + isInheritablePred, isIPPred, tcSplitFunTy_maybe, tcSplitPredTy_maybe, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) import CoreFVs ( idFreeTyVars ) @@ -330,11 +330,32 @@ newMethodWithGivenTy orig id tys theta tau returnM (instToId inst) -------------------------------------------- --- newMethodWith and newMethodAtLoc do *not* drop the +-- tcInstClassOp, and newMethodWith 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 +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 = ASSERT( equalLength tyvars tys ) + substTy (mkTopTyVarSubst tyvars tys) rho + Just (pred_ty,tau) = tcSplitFunTy_maybe rho_ty + Just pred = tcSplitPredTy_maybe pred_ty + -- Split off exactly one predicate (see the example above) + in + ASSERT( isClassPred pred ) + newMethodWith inst_loc sel_id tys [pred] tau + newMethodWith inst_loc@(_,loc,_) id tys theta tau = newUnique `thenM` \ new_uniq -> let @@ -342,20 +363,6 @@ newMethodWith inst_loc@(_,loc,_) id tys theta tau inst = Method meth_id id tys theta tau 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 @@ -605,7 +612,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)))) @@ -617,7 +624,7 @@ 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} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index c39d8a0..191ff05 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -24,7 +24,7 @@ import RnHsSyn ( RenamedTyClDecl, RenamedSig, import RnEnv ( lookupSysName ) import TcHsSyn ( TcMonoBinds ) -import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethodAtLoc ) +import Inst ( Inst, InstOrigin(..), instToId, newDicts, tcInstClassOp ) import TcEnv ( TyThingDetails(..), tcLookupClass, tcExtendTyVarEnv2, tcExtendTyVarEnv @@ -518,7 +518,7 @@ mkMethodBind :: InstOrigin mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) = getInstLoc origin `thenM` \ inst_loc -> - newMethodAtLoc inst_loc sel_id inst_tys `thenM` \ meth_inst -> + tcInstClassOp inst_loc sel_id inst_tys `thenM` \ meth_inst -> -- Do not dump anything into the LIE let meth_id = instToId meth_inst diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6d9f99f..427ec92 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,7 +31,7 @@ import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, TyVarDetails(..) ) -import Inst ( InstOrigin(..), newMethod, newMethodAtLoc, +import Inst ( InstOrigin(..), newMethod, tcInstClassOp, newDicts, instToId, showLIE ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, @@ -641,10 +641,12 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' where do_one inst_loc (sel_id, _) - = newMethodAtLoc inst_loc sel_id inst_tys' `thenM` \ meth_inst -> - -- Like in mkMethodBind + = -- The binding is like "op @ NewTy = op @ RepTy" + -- Make the *binder*, like in mkMethodBind + 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 -> - -- The binding is like "op @ NewTy = op @ RepTy" let meth_id = instToId meth_inst in diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index d017154..758659a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -33,7 +33,7 @@ import Inst ( lookupInst, LookupInstResult(..), instToId, tyVarsOfInsts, cloneDict, ipNamesOfInsts, ipNamesOfInst, dictPred, instBindingRequired, instCanBeGeneralised, - newDictsFromOld, newMethodAtLoc, + newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts, Inst, pprInsts, pprInstsInFull, @@ -1450,8 +1450,8 @@ addLinearAvailable avails avail wanted | otherwise = tcLookupId splitName `thenM` \ split_id -> - newMethodAtLoc (instLoc wanted) split_id - [linearInstType wanted] `thenM` \ split_inst -> + tcInstClassOp (instLoc wanted) split_id + [linearInstType wanted] `thenM` \ split_inst -> returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst]) where -- 1.7.10.4