Typeable.hs

{-# OPTIONS_JHC -fffi -funboxed-values  #-}
module Data.Typeable(TypeRep(),Typeable(..),Typeable1(..),Typeable2(..)) where

import Jhc.Prim
import Jhc.String

type String_ = BitsPtr_

data TypeRep = TypeRep String_ [TypeRep]

showsAddr__ :: String_ -> [Char] -> [Char]
showsAddr__ a xs = unpackStringFoldr a (:) xs

instance Show TypeRep where
    showsPrec _ (TypeRep a []) = showsAddr__ a
    showsPrec n (TypeRep a xs) = showParen (n > 9) $ spacesep (showsAddr__ a:map (showsPrec 10) xs) where
        spacesep [] = id
        spacesep [x] = x
        spacesep (x:xs) = x . showChar ' ' . spacesep xs

instance Eq TypeRep where
    TypeRep a xs == TypeRep b ys = case c_strcmp (Addr_ a) (Addr_ b) of
        0 -> xs == ys
        _ -> False

foreign import ccall "strcmp" c_strcmp :: Addr_ -> Addr_ -> Int

{-
foreign import primitive ptypeOf :: a -> TypeRep
foreign import primitive ptypeOf1 :: t a -> TypeRep
foreign import primitive ptypeOf2 :: t a b -> TypeRep
foreign import primitive ptypeOf3 :: t a b c -> TypeRep
foreign import primitive ptypeOf4 :: t a b c d -> TypeRep
foreign import primitive ptypeOf5 :: t a b c d e -> TypeRep
foreign import primitive ptypeOf6 :: t a b c d e f -> TypeRep
foreign import primitive ptypeOf7 :: t a b c d e f g -> TypeRep
foreign import primitive typeRepEq :: TypeRep -> TypeRep -> Bool
-}

class Typeable a where
    typeOf :: a -> TypeRep

class Typeable1 f where
    typeOf1 :: f a -> TypeRep

class Typeable2 f where
    typeOf2 :: f a b -> TypeRep

instance Typeable1 [] where
    typeOf1 _ = TypeRep "[]"# []

instance Typeable a => Typeable [a] where
    typeOf x = typeOfDefault x

{-
instance (Typeable a,Typeable b) => Typeable (a -> b) where
    typeOf x = (typeOf2 x `mkAppTy` arg1 x) `mkAppTy` arg2 x where
        arg1 :: (x -> y) -> x
        arg2 :: (x -> y) -> y
        arg1 = undefined
        arg2 = undefined

instance (Typeable a) => Typeable1 ((->) a) where
    typeOf1 x = typeOf1Default x

instance Typeable2 (->) where
    typeOf2 _ = TypeRep "->"# []
-}

instance Typeable2 (,) where
    typeOf2 _ = TypeRep "(,)"# []

instance Typeable a => Typeable1 ((,) a) where
    typeOf1 x = typeOf1Default x

instance (Typeable b,Typeable a) => Typeable (a,b) where
    typeOf x = typeOfDefault x

instance Typeable Char where
    typeOf _ = TypeRep "Char"# []

instance Typeable () where
    typeOf _ = TypeRep "()"# []

instance Typeable Int where
    typeOf _ = TypeRep "Int"# []

--instance (Typeable1 f,Typeable a) => Typeable (f a) where
--    typeOf x = typeOf1 x `mkAppTy` typeOf (argType x) where
--        argType :: a b -> b
--        argType = undefined

mkAppTy :: TypeRep -> TypeRep -> TypeRep
mkAppTy (TypeRep x xs) tr = TypeRep x (xs ++ [tr])

-------------------------------------------------------------
--
--		Type-safe cast
--
-------------------------------------------------------------

unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce__

-- | The type-safe cast operation
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r where
    fromJust (Just x) = x
    r = if typeOf x == typeOf (fromJust r)
               then Just $ unsafeCoerce x
	       else Nothing

{-
-- | A flexible variation parameterised in a type constructor
gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
gcast x = r
 where
  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
        then Just $ unsafeCoerce x
        else Nothing
  getArg :: c x -> x
  getArg = undefined

-- | Cast for * -> *
gcast1 :: (Typeable1 t, Typeable1 t') c (t a) -> Maybe (c (t' a))
gcast1 x = r
 where
  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
       then Just $ unsafeCoerce x
       else Nothing
  getArg :: c x -> x
  getArg = undefined

-- | Cast for * -> * -> *
gcast2 :: (Typeable2 t, Typeable2 t') c (t a b) -> Maybe (c (t' a b))
gcast2 x = r
 where
  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
       then Just $ unsafeCoerce x
       else Nothing
  getArg :: c x -> x
  getArg = undefined
  -}

-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
 where
   argType :: t a -> a
   argType =  undefined

-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
 where
   argType :: t a b -> a
   argType =  undefined