{-# LANGUAGE ExistentialQuantification, UndecidableInstances,
      ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances,
      IncoherentInstances, OverloadedStrings, MultiParamTypeClasses,
      FlexibleInstances #-}

{- |
IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects
in the cache so any new datatype can be incrementally stored without recompilation.
IDimamic provices methods for safe casting,  besides serializaton, deserialirezation and retrieval by key.
-}
module Data.Persistent.IDynamic where
import Data.Typeable
import System.IO.Unsafe

import Data.ByteString.Lazy.Char8 as B

import Control.Exception(handle, SomeException)
import Data.IORef
import Data.RefSerialize

--import Debug.Trace
--(!>)= flip trace


newtype IDynamic  =  IDyn  (IORef IDynType) deriving Typeable

data IDynType= forall a.(Typeable a, Serialize a)
               => DRight !a
             |  DLeft  !(ByteString ,(Context, ByteString))


               deriving Typeable

newtype Save= Save ByteString deriving Typeable

tosave :: IDynamic -> IDynamic
tosave :: IDynamic -> IDynamic
tosave d :: IDynamic
d@(IDyn IORef IDynType
r)= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
   IDynType
mr<- forall a. IORef a -> IO a
readIORef IORef IDynType
r
   case IDynType
mr of
     DRight a
_ ->  forall (m :: * -> *) a. Monad m => a -> m a
return IDynamic
d
     DLeft (ByteString
s,(Context, ByteString)
_) -> forall a. IORef a -> a -> IO ()
writeIORef IORef IDynType
r (forall a. (Typeable a, Serialize a) => a -> IDynType
DRight forall a b. (a -> b) -> a -> b
$ ByteString -> Save
Save ByteString
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return IDynamic
d


instance Serialize Save  where
  showp :: Save -> STW ()
showp (Save ByteString
s)= ByteString -> STW ()
insertString ByteString
s
  readp :: STR Save
readp = forall a. HasCallStack => [Char] -> a
error [Char]
"readp not impremented for Save"


errorfied :: String -> String -> a
errorfied :: forall a. [Char] -> [Char] -> a
errorfied [Char]
str [Char]
str2= forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
str forall a. [a] -> [a] -> [a]
++ [Char]
": IDynamic object not reified: "forall a. [a] -> [a] -> [a]
++ [Char]
str2



dynPrefix :: String
dynPrefix :: [Char]
dynPrefix= [Char]
"Dyn"

dynPrefixSp :: ByteString
dynPrefixSp :: ByteString
dynPrefixSp= ByteString -> ByteString -> ByteString
append  ([Char] -> ByteString
pack [Char]
dynPrefix) ByteString
" "

notreified :: ByteString
notreified :: ByteString
notreified = [Char] -> ByteString
pack forall a b. (a -> b) -> a -> b
$ [Char]
dynPrefix forall a. [a] -> [a] -> [a]
++[Char]
" 0"



instance Serialize IDynamic where

   showp :: IDynamic -> STW ()
showp (IDyn IORef IDynType
t)=
    case forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef IDynType
t of
     DRight a
x -> do
--          insertString $ pack dynPrefix
          (HashTable RealWorld Int (StableName Char, Char, [ShowF], Int),
 ByteString)
_ <- STW (Context, ByteString)
getWContext
          ByteString
showpx  <-  forall {p}. Serialize p => p -> STW ByteString
rshowps a
x
--          showpText . fromIntegral $ B.length showpx
          forall c. Serialize c => c -> STW ()
showp forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
showpx

     DLeft (ByteString
showpx,(Context, ByteString)
_) ->   --  error $ "IDynamic not reified :: "++  unpack showpx
--        insertString   notreified
          ByteString -> STW ()
insertString  forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode ByteString
showpx
            where
            encode :: ByteString -> ByteString
encode =   [Char] -> ByteString
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
unpack

   readp :: STR IDynamic
readp = forall {b}. STR b -> STR b
lexeme (do
--      symbol dynPrefix
--      n <- readpText
--      s <- takep n

      [Char]
s <- forall c. Serialize c => STR c
rreadp :: STR  String

      (HashTable RealWorld Int (StableName Char, Char, [ShowF], Int),
 ByteString)
c <- STR (Context, ByteString)
getRContext
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef IDynType -> IDynamic
IDyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ (ByteString, (Context, ByteString)) -> IDynType
DLeft ( [Char] -> ByteString
pack [Char]
s, (HashTable RealWorld Int (StableName Char, Char, [ShowF], Int),
 ByteString)
c))
      forall {a}. STR a -> [Char] -> STR a
<?> [Char]
"IDynamic"



instance Show  IDynamic where
 show :: IDynamic -> [Char]
show (IDyn IORef IDynType
r) =
    let t :: IDynType
t= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef IDynType
r
    in case IDynType
t of
      DRight a
x -> [Char]
"IDyn " forall a. [a] -> [a] -> [a]
++  ( ByteString -> [Char]
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. STW () -> ByteString
runW forall a b. (a -> b) -> a -> b
$ forall c. Serialize c => c -> STW ()
showp  a
x)
      DLeft (ByteString
s, (Context, ByteString)
_) ->  [Char]
"IDyns \"" forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
unpack ByteString
s forall a. [a] -> [a] -> [a]
++ [Char]
"\""





toIDyn :: (Typeable a, Serialize a) => a -> IDynamic
toIDyn :: forall a. (Typeable a, Serialize a) => a -> IDynamic
toIDyn a
x= IORef IDynType -> IDynamic
IDyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Serialize a) => a -> IDynType
DRight a
x

-- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization"
serializedEqual :: IDynamic -> ByteString -> Bool
serializedEqual :: IDynamic -> ByteString -> Bool
serializedEqual (IDyn IORef IDynType
r) ByteString
str= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  IDynType
t <- forall a. IORef a -> IO a
readIORef IORef IDynType
r
  case IDynType
t of
   DRight a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ STW () -> ByteString
runW (forall c. Serialize c => c -> STW ()
showp a
x) forall a. Eq a => a -> a -> Bool
== ByteString
str   -- !> ("R "++ (show $ unpack $ runW (showp x)))
   DLeft (ByteString
str', (Context, ByteString)
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
strforall a. Eq a => a -> a -> Bool
== ByteString
str'       -- !> ("L "++ (show $ unpack str' ))

fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a
fromIDyn :: forall a. (Typeable a, Serialize a) => IDynamic -> a
fromIDyn IDynamic
x= case forall a. (Typeable a, Serialize a) => IDynamic -> Either [Char] a
safeFromIDyn IDynamic
x of
          Left  [Char]
s -> forall a. HasCallStack => [Char] -> a
error [Char]
s
          Right a
v -> a
v


safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a
safeFromIDyn :: forall a. (Typeable a, Serialize a) => IDynamic -> Either [Char] a
safeFromIDyn d :: IDynamic
d@(IDyn IORef IDynType
r) = Either [Char] a
final
  where
    final :: Either [Char] a
final =
      forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
        IDynType
t <- forall a. IORef a -> IO a
readIORef IORef IDynType
r
        case IDynType
t of
          DRight a
x ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x of
              Maybe a
Nothing ->
                forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                [Char]
"fromIDyn: unable to extract from " forall a. [a] -> [a] -> [a]
++
                forall a. Show a => a -> [Char]
show IDynamic
d forall a. [a] -> [a] -> [a]
++ [Char]
" something of type: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> TypeRep
typeOf forall a b. (a -> b) -> a -> b
$ forall {a} {b}. Either a b -> b
fromRight Either [Char] a
final)
              Just a
x' -> forall a b. b -> Either a b
Right a
x'
            where fromRight :: Either a b -> b
fromRight (Right b
x') = b
x'
                  fromRight (Left a
_') = forall a. HasCallStack => [Char] -> a
error [Char]
"this will never happen?"
          DLeft (ByteString
str, (Context, ByteString)
c) ->
            forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. Show a => a -> [Char]
show SomeException
e)) forall a b. (a -> b) -> a -> b
$ -- !> ("safeFromIDyn : "++ show e)) $
             do
              let v :: a
v = forall a. (Context, ByteString) -> STR a -> ByteString -> a
runRC (Context, ByteString)
c forall c. Serialize c => STR c
rreadp ByteString
str -- !> unpack str
              forall a. IORef a -> a -> IO ()
writeIORef IORef IDynType
r forall a b. (a -> b) -> a -> b
$! forall a. (Typeable a, Serialize a) => a -> IDynType
DRight a
v -- !> ("***reified "++ unpack str)
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
v)             -- !>  ("*** end reified " ++ unpack str)



reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a
reifyM :: forall a. (Typeable a, Serialize a) => IDynamic -> a -> IO a
reifyM IDynamic
dyn a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Typeable a, Serialize a) => IDynamic -> a
fromIDyn IDynamic
dyn