module Data.HMemDb
(
MS,
Multitude, Single, Multiple,
Table, Key,
TableVarU, TableVar, TableVars, fromList, toList, readVar, readRefs,
Spec (Spec, sRefs, sKeys),
TableRef, only, some,
RefsC, Refs (Refs), RefsComponent, Ref, (:&:)((:&:)), splitRef,
KeySpec, single, multiple, single_, multiple_,
KeysC, Keys (Keys), KeysComponent, KeyRef, (:+:)((:+:)), splitKey,
Created (Created),
createTable, select, select_, selectBetween, insert, update, update_, delete,
getTable, getTable_, getTable__,
putTable, putTable_, putTable__
) where
import Control.Concurrent.STM (STM, TVar, modifyTVar', newTVar, readTVar, writeTVar)
import Control.Monad (forM, forM_, guard, liftM, liftM2, replicateM)
import Control.Monad.STM.Class (MonadSTM, liftSTM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import Data.Binary (Binary (get, put), Get, Put)
import Data.Functor.Identity (Identity (Identity, runIdentity))
import qualified Data.Map as M
(Map, empty,
elems, fromList, toList,
alter, delete, insert, lookup, update,
maxViewWithKey, minViewWithKey, splitLookup)
import Data.Maybe (fromMaybe)
import qualified Data.Set as S (Set, delete, fromList, insert, null, singleton, toList)
liftMaybe :: Monad m => Maybe a -> MaybeT m a
liftMaybe = MaybeT . return
type MS = MaybeT STM
newtype Single = Single {sVal :: Integer} deriving (Eq, Ord)
newtype Multiple = Multiple {mVal :: S.Set Integer} deriving Eq
class Binary u => Multitude u where
mToList :: u -> [Integer]
mSingleton :: Integer -> u
mInsert :: Integer -> u -> Maybe u
mDelete :: Integer -> u -> Maybe u
instance Binary Single where
get = fmap Single get
put = put . sVal
instance Multitude Single where
mToList = return . sVal
mSingleton = Single
mInsert _ _ = Nothing
mDelete n s = guard (n /= sVal s) >> return s
instance Binary Multiple where
get = fmap Multiple get
put = put . mVal
instance Multitude Multiple where
mToList = S.toList . mVal
mSingleton = Multiple . S.singleton
mInsert n u = return $ u {mVal = S.insert n $ mVal u}
mDelete n u =
let s = S.delete n $ mVal u in if S.null s then Nothing else Just (Multiple s)
data TableVarU t a u = TableVar {tvVal :: u} deriving (Eq, Ord)
type TableVar t a = TableVarU t a Single
type TableVars t a = TableVarU t a Multiple
fromList :: [TableVar t a] -> TableVars t a
fromList vs = TableVar $ Multiple $ S.fromList $ map (sVal . tvVal) vs
toList :: TableVars t a -> [TableVar t a]
toList v = map (TableVar . Single) $ S.toList $ mVal $ tvVal v
data KeyBack r a i u =
KeyBack
{
kbMap :: TVar (M.Map i u),
kbKey :: a -> r TableVarU -> i
}
data PreTable t r k a =
PreTable
{
tMap :: TVar (M.Map Integer (TVar (a, r TableVarU))),
tKey :: k (KeyBack r a)
}
class KeysC k where
forKeys
:: Monad m =>
k f
-> (forall i u. (Multitude u, Ord i) => f i u -> m (g i u))
-> m (k g)
data Keys (f :: * -> * -> *) = Keys
instance KeysC Keys where forKeys ~Keys _ = return Keys
data KeyRef i u
data (ks :+: k) f where (:+:) :: ks f -> f i u -> (ks :+: KeyRef i u) f
infixl 5 :+:
splitKey :: (ks :+: KeyRef i u) f -> (ks f, f i u)
splitKey (ksf :+: fiu) = (ksf, fiu)
class KeysComponent k where
forKeysComponent
:: (KeysC ks, Monad m) =>
(ks :+: k) f
-> (forall i u. (Multitude u, Ord i) => f i u -> m (g i u))
-> m ((ks :+: k) g)
instance (KeysC ks, KeysComponent k) => KeysC (ks :+: k) where forKeys = forKeysComponent
instance (Multitude u, Ord i) => KeysComponent (KeyRef i u) where
forKeysComponent (ksf :+: fiu) action =
liftM2 (:+:) (forKeys ksf action) (action fiu)
class RefsC r where
putRefs
:: Monad m =>
r f
-> (forall t a u. Multitude u => f t a u -> m ())
-> m ()
getRefs
:: Monad m =>
(forall t a u. Multitude u => m (f t a u))
-> m (r f)
data Refs (f :: * -> * -> * -> *) = Refs
instance RefsC Refs where
putRefs ~Refs _ = return ()
getRefs _ = return Refs
data Ref t a u
data (rs :&: r) f where (:&:) :: rs f -> f t a u -> (rs :&: Ref t a u) f
infix 5 :&:
splitRef :: (rs :&: Ref t a u) f -> (rs f, f t a u)
splitRef (rsf :&: ftau) = (rsf, ftau)
class RefsComponent r where
putRefsComponent
:: (RefsC rs, Monad m) =>
(rs :&: r) f
-> (forall t a u. Multitude u => f t a u -> m ())
-> m ()
getRefsComponent
:: (RefsC rs, Monad m) =>
(forall t a u. Multitude u => m (f t a u))
-> m ((rs :&: r) f)
instance (RefsC rs, RefsComponent r) => RefsC (rs :&: r) where
putRefs = putRefsComponent
getRefs = getRefsComponent
instance Multitude u => RefsComponent (Ref t a u) where
putRefsComponent (rsf :&: ftau) action = putRefs rsf action >> action ftau
getRefsComponent action = liftM2 (:&:) (getRefs action) action
data Table t r a where
Table :: (KeysC k, RefsC r) => PreTable t r k a -> TVar Integer -> Table t r a
newtype Key t a i u = Key {kVal :: TVar (M.Map i u)}
newtype KeySpec r a i u = KeySpec {ksVal :: a -> r TableVarU -> i}
single_ :: (a -> r TableVarU -> i) -> KeySpec r a i Single
single_ = KeySpec
multiple_ :: (a -> r TableVarU -> i) -> KeySpec r a i Multiple
multiple_ = KeySpec
single :: (a -> i) -> KeySpec r a i Single
single f = single_ $ const . f
multiple :: (a -> i) -> KeySpec r a i Multiple
multiple f = multiple_ $ const . f
data TableRef t a u = TableRef
only :: Table t r a -> TableRef t a Single
only = const TableRef
some :: Table t r a -> TableRef t a Multiple
some = const TableRef
data Spec r k a =
Spec
{
sRefs :: r TableRef,
sKeys :: k (KeySpec r a)
}
data Created r k a where Created :: Table t r a -> k (Key t a) -> Created r k a
data KeyProcess r a i u =
KeyProcess
{
kpBack :: KeyBack r a i u,
kpMap :: M.Map i u
}
insertMap :: (Multitude u, Ord k) => Integer -> k -> M.Map k u -> Maybe (M.Map k u)
insertMap n i km =
case M.lookup i km of
Nothing -> return $ M.insert i (mSingleton n) km
Just u -> flip (M.insert i) km `fmap` mInsert n u
forKeys_
:: (KeysC k, Monad m) =>
k f
-> (forall i u. (Multitude u, Ord i) => f i u -> m ())
-> m ()
forKeys_ ks action = forKeys ks (\k -> action k >> return k) >> return ()
createTable :: (KeysC k, RefsC r) => Spec r k a -> STM (Created r k a)
createTable s =
do counter <- newTVar 0
tm <- newTVar M.empty
tk <-
forKeys (sKeys s) $ \ks ->
do kbm <- newTVar M.empty
return KeyBack {kbMap = kbm, kbKey = ksVal ks}
let cTable = Table PreTable {tMap = tm, tKey = tk} counter
cKeys = runIdentity $ forKeys tk $ Identity . Key . kbMap
return $ Created cTable cKeys
select :: Ord i => Key t a i Single -> i -> MS (TableVar t a)
select k i = fmap TableVar $ lift (readTVar $ kVal k) >>= liftMaybe . M.lookup i
listUnMaybe :: Maybe [a] -> [a]
listUnMaybe Nothing = []
listUnMaybe (Just as) = as
select_ ::
(Multitude u, Ord i)
=> Key t a i u
-> i
-> (forall o. Ord o => o -> o -> Bool)
-> STM [TableVar t a]
select_ k i c =
do kv <- readTVar $ kVal k
let ~(l, e, g) = M.splitLookup i kv
lvs =
do ~((li, _), _) <- M.minViewWithKey l
guard $ i `c` li
return $ M.elems l >>= mToList
evs =
do u <- e
guard $ i `c` i
return $ mToList u
gvs =
do ~((gi, _), _) <- M.maxViewWithKey g
guard $ i `c` gi
return $ M.elems g >>= mToList
return $ map (TableVar . Single) $ [lvs, evs, gvs] >>= listUnMaybe
selectBetween
:: (Multitude u, Ord i) =>
Key t a i u
-> i
-> Bool
-> i
-> Bool
-> STM [TableVar t a]
selectBetween k il bl ig bg =
do kv <- readTVar $ kVal k
let ~(_, l, mgu) = M.splitLookup il kv
~(m, g, _) = M.splitLookup ig mgu
lvs = if bl then fmap mToList l else Nothing
mvs = return $ M.elems m >>= mToList
gvs = if bg then fmap mToList g else Nothing
return $ map (TableVar . Single) $ [lvs, mvs, gvs] >>= listUnMaybe
insert :: Table t r a -> a -> r TableVarU -> MS (TableVar t a)
insert (Table pt counter) a r =
do c <- lift $ readTVar counter
kps <-
forKeys (tKey pt) $ \kb ->
do km <- lift $ readTVar $ kbMap kb
km' <- liftMaybe $ insertMap c (kbKey kb a r) km
return KeyProcess {kpBack = kb, kpMap = km'}
lift $ do
writeTVar counter $! c + 1
forKeys_ kps $ \kp -> writeTVar (kbMap $ kpBack kp) $ kpMap kp
pr <- newTVar (a, r)
modifyTVar' (tMap pt) $ M.insert c pr
return $ TableVar $ Single c
readVar :: Table t r a -> TableVar t a -> MS a
readVar (Table pt _) v =
do mp <- lift $ readTVar $ tMap pt
pr <- liftMaybe $ M.lookup (sVal $ tvVal v) mp
~(a, _) <- lift $ readTVar pr
return a
readRefs :: Table t r a -> TableVar t a -> MS (r TableVarU)
readRefs (Table pr _) v =
fmap snd $ lift (readTVar $ tMap pr) >>=
liftMaybe . M.lookup (sVal $ tvVal v) >>= lift . readTVar
update_ :: Table t r a -> TableVar t a -> a -> r TableVarU -> MS ()
update_ (Table pt _) v a r =
do let n = sVal $ tvVal v
pr <- lift (readTVar $ tMap pt) >>= liftMaybe . M.lookup n
~(a', r') <- lift $ readTVar pr
kps <-
forKeys (tKey pt) $ \kb ->
do km <- lift $ readTVar $ kbMap kb
km' <-
liftMaybe $
insertMap n (kbKey kb a r) $
M.update (mDelete n) (kbKey kb a' r') km
return KeyProcess {kpBack = kb, kpMap = km'}
lift $ do
forKeys_ kps $ \kp -> writeTVar (kbMap $ kpBack kp) $ kpMap kp
writeTVar pr (a, r)
update :: Table t r a -> TableVar t a -> a -> MS ()
update t v a = readRefs t v >>= update_ t v a
delete :: Table t r a -> TableVar t a -> MS ()
delete (Table pt _) v =
do let n = sVal $ tvVal v
tm <- lift $ readTVar $ tMap pt
pr <- liftMaybe $ M.lookup n tm
lift $ do
~(a, r) <- readTVar pr
forKeys_ (tKey pt) $ \kb ->
modifyTVar' (kbMap kb) $ M.update (mDelete n) (kbKey kb a r)
writeTVar (tMap pt) $! M.delete n tm
getTable__ :: (Monad m, MonadSTM m) => Get (m a) -> Table t r a -> Get (m ())
getTable__ g (Table pt c) =
do l <- get
listM <-
replicateM l $ do
i <- get :: Get Integer
ma <- g
r <- getRefs $ liftM TableVar get
return (i, ma, r)
n <- get
return $ do
list <- forM listM $ \ ~(i, ma, r) -> liftM (\a -> (i, a, r)) ma
let result =
do forKeys_ (tKey pt) $ \kb -> writeTVar (kbMap kb) M.empty
tm <-
forM list $ \ ~(i, a, r) ->
do pr <- newTVar (a, r)
forKeys_ (tKey pt) $ \kb ->
modifyTVar' (kbMap kb) $
flip M.alter (kbKey kb a r) $ Just . \mu ->
case mu of
Nothing -> mSingleton i
Just u -> fromMaybe u $ mInsert i u
return (i, pr)
writeTVar (tMap pt) $ M.fromList tm
writeTVar c n
liftSTM result
getTable_ :: Get a -> Table t r a -> Get (STM ())
getTable_ g = getTable__ $ fmap return g
getTable :: Binary a => Table t r a -> Get (STM ())
getTable = getTable_ get
putTable__ :: (Monad m, MonadSTM m) => (a -> m Put) -> Table t r a -> m Put
putTable__ p (Table pt c) =
do ~(listM, n) <-
liftSTM $ do
tm <- readTVar $ tMap pt
list <-
forM (M.toList tm) $ \ ~(i, v) ->
do ~(a, r) <- readTVar v
return (i, a, r)
n <- readTVar c
return (list, n)
list <- forM listM $ \ ~(i, a, r) -> liftM (\pa -> (i, pa, r)) $ p a
return $ do
put $ length list
forM_ list $ \ ~(i, pa, r) ->
do put i
pa
putRefs r $ \v -> put (tvVal v)
put n
putTable_ :: (a -> Put) -> Table t r a -> STM Put
putTable_ p = putTable__ $ return . p
putTable :: Binary a => Table t r a -> STM Put
putTable = putTable_ put