From 115f0fae2f782836550a9419f739fd29c09e4f1b Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 4 Feb 2003 12:28:26 +0000 Subject: [PATCH] [project @ 2003-02-04 12:28:22 by simonpj] --------------------------------------------------- Important fix to the handling of class methods that mention their own class type variable --------------------------------------------------- [NB: I'm not 100% certain that this commit is independent of the Template-Haskell-related commit I'm doing at the same time. I've tried to separate them but may not have succeeded totally.] This bug gives utterly bogus (detected by Core Lint) programs. Isaac Jones discovered it. Here's an example, now enshrined as tc165. class C a where f :: (Eq a) => a instance C () where f = f The instance decl was translated as dfC() = MkC (let f = \dEq -> f in f) which is utterly wrong. Reason: the 'f' on the left was being treated as an available Inst, but it doesn't obey INVARIANT 2 for Insts, which is that they are applied to all their dictionaries. (See the data type decl for Inst.) Solution: don't include such class methods in the available Insts. --- ghc/compiler/typecheck/Inst.lhs | 19 +++----- ghc/compiler/typecheck/TcClassDcl.lhs | 78 +++++++++++++++++++++++++-------- ghc/compiler/typecheck/TcInstDcls.lhs | 7 +-- ghc/compiler/typecheck/TcMonoType.lhs | 11 ++--- 4 files changed, 75 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 083c364..cd189a5 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -323,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 @@ -480,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] diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 86d3bba..fb29e56 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, tcInstClassOp ) +import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) import TcEnv ( TyThingDetails(..), tcLookupClass, tcExtendTyVarEnv2, tcExtendTyVarEnv @@ -36,7 +36,8 @@ import TcUnify ( checkSigTyVars, sigCtxt ) import TcMType ( tcInstTyVars ) import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys, - tcIsTyVarTy, tcSplitTyConApp_maybe + tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy, + getClassPredTys_maybe, mkPhiTy ) import TcRnMonad import Generics ( mkGenericRhs ) @@ -44,9 +45,10 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import Class ( classTyVars, classBigSig, classTyCon, Class, ClassOpItem, DefMeth (..) ) import TyCon ( tyConGenInfo ) +import Subst ( substTyWith ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon ) -import Id ( Id, idType, idName, setIdLocalExported, setInlinePragma ) +import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) import NameSet ( emptyNameSet, unitNameSet ) @@ -57,7 +59,7 @@ import Var ( TyVar ) import CmdLineOpts import UnicodeUtil ( stringToUtf8 ) import ErrUtils ( dumpIfSet ) -import Util ( count, lengthIs ) +import Util ( count, lengthIs, isSingleton ) import Maybes ( seqMaybe ) import Maybe ( isJust ) import FastString @@ -391,7 +393,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) in newDicts origin theta `thenM` \ [this_dict] -> - mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (dm_inst, meth_info) -> + mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) -> getLIE (tcMethodBind xtve clas_tyvars theta [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) -> @@ -408,10 +410,11 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' -> let + (_,dm_inst_id,_) = meth_info full_bind = AbsBinds clas_tyvars' [instToId this_dict] - [(clas_tyvars', local_dm_id, instToId dm_inst)] + [(clas_tyvars', local_dm_id, dm_inst_id)] emptyNameSet -- No inlines (yet) (dict_binds `andMonoBinds` defm_bind) in @@ -435,7 +438,7 @@ tyvar sets. \begin{code} type MethodSpec = (Id, -- Global selector Id - TcSigInfo, -- Signature + Id, -- Local Id (class tyvars instantiated) RenamedMonoBinds) -- Binding for the method tcMethodBind @@ -453,9 +456,11 @@ tcMethodBind -> TcM TcMonoBinds tcMethodBind xtve inst_tyvars inst_theta avail_insts prags - (sel_id, meth_sig, meth_bind) + (sel_id, meth_id, meth_bind) = -- Check the bindings; first adding inst_tyvars to the envt -- so that we don't quantify over them in nested places + mkTcSig meth_id `thenM` \ meth_sig -> + tcExtendTyVarEnv2 xtve ( addErrCtxt (methodCtxt sel_id) $ getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive) @@ -510,17 +515,14 @@ mkMethodBind :: InstOrigin -> Class -> [TcType] -- Class and instance types -> RenamedMonoBinds -- Method binding (pick the right one from in here) -> ClassOpItem - -> TcM (Inst, -- Method inst + -> TcM (Maybe Inst, -- Method inst MethodSpec) -- Find the binding for the specified method, or make -- up a suitable default method if it isn't there mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) - = getInstLoc origin `thenM` \ inst_loc -> - tcInstClassOp inst_loc sel_id inst_tys `thenM` \ meth_inst -> - -- Do not dump anything into the LIE + = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) -> let - meth_id = instToId meth_inst meth_name = idName meth_id in -- Figure out what method binding to use @@ -530,13 +532,53 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) Just user_bind -> returnM user_bind Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> returnM (FunMonoBind meth_name False -- Not infix decl - [mkSimpleMatch [] rhs placeHolderType loc] loc) + [mkSimpleMatch [] rhs placeHolderType loc] loc) ) `thenM` \ meth_bind -> - mkTcSig meth_id loc `thenM` \ meth_sig -> - - returnM (meth_inst, (sel_id, meth_sig, meth_bind)) - + returnM (mb_inst, (sel_id, meth_id, meth_bind)) + +mkMethId :: InstOrigin -> Class + -> Id -> [TcType] -- Selector, and instance types + -> TcM (Maybe Inst, Id) + +-- mkMethId instantiates the selector Id at the specified types +-- THe +mkMethId origin clas sel_id inst_tys + = let + (tyvars,rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length tyvars == length inst_tys ) + substTyWith tyvars inst_tys rho + (preds,tau) = tcSplitPhiTy rho_ty + first_pred = head preds + in + -- The first predicate should be of form (C a b) + -- where C is the class in question + ASSERT( not (null preds) && + case getClassPredTys_maybe first_pred of + { Just (clas1,tys) -> clas == clas1 ; Nothing -> False } + ) + if isSingleton preds then + -- If it's the only one, make a 'method' + getInstLoc origin `thenM` \ inst_loc -> + newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst -> + returnM (Just meth_inst, instToId meth_inst) + else + -- If it's not the only one we need to be careful + -- For example, given 'op' defined thus: + -- class Foo a where + -- op :: (?x :: String) => a -> a + -- (mkMethId op T) should return an Inst with type + -- (?x :: String) => T -> T + -- That is, the class-op's context is still there. + -- BUT: it can't be a Method any more, because it breaks + -- INVARIANT 2 of methods. (See the data decl for Inst.) + newUnique `thenM` \ uniq -> + getSrcLocM `thenM` \ loc -> + let + real_tau = mkPhiTy (tail preds) tau + meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc + in + returnM (Nothing, meth_id) -- The user didn't supply a method binding, -- so we have to make up a default binding diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index b30af59..cf705ae 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -610,7 +610,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' let mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds in - mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) -> + mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) -> -- And type check them -- It's really worth making meth_insts available to the tcMethodBind @@ -630,13 +630,14 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' -- Solution: make meth_insts available, so that 'then' refers directly -- to the local 'bind' rather than going via the dictionary. let - all_insts = avail_insts ++ meth_insts + all_insts = avail_insts ++ catMaybes meth_insts xtve = inst_tyvars `zip` inst_tyvars' tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags in mapM tc_method_bind meth_infos `thenM` \ meth_binds_s -> - returnM (map instToId meth_insts, andMonoBindList meth_binds_s) + returnM ([meth_id | (_,meth_id,_) <- meth_infos], + andMonoBindList meth_binds_s) -- Derived newtype instances diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 320cf8d..e93f64d 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -654,13 +654,13 @@ maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name tcTySig :: RenamedSig -> TcM TcSigInfo tcTySig (Sig v ty src_loc) - = addSrcLoc src_loc $ - tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> - mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenM` \ sig -> + = addSrcLoc src_loc $ + tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> + mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig -> returnM sig -mkTcSig :: TcId -> SrcLoc -> TcM TcSigInfo -mkTcSig poly_id src_loc +mkTcSig :: TcId -> TcM TcSigInfo +mkTcSig poly_id = -- Instantiate this type -- It's important to do this even though in the error-free case -- we could just split the sigma_tc_ty (since the tyvars don't @@ -677,6 +677,7 @@ mkTcSig poly_id src_loc -- We make a Method even if it's not overloaded; no harm -- But do not extend the LIE! We're just making an Id. + getSrcLocM `thenM` \ src_loc -> returnM (TySigInfo poly_id tyvars' theta' tau' (instToId inst) [inst] src_loc) \end{code} -- 1.7.10.4