{-# LANGUAGE CPP, ExistentialQuantification, DeriveDataTypeable, ScopedTypeVariables #-}
module Data.Binary.Shared (
BinaryShared(..)
, encodeFileSer
, encodeSer
, decodeSer
) where
import Data.Typeable (cast,Typeable(..))
#if MIN_VERSION_base(4,6,0)
import Data.Typeable (typeOf)
#else
import Data.Typeable (typeRepKey)
import System.IO.Unsafe (unsafePerformIO)
#endif
import qualified Control.Monad.State as St (StateT(..),get,put)
import Data.Map (Map(..))
import qualified Data.Map as Map (empty,fromDistinctAscList,toAscList,Map(..),insert,lookup)
import Data.IntMap (IntMap(..))
import qualified Data.IntMap as IMap (empty,IntMap(..),insert,lookup)
import qualified Data.Binary as Bin (getWord8,putWord8,Get(..),Binary(..))
import Data.Binary.Put (runPut,PutM(..),putWord64be)
import Control.Monad.Trans (lift)
import Control.Monad (liftM2,replicateM,liftM)
import qualified Data.Set as Set (fromDistinctAscList,toAscList,Set(..))
import qualified Data.ByteString.Lazy as L
import Data.ByteString (ByteString(..))
import Control.Monad.State.Lazy (evalStateT)
import Data.Binary.Get (runGet,getWord64be)
class (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => BinaryShared alpha where
put :: alpha -> PutShared
putShared :: (alpha -> PutShared) -> alpha -> PutShared
putShared alpha -> PutShared
fput alpha
v = do
(Map Object Int
dict, Int
unique) <- StateT (Map Object Int, Int) PutM (Map Object Int, Int)
forall s (m :: * -> *). MonadState s m => m s
St.get
case (alpha -> Object
forall alpha.
(Typeable alpha, Ord alpha, Eq alpha, Show alpha) =>
alpha -> Object
ObjC alpha
v) Object -> Map Object Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Object Int
dict of
Just Int
i -> PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Word8 -> PutM ()
Bin.putWord8 Word8
0 PutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> PutM ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
Maybe Int
Nothing -> do
(Map Object Int, Int) -> PutShared
forall s (m :: * -> *). MonadState s m => s -> m ()
St.put (Map Object Int
dict,Int
unique Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Word8 -> PutM ()
Bin.putWord8 Word8
1)
PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Word64 -> PutM ()
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
unique))
alpha -> PutShared
fput alpha
v
(Map Object Int
dict2, Int
unique2) <- StateT (Map Object Int, Int) PutM (Map Object Int, Int)
forall s (m :: * -> *). MonadState s m => m s
St.get
let newDict :: Map Object Int
newDict = Object -> Int -> Map Object Int -> Map Object Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (alpha -> Object
forall alpha.
(Typeable alpha, Ord alpha, Eq alpha, Show alpha) =>
alpha -> Object
ObjC alpha
v) Int
unique Map Object Int
dict2
(Map Object Int, Int) -> PutShared
forall s (m :: * -> *). MonadState s m => s -> m ()
St.put (Map Object Int
newDict,Int
unique2)
get :: GetShared alpha
getShared :: GetShared alpha -> GetShared alpha
getShared GetShared alpha
f = do
IntMap Object
dict <- StateT (IntMap Object) Get (IntMap Object)
forall s (m :: * -> *). MonadState s m => m s
St.get
Word8
w <- Get Word8 -> StateT (IntMap Object) Get Word8
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Word8
Bin.getWord8
case Word8
w of
Word8
0 -> do
Int
i <- Get Int -> StateT (IntMap Object) Get Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Word64 -> Int) -> Get Word64 -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
getWord64be))
case Int -> IntMap Object -> Maybe Object
forall a. Int -> IntMap a -> Maybe a
IMap.lookup Int
i IntMap Object
dict of
Just (ObjC alpha
obj) -> alpha -> GetShared alpha
forall a. a -> StateT (IntMap Object) Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe alpha -> String -> alpha
forall alpha. Maybe alpha -> String -> alpha
forceJust (alpha -> Maybe alpha
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast alpha
obj)
String
"Shared>>getShared: Cast failed")
Maybe Object
Nothing -> String -> GetShared alpha
forall a. HasCallStack => String -> a
error (String -> GetShared alpha) -> String -> GetShared alpha
forall a b. (a -> b) -> a -> b
$ String
"Shared>>getShared : Dont find in Map " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
Word8
1 -> do
Int
i <- Get Int -> StateT (IntMap Object) Get Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Word64 -> Int) -> Get Word64 -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
getWord64be))
alpha
obj <- GetShared alpha
f
IntMap Object
dict2 <- StateT (IntMap Object) Get (IntMap Object)
forall s (m :: * -> *). MonadState s m => m s
St.get
IntMap Object -> StateT (IntMap Object) Get ()
forall s (m :: * -> *). MonadState s m => s -> m ()
St.put (Int -> Object -> IntMap Object -> IntMap Object
forall a. Int -> a -> IntMap a -> IntMap a
IMap.insert Int
i (alpha -> Object
forall alpha.
(Typeable alpha, Ord alpha, Eq alpha, Show alpha) =>
alpha -> Object
ObjC alpha
obj) IntMap Object
dict2)
alpha -> GetShared alpha
forall a. a -> StateT (IntMap Object) Get a
forall (m :: * -> *) a. Monad m => a -> m a
return alpha
obj
Word8
_ -> String -> GetShared alpha
forall a. HasCallStack => String -> a
error (String -> GetShared alpha) -> String -> GetShared alpha
forall a b. (a -> b) -> a -> b
$ String
"Shared>>getShared : Encoding error"
encodeSer :: BinaryShared a => a -> L.ByteString
encodeSer :: forall a. BinaryShared a => a -> ByteString
encodeSer a
v = PutM () -> ByteString
runPut (PutShared -> (Map Object Int, Int) -> PutM ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (a -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put a
v) (Map Object Int
forall k a. Map k a
Map.empty,Int
0))
encodeFileSer :: BinaryShared a => FilePath -> a -> IO ()
encodeFileSer :: forall a. BinaryShared a => String -> a -> IO ()
encodeFileSer String
f a
v = String -> ByteString -> IO ()
L.writeFile String
f (a -> ByteString
forall a. BinaryShared a => a -> ByteString
encodeSer a
v)
decodeSer :: BinaryShared alpha => L.ByteString -> alpha
decodeSer :: forall alpha. BinaryShared alpha => ByteString -> alpha
decodeSer = Get alpha -> ByteString -> alpha
forall a. Get a -> ByteString -> a
runGet (StateT (IntMap Object) Get alpha -> IntMap Object -> Get alpha
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (IntMap Object) Get alpha
forall alpha. BinaryShared alpha => GetShared alpha
get IntMap Object
forall a. IntMap a
IMap.empty)
data Object = forall alpha. (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => ObjC {()
unObj :: alpha}
instance Eq Object where
(ObjC alpha
a) == :: Object -> Object -> Bool
== (ObjC alpha
b) = if alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
a TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
b
then Bool
False
else (alpha -> Maybe alpha
forall a. a -> Maybe a
Just alpha
a) Maybe alpha -> Maybe alpha -> Bool
forall a. Eq a => a -> a -> Bool
== alpha -> Maybe alpha
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast alpha
b
instance Ord Object where
compare :: Object -> Object -> Ordering
compare (ObjC alpha
a) (ObjC alpha
b) = if alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
a TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
b
#if MIN_VERSION_base(4,6,0)
then TypeRep -> TypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
a) (alpha -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf alpha
b)
#else
then compare ((unsafePerformIO . typeRepKey . typeOf) a)
((unsafePerformIO . typeRepKey . typeOf) b)
#endif
else Maybe alpha -> Maybe alpha -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (alpha -> Maybe alpha
forall a. a -> Maybe a
Just alpha
a) (alpha -> Maybe alpha
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast alpha
b)
type PutShared = St.StateT (Map Object Int, Int) PutM ()
type GetShared = St.StateT (IntMap Object) Bin.Get
instance BinaryShared a => BinaryShared [a] where
put :: [a] -> PutShared
put = ([a] -> PutShared) -> [a] -> PutShared
forall alpha.
BinaryShared alpha =>
(alpha -> PutShared) -> alpha -> PutShared
putShared (\[a]
l -> PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l)) PutShared -> PutShared -> PutShared
forall a b.
StateT (Map Object Int, Int) PutM a
-> StateT (Map Object Int, Int) PutM b
-> StateT (Map Object Int, Int) PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> PutShared) -> [a] -> PutShared
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put [a]
l)
get :: GetShared [a]
get = GetShared [a] -> GetShared [a]
forall alpha.
BinaryShared alpha =>
GetShared alpha -> GetShared alpha
getShared (do
Int
n <- Get Int -> StateT (IntMap Object) Get Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get Int
forall t. Binary t => Get t
Bin.get :: Bin.Get Int)
Int -> StateT (IntMap Object) Get a -> GetShared [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT (IntMap Object) Get a
forall alpha. BinaryShared alpha => GetShared alpha
get)
instance (BinaryShared a) => BinaryShared (Maybe a) where
put :: Maybe a -> PutShared
put Maybe a
Nothing = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Word8 -> PutM ()
Bin.putWord8 Word8
0)
put (Just a
x) = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Word8 -> PutM ()
Bin.putWord8 Word8
1) PutShared -> PutShared -> PutShared
forall a b.
StateT (Map Object Int, Int) PutM a
-> StateT (Map Object Int, Int) PutM b
-> StateT (Map Object Int, Int) PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put a
x
get :: GetShared (Maybe a)
get = do
Word8
w <- Get Word8 -> StateT (IntMap Object) Get Word8
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get Word8
Bin.getWord8)
case Word8
w of
Word8
0 -> Maybe a -> GetShared (Maybe a)
forall a. a -> StateT (IntMap Object) Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Word8
_ -> (a -> Maybe a)
-> StateT (IntMap Object) Get a -> GetShared (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just StateT (IntMap Object) Get a
forall alpha. BinaryShared alpha => GetShared alpha
get
instance (BinaryShared a, BinaryShared b) => BinaryShared (a,b) where
put :: (a, b) -> PutShared
put (a
a,b
b) = a -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put a
a PutShared -> PutShared -> PutShared
forall a b.
StateT (Map Object Int, Int) PutM a
-> StateT (Map Object Int, Int) PutM b
-> StateT (Map Object Int, Int) PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put b
b
get :: GetShared (a, b)
get = (a -> b -> (a, b))
-> StateT (IntMap Object) Get a
-> StateT (IntMap Object) Get b
-> GetShared (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) StateT (IntMap Object) Get a
forall alpha. BinaryShared alpha => GetShared alpha
get StateT (IntMap Object) Get b
forall alpha. BinaryShared alpha => GetShared alpha
get
instance BinaryShared a => BinaryShared (Set.Set a) where
put :: Set a -> PutShared
put Set a
s = [a] -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put (Set a -> [a]
forall a. Set a -> [a]
Set.toAscList Set a
s)
get :: GetShared (Set a)
get = ([a] -> Set a)
-> StateT (IntMap Object) Get [a] -> GetShared (Set a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [a] -> Set a
forall a. [a] -> Set a
Set.fromDistinctAscList StateT (IntMap Object) Get [a]
forall alpha. BinaryShared alpha => GetShared alpha
get
instance (BinaryShared k, BinaryShared e) => BinaryShared (Map.Map k e) where
put :: Map k e -> PutShared
put Map k e
m = [(k, e)] -> PutShared
forall alpha. BinaryShared alpha => alpha -> PutShared
put (Map k e -> [(k, e)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k e
m)
get :: GetShared (Map k e)
get = ([(k, e)] -> Map k e)
-> StateT (IntMap Object) Get [(k, e)] -> GetShared (Map k e)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(k, e)] -> Map k e
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList StateT (IntMap Object) Get [(k, e)]
forall alpha. BinaryShared alpha => GetShared alpha
get
instance BinaryShared Bool where
put :: Bool -> PutShared
put = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PutM () -> PutShared) -> (Bool -> PutM ()) -> Bool -> PutShared
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put
get :: GetShared Bool
get = Get Bool -> GetShared Bool
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Bool
forall t. Binary t => Get t
Bin.get
instance BinaryShared Char where
put :: Char -> PutShared
put = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PutM () -> PutShared) -> (Char -> PutM ()) -> Char -> PutShared
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put
get :: GetShared Char
get = Get Char -> GetShared Char
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Char
forall t. Binary t => Get t
Bin.get
instance BinaryShared Int where
put :: Int -> PutShared
put = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PutM () -> PutShared) -> (Int -> PutM ()) -> Int -> PutShared
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put
get :: StateT (IntMap Object) Get Int
get = Get Int -> StateT (IntMap Object) Get Int
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Int
forall t. Binary t => Get t
Bin.get
instance BinaryShared Integer where
put :: Integer -> PutShared
put = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PutM () -> PutShared)
-> (Integer -> PutM ()) -> Integer -> PutShared
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put
get :: GetShared Integer
get = Get Integer -> GetShared Integer
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Integer
forall t. Binary t => Get t
Bin.get
instance BinaryShared ByteString where
put :: ByteString -> PutShared
put = PutM () -> PutShared
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Object Int, Int) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PutM () -> PutShared)
-> (ByteString -> PutM ()) -> ByteString -> PutShared
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PutM ()
forall t. Binary t => t -> PutM ()
Bin.put
get :: GetShared ByteString
get = Get ByteString -> GetShared ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (IntMap Object) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get ByteString
forall t. Binary t => Get t
Bin.get
forceJust :: Maybe alpha -> String -> alpha
forceJust :: forall alpha. Maybe alpha -> String -> alpha
forceJust Maybe alpha
mb String
str = case Maybe alpha
mb of
Maybe alpha
Nothing -> String -> alpha
forall a. HasCallStack => String -> a
error String
str
Just alpha
it -> alpha
it