From 0adb717549e8f6974453eb386350874be601bb03 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 11 Nov 2002 10:53:29 +0000 Subject: [PATCH 1/1] [project @ 2002-11-11 10:53:28 by simonpj] ------------------ Fix a newtype-deriving bug ------------------ The new newtype-deriving mechanism was erroneously using the *representation type* of the newtype. The rep type looks through all ihtermediate newtypes, so that is wrong. See Note [newtype representation] in TcDeriv.lhs deriving/should_run/drvrun013 now tests for this. --- ghc/compiler/typecheck/TcDeriv.lhs | 24 +++++++++++++++++------- ghc/compiler/typecheck/TcEnv.lhs | 2 +- ghc/compiler/typecheck/TcType.lhs | 23 ++++++++++++++--------- ghc/compiler/types/TyCon.lhs | 13 ++++++++----- ghc/compiler/types/Type.lhs | 17 +++++++---------- ghc/compiler/utils/Util.lhs | 20 ++++++++++---------- 6 files changed, 57 insertions(+), 42 deletions(-) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 2e5dc6b..435316b 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -36,20 +36,19 @@ import Class ( className, classKey, classTyVars, classSCTheta, Class ) import Subst ( mkTyVarSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) -import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon ) +import DataCon ( dataConRepArgTys, dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) import Maybes ( maybeToBool, catMaybes ) import Name ( Name, getSrcLoc, nameUnique ) import NameSet import RdrName ( RdrName ) -import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep, +import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe, isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, - tcEqTypes, mkAppTys ) -import Type ( splitAppTys ) + tcEqTypes, tcSplitAppTys, mkAppTys ) import Var ( TyVar, tyVarKind ) import VarSet ( mkVarSet, subVarSet ) import PrelNames @@ -348,7 +347,7 @@ makeDerivEqns tycl_decls constraints = extra_constraints ++ [ mkClassPred clas [arg_ty] | data_con <- tyConDataCons tycon, - arg_ty <- dataConRepArgTys data_con, + arg_ty <- dataConRepArgTys data_con, -- dataConOrigArgTys??? -- Use the same type variables -- as the type constructor, -- hence no need to instantiate @@ -362,6 +361,7 @@ makeDerivEqns tycl_decls = doptM Opt_GlasgowExts `thenM` \ gla_exts -> if can_derive_via_isomorphism && (gla_exts || standard_instance) then -- Go ahead and use the isomorphism + traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` new_dfun_name clas tycon `thenM` \ dfun_name -> returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name, iBinds = NewTypeDerived rep_tys })) @@ -394,8 +394,18 @@ makeDerivEqns tycl_decls -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s) - (tyvars, rep_ty) = newTyConRep tycon - (rep_fn, rep_ty_args) = splitAppTys rep_ty + -- Note [newtype representation] + -- We must not use newTyConRep to get the representation + -- type, because that looks through all intermediate newtypes + -- To get the RHS of *this* newtype, just look at the data + -- constructor. For example + -- newtype B = MkB Int + -- newtype A = MkA B deriving( Num ) + -- We want the Num instance of B, *not* the Num instance of Int, + -- when making the Num instance of A! + tyvars = tyConTyVars tycon + rep_ty = head (dataConOrigArgTys (head (tyConDataCons tycon))) + (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty n_tyvars_to_keep = tyConArity tycon - n_args_to_drop tyvars_to_drop = drop n_tyvars_to_keep tyvars diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5d53dae..75e4a72 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -591,7 +591,7 @@ data InstBindings pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b -pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the represenation type" +pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type" simpleInstInfoTy :: InstInfo -> Type simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index fc5d3ae..29997cd 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -35,7 +35,7 @@ module TcType ( tcSplitForAllTys, tcSplitPhiTy, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy, tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar, --------------------------------- @@ -141,7 +141,7 @@ import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon ) import BasicTypes ( IPName(..), ipNameName ) import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) -import Util ( cmpList, thenCmp, equalLength ) +import Util ( cmpList, thenCmp, equalLength, snocView ) import Maybes ( maybeToBool, expectJust ) import Outputable \end{code} @@ -405,21 +405,26 @@ tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty -tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys - --- Don't forget that newtype! +tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype! tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys tcSplitAppTy_maybe other = Nothing -tc_split_app tc [] = Nothing -tc_split_app tc tys = split tys [] - where - split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) - split (ty:tys) acc = split tys (ty:acc) +tc_split_app tc tys = case snocView tys of + Just (tys',ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff Nothing -> pprPanic "tcSplitAppTy" (pprType ty) +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe (TyVarTy tv) = Just tv tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 642f246..74658f2 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -181,15 +181,18 @@ data AlgTyConFlavour | NewTyCon Type -- Newtype, with its *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself -- a newtype or type synonym. - + -- The rep type isn't entirely simple: + -- for a recursive newtype we pick () as the rep type + -- newtype T = MkT T + -- -- The rep type has free type variables the tyConTyVars -- Thus: -- newtype T a = MkT [(a,Int)] -- The rep type is [(a,Int)] - -- - -- The rep type isn't entirely simple: - -- for a recursive newtype we pick () as the rep type - -- newtype T = MkT T + -- NB: the rep type isn't necessarily the original RHS of the + -- newtype decl, because the rep type looks through other + -- newtypes. If you want hte original RHS, look at the + -- argument type of the data constructor. data DataConDetails datacon = DataCons [datacon] -- Its data constructors, with fully polymorphic types diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 68a9275..0ce97f4 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -106,7 +106,7 @@ import CmdLineOpts ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) import PrimRep ( PrimRep(..) ) import Unique ( Uniquable(..) ) -import Util ( mapAccumL, seqList, lengthIs ) +import Util ( mapAccumL, seqList, lengthIs, snocView ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet import Maybe ( isJust ) @@ -249,14 +249,11 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type) splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty -splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) -splitAppTy_maybe (TyConApp tc []) = Nothing -splitAppTy_maybe (TyConApp tc tys) = split tys [] - where - split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) - split (ty:tys) acc = split tys (ty:acc) - -splitAppTy_maybe other = Nothing +splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) +splitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Nothing -> Nothing + Just (tys',ty') -> Just (TyConApp tc tys', ty') +splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) splitAppTy ty = case splitAppTy_maybe ty of @@ -268,7 +265,7 @@ splitAppTys ty = split ty ty [] where split orig_ty (AppTy ty arg) args = split ty ty (arg:args) split orig_ty (NoteTy _ ty) args = split orig_ty ty args - split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args + split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 9cc5c58..4949515 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -13,9 +13,8 @@ module Util ( nOfThem, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, isSingleton, only, - notNull, + notNull, snocView, - snocView, isIn, isn'tIn, -- for-loop @@ -263,6 +262,15 @@ notNull :: [a] -> Bool notNull [] = False notNull _ = True +snocView :: [a] -> Maybe ([a],a) + -- Split off the last element +snocView [] = Nothing +snocView xs = go [] xs + where + -- Invariant: second arg is non-empty + go acc [x] = Just (reverse acc, x) + go acc (x:xs) = go (x:acc) xs + only :: [a] -> a #ifdef DEBUG only [a] = a @@ -271,14 +279,6 @@ only (a:_) = a #endif \end{code} -\begin{code} -snocView :: [a] -> ([a], a) -- Split off the last element -snocView xs = go xs [] - where - go [x] acc = (reverse acc, x) - go (x:xs) acc = go xs (x:acc) -\end{code} - Debugging/specialising versions of \tr{elem} and \tr{notElem} \begin{code} -- 1.7.10.4