module Data.HMemDb.Persistence (getTable, putTable) where
import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Control.Compose (oPure)
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.CreateTable (CreateTable(makeTable))
import Data.HMemDb.ForeignKeys (ForeignKey)
import Data.HMemDb.RefConverter (RefConv(RefConv))
import Data.HMemDb.Specs
(FullSpec(FullSpec, keySpec, tabSpec), TableSpec(TableSpec), makeRC)
import Data.HMemDb.Tables
(PreTable(tabContent, tabCount), 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 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 r
putTable :: Table a -> SP
putTable (Table pt) = runCont (putPreTable pt) pure
getTable :: CreateTable u => FullSpec a u -> GS (Table a, u a ForeignKey)
getTable (FullSpec {tabSpec = TableSpec cs, keySpec = ks}) =
case makeRC cs of
RefConv tr pr ->
let genPairs =
(\result tC pairs -> (result, (tC, pairs)))
<$> oPure (makeTable pr ks)
<*> pureO get
<*> (get `bindO` replicateO ((,) <$> pureO get <*> binGet tr))
insPairs ~((pt, uf), (tC, pairs)) =
do writeTVar (tabCount pt) tC
for_ pairs (runMaybeT . insertRefIntoTable pt)
return (Table pt, uf)
in genPairs `oBind` insPairs