module Data.HMemDb.Persistence (fillTable, putTable) where
import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Control.Concurrent.STM (STM, TVar, readTVar, writeTVar)
import Control.Monad.Trans.Cont (Cont, runCont, cont)
import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
import Data.Binary (Binary(get, put))
import Data.Foldable (for_)
import qualified Data.Map as M (toAscList)
import Data.HMemDb.Bin (Bin (binGet, binPut))
import Data.HMemDb.Binary (GS, SP)
import Data.HMemDb.Tables
(PreTable(tabContent, tabCount, tabRefs), Table(Table), insertRefIntoTable)
import Data.HMemDb.Utils
(bindO, enumElem, fixArray, oBind, liftPure, pureO, replicateO)
putTVar :: TVar a -> Cont SP a
putTVar tv = cont $ bindO $ readTVar tv
readValue :: (a, TVar (Maybe b)) -> STM (Maybe (a, b))
readValue (n, tv) = fmap ((,) n) <$> readTVar tv
putPreTable :: Bin r -> PreTable r a -> Cont SP ()
putPreTable b pt =
do tC <- putTVar $ tabCount pt
liftPure $ put tC
mp <- putTVar $ tabContent pt
pairs <- fixArray (M.toAscList mp) readValue
liftPure $ put $ length pairs
~(n, r) <- enumElem pairs
liftPure $ put n >> binPut b r
putTable :: Table a -> SP
putTable (Table b pt) = runCont (putPreTable b pt) pure
fillTable :: Table a -> GS ()
fillTable (Table b pt) = genPairs `oBind` insPairs where
genPair = (,) <$> pureO get <*> binGet b (tabRefs pt)
genPairs = (,) <$> pureO get <*> (get `bindO` replicateO genPair)
insPairs ~(counter, pairs) =
do writeTVar (tabCount pt) counter
for_ pairs $ runMaybeT . insertRefIntoTable pt