module Data.HMemDb.Bin
(
Bin(binGet, binPut),
IsId(isId),
Proxy(Proxy, unProxy),
TableGetData(TableGetData),
TableRefs(TRNil, TRPair, TRProxy, TRVar)
) where
import Control.Applicative (liftA2, (<$>))
import Control.Compose (Id, unId, (:.))
import Control.Concurrent.STM (TVar, readTVar)
import Control.Monad.Trans.Class (lift)
import Data.Binary (Binary(get, put), Get, Put)
import qualified Data.Map as M (Map, lookup)
import Data.HMemDb.Binary (MS)
import Data.HMemDb.References (CRef(CRef), Ref(Ref, refContent, refIndex))
import Data.HMemDb.Utils (liftMaybe, oBind, pureO)
data Proxy a = Proxy {unProxy :: a}
data TableGetData a where
TableGetData :: (r -> MS a) -> TVar (M.Map Integer (TVar (Maybe r))) -> TableGetData a
data TableRefs r where
TRNil :: TableRefs ()
TRProxy :: TableRefs (Proxy r)
TRVar :: TableGetData a -> TableRefs (CRef a)
TRPair :: TableRefs r1 -> TableRefs r2 -> TableRefs (r1, r2)
class Bin r where
binPut :: r -> Put
binGet :: TableRefs r -> (Get :. MS) r
instance Bin () where
binPut = put
binGet TRNil = pureO $ return ()
instance Binary r => Bin (Proxy r) where
binPut = put . unProxy
binGet TRProxy = pureO $ Proxy <$> get
class IsId s where
isId :: s a -> a
isIdTR :: TableRefs (f s a) -> TableRefs (f Id a)
isIdTRBack :: f Id a -> f s a
instance IsId Id where
isId = unId
isIdTR = id
isIdTRBack = id
tableVarBinGet :: TableRefs (CRef a) -> Integer -> MS (CRef a)
tableVarBinGet (TRVar (TableGetData to cnt)) n =
do mp <- lift $ readTVar cnt
ref <- liftMaybe $ M.lookup n mp
return $ CRef (Ref {refContent = ref, refIndex = n}) to
instance Bin (CRef a) where
binPut (CRef ref _) = put $ refIndex ref
binGet tref = pureO get `oBind` tableVarBinGet tref
instance (Bin r1, Bin r2) => Bin (r1, r2) where
binPut (r1, r2) = binPut r1 >> binPut r2
binGet (TRPair tr1 tr2) = liftA2 (,) (binGet tr1) (binGet tr2)