{-# LANGUAGE GADTs, TypeOperators #-}
module Data.HMemDb.Bin
    (
     Bin(Bin, binGet, binPut),
     Proxy(Proxy, unProxy),
     TableGetData(TableGetData),
     TableRefs(TRNil, TRPair, TRProxy, TRVar),
     binUnit, binProxy, binCRef, binPair
    ) where
import Control.Applicative (liftA2, (<$>))
import Control.Compose ((:.))
import Control.Concurrent.STM (TVar)
import Data.Binary (Binary(get, put), Get, Put)
import Data.Map (Map)
import Data.HMemDb.MapTVar (MS)
import Data.HMemDb.References (CRef, cRefIndex, readCRef)
import Data.HMemDb.Utils (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 (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)
data Bin r =
    Bin
    {
      binPut :: r -> Put,
      binGet :: TableRefs r -> (Get :. MS) r
    }
binUnit :: Bin ()
binUnit = Bin {binPut = put, binGet = \TRNil -> pureO $ return ()}
binProxy :: Binary r => Bin (Proxy r)
binProxy = Bin {binPut = put . unProxy, binGet = \TRProxy -> pureO $ Proxy <$> get}
tableVarBinGet :: TableRefs (CRef a) -> Integer -> MS (CRef a)
tableVarBinGet (TRVar (TableGetData to cnt)) n = readCRef to cnt n
binCRef :: Bin (CRef a)
binCRef =
    Bin
    {
      binPut = put . cRefIndex,
      binGet = \tref -> pureO get `oBind` tableVarBinGet tref
    }
binPair :: Bin r1 -> Bin r2 -> Bin (r1, r2)
binPair b1 b2 =
    Bin
    {
      binPut = \ ~(r1, r2) -> binPut b1 r1 >> binPut b2 r2,
      binGet = \(TRPair tr1 tr2) -> liftA2 (,) (binGet b1 tr1) (binGet b2 tr2)
    }