module Data.TCache.IDynamic where
import Data.Typeable
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Concurrent.MVar
import Data.Map as M
import Data.TCache.IResource
import Data.RefSerialize
import Data.HashTable(hashString)
import Data.Word
import Numeric (showHex, readHex)
data IDynamic= forall a. (Typeable a, IResource a) => IDynamic a deriving Typeable
list :: MVar (Map Word (IDynamic -> IO (Maybe IDynamic), String -> IDynamic, ST IDynamic ) )
list = unsafePerformIO $ newMVar $ empty
hash x= unsafeCoerce . hashString . show $ typeOf x :: Word
instance IResource IDynamic where
keyResource (IDynamic x)= keyResource x
serialize (IDynamic x)= "Dyn " ++ showHex (hash x) ( " " ++ serialize x)
deserialize str2=
let
str= drop 4 str2
[(t :: Word, str1)]= readHex str
in
case M.lookup t (unsafePerformIO $ readMVar list) of
Nothing -> error $ "not registered type " ++ str1 ++ " please registerType it"
Just (_, f, _)-> f $ tail str1
tshowp (IDynamic x)= do
str <- tshowp x
return $ "Dyn " ++ showHex (hash x) ( " "++ str)
treadp = do
symbol "Dyn"
t <- readHexp
case M.lookup t (unsafePerformIO $ readMVar list) of
Nothing -> fail $ "not registered type please registerType it"
Just (_,_, f)-> f
<?> "IDynamic"
defPath (IDynamic x)= defPath x
writeResource (IDynamic x)= writeResource x
readResource d@(IDynamic x)
| typeOfx== typeOf Key= do
mx <- readResource x
case mx of
Nothing -> return $ Nothing
Just x -> return $ Just $ toIDyn x
| otherwise=
case M.lookup type1 (unsafePerformIO $ readMVar list) of
Nothing -> error $ "not registered type " ++ show (typeOf x) ++ " please registerType it"
Just (f ,_,_)-> f d
where
typeOfx= typeOf x
type1= unsafeCoerce $ hashString $ show typeOfx :: Word
instance Show IDynamic where
show (IDynamic x)= "(IDynamic \""++show (typeOf x) ++"\" "++ serialize x++")"
class DynamicInterface x where
toIDyn :: x -> IDynamic
registerType :: IO x
fromIDyn :: IDynamic -> x
unsafeFromIDyn :: IDynamic -> x
safeFromIDyn :: IDynamic -> Maybe x
instance (IResource x,Typeable x) => DynamicInterface x where
toIDyn x= IDynamic x
registerType = do
let x= unsafeCoerce 1 :: x
let deserializex str= toIDyn (deserialize str :: x)
let treadpx = do
t<- treadp :: ST x
return $ toIDyn t
let readResourcex (IDynamic s)= do
mr <- readResource (unsafeCoerce s :: x) :: IO (Maybe x)
case mr of
Nothing -> return Nothing
Just s' -> return $ Just $ IDynamic s'
l <- takeMVar list
let key= hash x
case M.lookup key l of
Just _ -> do
putMVar list l
return x
_ -> do
putMVar list $ insert key (readResourcex, deserializex, treadpx ) l
return x
fromIDyn d@(IDynamic a)= if type2 == type1 then v
else error ("fromIDyn: casting "++ show type1 ++" to type "++show type2 ++" for data "++ serialize a)
where
v= unsafeCoerce a :: x
type1= typeOf a
type2= typeOf v
unsafeFromIDyn (IDynamic a)= unsafeCoerce a
safeFromIDyn (IDynamic a)= let v= unsafeCoerce a :: x in if typeOf a == typeOf v then Just v else Nothing
data Key = Key TypeRep String deriving Typeable
instance IResource Key where
keyResource (Key _ k)=k
serialize _= error "Key is not serializable"
deserialize _= error "Key is not serializable"
writeResource _= error "Please don't create Key objects"
readResource key@(Key t _)=
case M.lookup type1 (unsafePerformIO $ readMVar list) of
Nothing -> error $ "not registered type "++show t++" please registerType it"
Just (f,_,_) -> do
d <- f . toIDyn $ key
return $ dynMaybe d
where
dynMaybe (Just dyn)= return $ fromIDyn dyn
type1= hash t