IDynamic-0.1: Data/IDynamic.hs

{-# OPTIONS -fglasgow-exts  -XUndecidableInstances -XBangPatterns #-}
module Data.IDynamic where

import Data.Typeable
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Concurrent.MVar 
import Data.Map as M
import Data.IResource
import Data.HashTable(hashString)
import Data.Word
import Numeric (showHex, readHex)


{- |
Data.IDynamic is a indexable and serializable version  @Data.Dynamic@ .
IDinamic provices methods for safe casting,   serializaton, deserialization,
registration output and input

the data definition of IDymanic is as such:
 @data IDynamic= forall a. (Typeable a, IResource a) => IDynamic  a deriving Typeable@

The registration trough @registerType@ is necessary before deserialization:
      @'registerType'  :: IO Type@

example:


@module Main where
import Data.IResource
import Data.IDynamic
import Data.Typeable

instance IResource Int where     
       keyResource x=  \"I\"
       serialize = show
       deserialize = read
       defPath _= \"data/ \"

instance IResource String where
       keyResource x=  take 5 x
       serialize = show
       deserialize = read
       defPath _= \"data/\"
               
main= do
      putStrLn \"see the code to know the meaning of he results\"
      registerType :: IO Int           -- register both datatypes (Int, and String)
      registerType :: IO String
      let x= 1 :: Int

      let list= [IDynamic x, IDynamic \"hello, how are you\"]

      let assoc= zip (map keyResource list) list
      print $ lookup (keyResource (5 ::Int)) assoc

      mapM writeResource list
      mds <-  readResource $  IDynamic  \"hello\"
      case mds of
            Nothing -> error \"must have been Just!\"
            Just ds -> do
                     putStrLn $ serialize ds
                     let str= fromIDyn  ds ::   String
                     putStrLn str

                     let y=  fromIDyn  ds ::   Int   -- casting error
                     print y@






-}

data IDynamic= forall a. (Typeable a, IResource a) => IDynamic  a deriving Typeable


list :: MVar (Map Word  (IDynamic -> IO (Maybe IDynamic), String -> 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


            
   defPath (IDynamic x)= defPath x

   writeResource (IDynamic  x)=  writeResource  x

   readResource  d@(IDynamic x)
     | typeOfx==  typeOf Key= do
                                          mx <- readResource x    --`debug` ("retrieving key "++ show (typeOf 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++")"
  

-- | DynamicInterface groups a set of default method calls to handle dynamic objects. It is not necessary to derive instances from it

class DynamicInterface  x where
     toIDyn :: x     -> IDynamic     -- ^ encapsulates data in a dynamic object
     registerType ::   IO x                -- ^ registers the deserialize, readp and readResource methods for this data type
     fromIDyn :: IDynamic -> x    -- ^ extract the data from the dynamic object. trows a user error when the cast fails
     unsafeFromIDyn :: IDynamic -> x      -- ^ unsafe version.
     safeFromIDyn :: IDynamic -> Maybe x     -- ^ safe extraction with Maybe

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 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)  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

{- | Key datatype can be used to read any object trough the Dynamic interface.

        @ data Key =  Key 'TypeRep' String deriving Typeable @

         Example
         
        @  mst <- 'getDResource' $ 'Key' type 'keyofDesiredObject'
             case mst of
               Nothing -> error $ \"not found \"++ key
               Just (idyn) ->  fromIDyn idyn :: DesiredDatatype}@
-}

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