module Data.Binary.Shared (
BinaryShared(..)
, encodeFileSer
, encodeSer
, decodeSer
) where
import Data.Typeable (typeRepKey,cast,Typeable(..))
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 System.IO.Unsafe (unsafePerformIO)
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 fput v = do
(dict, unique) <- St.get
case (ObjC v) `Map.lookup` dict of
Just i -> lift (Bin.putWord8 0 >> putWord64be (fromIntegral i))
Nothing -> do
St.put (dict,unique + 1)
lift (Bin.putWord8 1)
lift (putWord64be (fromIntegral unique))
fput v
(dict2, unique2) <- St.get
let newDict = Map.insert (ObjC v) unique dict2
St.put (newDict,unique2)
get :: GetShared alpha
getShared :: GetShared alpha -> GetShared alpha
getShared f = do
dict <- St.get
w <- lift Bin.getWord8
case w of
0 -> do
i <- lift (liftM fromIntegral (getWord64be))
case IMap.lookup i dict of
Just (ObjC obj) -> return (forceJust (cast obj)
"Shared>>getShared: Cast failed")
Nothing -> error $ "Shared>>getShared : Dont find in Map " ++ show i
1 -> do
i <- lift (liftM fromIntegral (getWord64be))
obj <- f
dict2 <- St.get
St.put (IMap.insert i (ObjC obj) dict2)
return obj
_ -> error $ "Shared>>getShared : Encoding error"
encodeSer :: BinaryShared a => a -> L.ByteString
encodeSer v = runPut (evalStateT (put v) (Map.empty,0))
encodeFileSer :: BinaryShared a => FilePath -> a -> IO ()
encodeFileSer f v = L.writeFile f (encodeSer v)
decodeSer :: BinaryShared alpha => L.ByteString -> alpha
decodeSer = runGet (evalStateT get IMap.empty)
data Object = forall alpha. (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => ObjC {unObj :: alpha}
instance Eq Object where
(ObjC a) == (ObjC b) = if typeOf a /= typeOf b
then False
else (Just a) == cast b
instance Ord Object where
compare (ObjC a) (ObjC b) = if typeOf a /= typeOf b
then compare ((unsafePerformIO . typeRepKey . typeOf) a)
((unsafePerformIO . typeRepKey . typeOf) b)
else compare (Just a) (cast 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 = putShared (\l -> lift (Bin.put (length l)) >> mapM_ put l)
get = getShared (do
n <- lift (Bin.get :: Bin.Get Int)
replicateM n get)
instance (BinaryShared a) => BinaryShared (Maybe a) where
put Nothing = lift (Bin.putWord8 0)
put (Just x) = lift (Bin.putWord8 1) >> put x
get = do
w <- lift (Bin.getWord8)
case w of
0 -> return Nothing
_ -> liftM Just get
instance (BinaryShared a, BinaryShared b) => BinaryShared (a,b) where
put (a,b) = put a >> put b
get = liftM2 (,) get get
instance BinaryShared a => BinaryShared (Set.Set a) where
put s = put (Set.toAscList s)
get = liftM Set.fromDistinctAscList get
instance (BinaryShared k, BinaryShared e) => BinaryShared (Map.Map k e) where
put m = put (Map.toAscList m)
get = liftM Map.fromDistinctAscList get
instance BinaryShared Bool where
put = lift . Bin.put
get = lift Bin.get
instance BinaryShared Char where
put = lift . Bin.put
get = lift Bin.get
instance BinaryShared Int where
put = lift . Bin.put
get = lift Bin.get
instance BinaryShared Integer where
put = lift . Bin.put
get = lift Bin.get
instance BinaryShared ByteString where
put = lift . Bin.put
get = lift Bin.get
forceJust :: Maybe alpha -> String -> alpha
forceJust mb str = case mb of
Nothing -> error str
Just it -> it