{-# LANGUAGE GADTs, TypeOperators #-}
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)
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)
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
-- | This class is here for technical reasons, it should only have one instance whatsoever.
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 = readCRef to cnt n
instance Bin (CRef a) where
    binPut cref = put $ cRefIndex cref
    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)