[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

3 files changed, 44 insertions, 38 deletions

diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs
index 26782cea96..31c0199adb 100644
--- a/libraries/base/Data/Dynamic.hs
+++ b/libraries/base/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/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs
index 1e997b8b63..d537a0e655 100644
--- a/libraries/base/Data/Typeable.hs
+++ b/libraries/base/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/libraries/base/include/Typeable.h b/libraries/base/include/Typeable.h
index 9e3bd869db..ea3fda716b 100644
--- a/libraries/base/include/Typeable.h
+++ b/libraries/base/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 { \