From 0a913ae5534cd8d3532c090054f482584bc6a0c3 Mon Sep 17 00:00:00 2001 From: ralf Date: Sun, 21 Mar 2004 19:07:01 +0000 Subject: [PATCH] [project @ 2004-03-21 19:07:00 by ralf] Implemented renaming for Data.Typeable according to http://www.haskell.org//pipermail/libraries/2004-March/001846.html --- Data/Dynamic.hs | 2 +- Data/Typeable.hs | 66 ++++++++++++++++++++++++++++------------------------ include/Typeable.h | 14 +++++------ 3 files changed, 44 insertions(+), 38 deletions(-) diff --git a/Data/Dynamic.hs b/Data/Dynamic.hs index 26782ce..31c0199 100644 --- a/Data/Dynamic.hs +++ b/Data/Dynamic.hs @@ -154,7 +154,7 @@ fromDynamic (Dynamic t v) = -- (f::(a->b)) `dynApply` (x::a) = (f a)::b dynApply :: Dynamic -> Dynamic -> Maybe Dynamic dynApply (Dynamic t1 f) (Dynamic t2 x) = - case applyTy t1 t2 of + case funResultTy t1 t2 of Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) Nothing -> Nothing diff --git a/Data/Typeable.hs b/Data/Typeable.hs index 1e997b8..d537a0e 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -36,10 +36,11 @@ module Data.Typeable -- * Construction of type representations mkTyCon, -- :: String -> TyCon - mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep + mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep + mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep - applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep - popStarTy, -- :: TypeRep -> TypeRep -> TypeRep + splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) + funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep -- * Observation of type representations typerepTyCon, -- :: TypeRep -> TyCon @@ -63,11 +64,11 @@ module Data.Typeable -- are generated by general instance declarations. typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep - typeOf2Default, -- :: (Typeable2 t, Typeable a) => t a b c -> TypeRep - typeOf3Default, -- :: (Typeable2 t, Typeable a) => t a b c d -> TypeRep - typeOf4Default, -- :: (Typeable2 t, Typeable a) => t a b c d e -> TypeRep - typeOf5Default, -- :: (Typeable2 t, Typeable a) => t a b c d e f -> TypeRep - typeOf6Default -- :: (Typeable2 t, Typeable a) => t a b c d e f g -> TypeRep + typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep + typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep + typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep + typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep + typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep ) where @@ -135,7 +136,7 @@ instance Eq TyCon where #endif -- - -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,") + -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") -- [fTy,fTy,fTy]) -- -- returns "(Foo,Foo,Foo)" @@ -148,29 +149,34 @@ instance Eq TyCon where ----------------- Construction -------------------- -- | Applies a type constructor to a sequence of types -mkAppTy :: TyCon -> [TypeRep] -> TypeRep -mkAppTy tc@(TyCon tc_k _) args +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc@(TyCon tc_k _) args = TypeRep (appKeys tc_k arg_ks) tc args where arg_ks = [k | TypeRep k _ _ <- args] --- | A special case of 'mkAppTy', which applies the function +-- | A special case of 'mkTyConApp', which applies the function -- type constructor to a pair of types. mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkAppTy funTc [f,a] +mkFunTy f a = mkTyConApp funTc [f,a] + +-- | Splits a type constructor application +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc trs) = (tc,trs) -- | Applies a type to a function type. Returns: @'Just' u@ if the -- first argument represents a function of type @t -> u@ and the -- second argument represents a function of type @t@. Otherwise, -- returns 'Nothing'. -applyTy :: TypeRep -> TypeRep -> Maybe TypeRep -applyTy (TypeRep _ tc [t1,t2]) t3 - | tc == funTc && t1 == t3 = Just t2 -applyTy _ _ = Nothing +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + _ -> Nothing -- | Adds a TypeRep argument to a TypeRep. -popStarTy :: TypeRep -> TypeRep -> TypeRep -popStarTy (TypeRep tr_k tc trs) arg_tr +mkAppTy :: TypeRep -> TypeRep -> TypeRep +mkAppTy (TypeRep tr_k tc trs) arg_tr = let (TypeRep arg_k _ _) = arg_tr in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) @@ -273,7 +279,7 @@ class Typeable1 t where -- | For defining a 'Typeable' instance from any 'Typeable1' instance. typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep -typeOfDefault x = typeOf1 x `popStarTy` typeOf (argType x) +typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) where argType :: t a -> a argType = undefined @@ -284,7 +290,7 @@ class Typeable2 t where -- | For defining a 'Typeable1' instance from any 'Typeable2' instance. typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep -typeOf1Default x = typeOf2 x `popStarTy` typeOf (argType x) +typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) where argType :: t a b -> a argType = undefined @@ -295,7 +301,7 @@ class Typeable3 t where -- | For defining a 'Typeable2' instance from any 'Typeable3' instance. typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep -typeOf2Default x = typeOf3 x `popStarTy` typeOf (argType x) +typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) where argType :: t a b c -> a argType = undefined @@ -306,7 +312,7 @@ class Typeable4 t where -- | For defining a 'Typeable3' instance from any 'Typeable4' instance. typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep -typeOf3Default x = typeOf4 x `popStarTy` typeOf (argType x) +typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) where argType :: t a b c d -> a argType = undefined @@ -317,7 +323,7 @@ class Typeable5 t where -- | For defining a 'Typeable4' instance from any 'Typeable5' instance. typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep -typeOf4Default x = typeOf5 x `popStarTy` typeOf (argType x) +typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e -> a argType = undefined @@ -328,7 +334,7 @@ class Typeable6 t where -- | For defining a 'Typeable5' instance from any 'Typeable6' instance. typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep -typeOf5Default x = typeOf6 x `popStarTy` typeOf (argType x) +typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f -> a argType = undefined @@ -339,7 +345,7 @@ class Typeable7 t where -- | For defining a 'Typeable6' instance from any 'Typeable7' instance. typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep -typeOf6Default x = typeOf7 x `popStarTy` typeOf (argType x) +typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) where argType :: t a b c d e f g -> a argType = undefined @@ -453,25 +459,25 @@ tup4Tc :: TyCon tup4Tc = mkTyCon ",,," instance Typeable4 (,,,) where - typeOf4 tu = mkAppTy tup4Tc [] + typeOf4 tu = mkTyConApp tup4Tc [] tup5Tc :: TyCon tup5Tc = mkTyCon ",,,," instance Typeable5 (,,,,) where - typeOf5 tu = mkAppTy tup5Tc [] + typeOf5 tu = mkTyConApp tup5Tc [] tup6Tc :: TyCon tup6Tc = mkTyCon ",,,,," instance Typeable6 (,,,,,) where - typeOf6 tu = mkAppTy tup6Tc [] + typeOf6 tu = mkTyConApp tup6Tc [] tup7Tc :: TyCon tup7Tc = mkTyCon ",,,,," instance Typeable7 (,,,,,,) where - typeOf7 tu = mkAppTy tup7Tc [] + typeOf7 tu = mkTyConApp tup7Tc [] INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr") INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr") diff --git a/include/Typeable.h b/include/Typeable.h index 9e3bd86..ea3fda7 100644 --- a/include/Typeable.h +++ b/include/Typeable.h @@ -12,7 +12,7 @@ #define INSTANCE_TYPEABLE0(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkAppTy tcname [] } +instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } #ifdef __GLASGOW_HASKELL__ @@ -21,26 +21,26 @@ instance Typeable tycon where { typeOf _ = mkAppTy tcname [] } #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkAppTy tcname [] } +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE2(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkAppTy tcname [] } +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE3(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkAppTy tcname [] } +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } #else /* !__GLASGOW_HASKELL__ */ #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkAppTy tcname [] }; \ +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } #define INSTANCE_TYPEABLE2(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkAppTy tcname [] }; \ +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable1 (tycon a) where { \ typeOf1 = typeOf1Default }; \ instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ @@ -48,7 +48,7 @@ instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ #define INSTANCE_TYPEABLE3(tycon,tcname,str) \ tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkAppTy tcname [] }; \ +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable2 (tycon a) where { \ typeOf2 = typeOf2Default }; \ instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ -- 1.7.10.4