Commit e3670130 authored by ralf's avatar ralf
Browse files

[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
parent bb1bb047
......@@ -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
......
......@@ -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")
......
......@@ -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 { \
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment