{-# LANGUAGE GADTs, TypeOperators #-}
module Data.HMemDb.Bin
    (
     Bin(binGet, binPut),
     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} -- should be newtype, but GHC gives annoying warnings.
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)