packages feed

hmemdb (empty) → 0.1.0.0

raw patch · 17 files changed

+734/−0 lines, 17 filesdep +TypeComposedep +basedep +binarysetup-changed

Dependencies added: TypeCompose, base, binary, containers, mtl, stm, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Miguel Mitrofanov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Miguel Mitrofanov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ hmemdb.cabal view
@@ -0,0 +1,33 @@+-- Initial hmemdb.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                hmemdb
+version:             0.1.0.0
+synopsis:            In-memory relational database
+description:         Library that provides a sort of relational database in memory (which could be saved to the disk, however). Very untested.
+license:             BSD3
+license-file:        LICENSE
+author:              Miguel Mitrofanov
+maintainer:          miguelimo38@yandex.ru
+-- copyright:           
+category:            Data
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Data.HMemDb
+  other-modules:       Data.HMemDb.Utils,
+                       Data.HMemDb.TableVars,
+                       Data.HMemDb.Tables,
+                       Data.HMemDb.Specs, 
+                       Data.HMemDb.References, 
+                       Data.HMemDb.RefConverter, 
+                       Data.HMemDb.RefContainer, 
+                       Data.HMemDb.Persistence,
+                       Data.HMemDb.KeyBackends,
+                       Data.HMemDb.ForeignKeys,
+                       Data.HMemDb.CreateTable, 
+                       Data.HMemDb.Binary,
+                       Data.HMemDb.Bin
+  build-depends:       base ==4.6.*, TypeCompose ==0.9.*, mtl ==2.1.*, transformers ==0.3.*, stm ==2.4.*, containers ==0.5.*, binary ==0.5.*
+  hs-source-dirs:      src
+ src/Data/HMemDb.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
+-- | This library allows one to create mutable (but thread-safe)
+-- lists of values and access them quickly
+-- with certain automatically updated indices (foreign keys).
+module Data.HMemDb
+    (
+     MS,
+     GS,
+     SP,
+-- * Tables
+     Table,
+     TableVar,
+     TableVarS,
+     forTV,
+     deleteTV,
+     modifyTV,
+     readTV,
+     ForeignKey,
+     keyTarget,
+-- * Specs
+     FullSpec(FullSpec, keySpec, tabSpec),
+-- ** Table specs
+     TableSpec(TableSpec),
+     ColSpec,
+     val,
+     key,
+-- ** Key specs
+     KeySpec,
+     unique,
+     nonunique,
+-- * Creating tables
+     createTable,
+     Keys(Keys),
+     RefContainer,
+     IsKeySpec,
+     (:+:)((:+:)),
+     CreateTable,
+-- * Basic operations
+     insert,
+     select,
+     delete,
+     update,
+-- * Serialization
+     getTable,
+     putTable,
+    )
+where
+import Data.HMemDb.Binary (GS, MS, SP)
+import Data.HMemDb.CreateTable (CreateTable, IsKeySpec, createTable)
+import Data.HMemDb.ForeignKeys (ForeignKey, delete, keyTarget, select, update)
+import Data.HMemDb.Persistence (getTable, putTable)
+import Data.HMemDb.RefContainer (RefContainer)
+import Data.HMemDb.Specs
+    (ColSpec, FullSpec(FullSpec, keySpec, tabSpec),
+     Keys(Keys), KeySpec, TableSpec(TableSpec),
+     key, nonunique, val, unique, (:+:)((:+:)))
+import Data.HMemDb.Tables (Table)
+import Data.HMemDb.TableVars
+    (TableVar, TableVarS, deleteTV, forTV, insert, modifyTV, readTV)
+ src/Data/HMemDb/Bin.hs view
@@ -0,0 +1,53 @@+{-# 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 (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)
+ src/Data/HMemDb/Binary.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeOperators #-}
+module Data.HMemDb.Binary (GS, MS, SP) where
+import Control.Compose ((:.))
+import Control.Concurrent.STM (STM)
+import Control.Monad.Trans.Maybe (MaybeT)
+import Data.Binary.Get (Get)
+import Data.Binary.Put (PutM)
+type MS = MaybeT STM
+type GS = Get :. STM
+type SP = (STM :. PutM) ()
+ src/Data/HMemDb/CreateTable.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE GADTs, TypeOperators #-}
+module Data.HMemDb.CreateTable (CreateTable(makeTable), IsKeySpec, createTable) where
+import Control.Applicative ((<$>))
+import Control.Arrow (first)
+import Control.Concurrent.STM (STM, newTVar)
+import qualified Data.Map as M (empty)
+import Data.HMemDb.Bin (Bin)
+import Data.HMemDb.ForeignKeys (ForeignKey(ForeignKey))
+import Data.HMemDb.KeyBackends (KeyBack(KeyBack), PreKeyBack(PreKeyBack))
+import Data.HMemDb.RefContainer (RefContainer)
+import Data.HMemDb.RefConverter (PreRefConv, RefConv(RefConv))
+import Data.HMemDb.Specs
+    (FullSpec(FullSpec, keySpec, tabSpec),
+     Keys(Keys), KeySpec(KeySpec), TableSpec(TableSpec),
+     makeRC, (:+:)((:+:)))
+import Data.HMemDb.Tables
+    (PreTable(PreTable, tabContent, tabConv, tabCount, tabIndices), Table(Table))
+-- | This is a class of sets of @KeySpec@'s and @ForeignKey@'s
+class CreateTable u where
+    makeTable ::
+        Bin r => PreRefConv r a a -> u a KeySpec -> STM (PreTable r a, u a ForeignKey)
+instance CreateTable Keys where
+    makeTable pr ~Keys =
+        do count <- newTVar 0
+           content <- newTVar M.empty
+           let pt =
+                   PreTable
+                   {tabCount = count, tabConv = pr, tabContent = content, tabIndices = []}
+           return (pt, Keys)
+-- | This class is here for technical reasons; it has just one instance.
+class IsKeySpec ks where
+    makeTableKS ::
+        (Bin r, CreateTable u) => PreRefConv r a a
+        -> (u :+: ks) a KeySpec
+        -> STM (PreTable r a, (u :+: ks) a ForeignKey)
+instance (Ord i, RefContainer s) => IsKeySpec (KeySpec s i) where
+    makeTableKS pr (uk :+: KeySpec h) =
+        do ~(pt, uf) <- makeTable pr uk
+           ii <- newTVar M.empty
+           tv <- newTVar M.empty
+           let pt' = pt {tabIndices = KeyBack (PreKeyBack h ii tv) : tabIndices pt}
+           return (pt', uf :+: ForeignKey pt' tv)
+instance (CreateTable u, IsKeySpec ks) => CreateTable (u :+: ks) where
+    makeTable = makeTableKS
+createTable :: CreateTable u => FullSpec a u -> STM (Table a, u a ForeignKey)
+-- ^ This function creates an empty table, given the table structure (@TableSpec@)
+-- and the set of keys (@KeySpec@).
+-- It returns the table itself, accompanied with the same set of foreign keys,
+-- allowing one to search through the table quickly, or to make a new @TableSpec@.
+createTable (FullSpec {tabSpec = TableSpec cs, keySpec = ks}) =
+    case makeRC cs of RefConv _ pr -> first Table <$> makeTable pr ks
+ src/Data/HMemDb/ForeignKeys.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE GADTs #-}
+module Data.HMemDb.ForeignKeys
+    (ForeignKey(ForeignKey), delete, getCRef, keyTarget, select, update) where
+import Control.Compose (Id, unId)
+import Control.Concurrent.STM (STM, TVar, readTVar)
+import Control.Monad (void)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Maybe (runMaybeT)
+import Data.Foldable (Foldable)
+import qualified Data.Map as M (Map, lookup)
+import Data.HMemDb.Bin (Bin)
+import Data.HMemDb.Binary (MS)
+import Data.HMemDb.RefConverter (rcTo)
+import Data.HMemDb.References (CRef(CRef), Ref)
+import Data.HMemDb.Tables (PreTable, Table(Table), tabConv)
+import Data.HMemDb.TableVars (TableVarS(TableVar), deleteTV, forTV, modifyTV)
+import Data.HMemDb.Utils (liftMaybe)
+-- | This is a type of foreign keys. Each foreign key points to one table.
+-- It is used to find the values in this table using @select@.
+-- Foreign keys are created at the same time @Table@'s are.
+-- They can't be added afterwards.
+data ForeignKey s i a where
+    ForeignKey ::
+        Bin r => PreTable r a
+        -> TVar (M.Map i (s (Ref r)))
+        -> ForeignKey s i a
+select :: Ord i => ForeignKey s i a -> i -> MS (TableVarS s a)
+-- ^ This function searches for some particular index in the table.
+-- It fails if there is no value with that index. Empty set of values is never returned.
+-- For non-unique indices it returns the set of @TableVar@'s.
+select (ForeignKey pt tv) i =
+    do mp <- lift $ readTVar tv
+       s <- liftMaybe $ M.lookup i mp
+       return $ TableVar s pt
+getCRef :: Ord i => ForeignKey Id i a -> i -> MS (CRef a)
+getCRef (ForeignKey pt tv) i =
+    do mp <- lift $ readTVar tv
+       iref <- liftMaybe $ M.lookup i mp
+       return $ CRef (unId iref) $ rcTo (tabConv pt)
+delete :: (Foldable s, Ord i) => ForeignKey s i a -> i -> STM ()
+-- ^ This function deletes the value from the table. It won't be accessible anymore.
+-- It never fails; nonexistent values are silently skipped.
+delete f i = void $ runMaybeT $ select f i >>= forTV (lift . runMaybeT . deleteTV)
+update :: Ord i => ForeignKey Id i a -> i -> a -> MS a
+-- ^ This function overrides the existing value in the table with the new one.
+-- All foreign keys pointing to the original value become pointing to the new value.
+-- It returns the original value, which is no longer in the table.
+-- Failure means that there was no such value.
+update f i new = select f i >>= modifyTV new
+keyTarget :: ForeignKey s i a -> Table a
+-- ^ This function returns the table that the key points to.
+keyTarget (ForeignKey pt _) = Table pt
+ src/Data/HMemDb/KeyBackends.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE GADTs #-}
+module Data.HMemDb.KeyBackends
+    (
+     PreKeyBack(PreKeyBack),
+     KeyBack(KeyBack),
+     deleteFromKeys,
+     insertIntoKeys,
+     modifyInKeys
+    ) where
+import Control.Concurrent.STM (STM, TVar, modifyTVar', readTVar, writeTVar)
+import Control.Monad (guard, void)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Cont (ContT(runContT))
+import Control.Monad.Trans.Maybe (runMaybeT)
+import Data.Foldable (for_)
+import Data.Map (Map)
+import qualified Data.Map as M (delete, insert, lookup, update)
+import Data.HMemDb.Binary (MS)
+import Data.HMemDb.RefContainer (RefContainer(insRef, delRef))
+import Data.HMemDb.References (Ref(refIndex))
+import Data.HMemDb.Utils (brackets, liftMaybe)
+data PreKeyBack s r a where
+    PreKeyBack ::
+        Ord i => (a -> i)
+        -> TVar (Map Integer i)
+        -> TVar (Map i (s (Ref r)))
+        -> PreKeyBack s r a
+data KeyBack r a where KeyBack :: RefContainer s => PreKeyBack s r a -> KeyBack r a
+insertIntoKey :: RefContainer s => a -> Ref r -> PreKeyBack s r a -> ContT () MS ()
+insertIntoKey new ref (PreKeyBack g ii tv) =
+    brackets before after where
+        before =
+            do let i = g new
+               mp <- lift $ readTVar tv
+               s <- liftMaybe $ insRef ref $ M.lookup i mp
+               return (M.insert (refIndex ref) i, M.insert i s mp)
+        after ~(makeNewImp, newMp) =
+            lift $ do
+              modifyTVar' ii makeNewImp
+              writeTVar tv $! newMp
+insertIntoKeys :: a -> Ref r -> [KeyBack r a] -> MS ()
+insertIntoKeys a ref ks =
+    runContT (for_ ks $ \(KeyBack pk) -> insertIntoKey a ref pk) return
+deleteFromKey :: RefContainer s => Ref r -> PreKeyBack s r a -> STM ()
+deleteFromKey ref (PreKeyBack _ ii tv) =
+    void $ runMaybeT $
+    do imp <- lift $ readTVar ii
+       i <- liftMaybe $ M.lookup (refIndex ref) imp
+       mp <- lift $ readTVar tv
+       s <- liftMaybe $ M.lookup i mp
+       lift $ do
+         writeTVar ii $! M.delete (refIndex ref) imp
+         writeTVar tv $! M.update (const $ delRef ref s) i mp
+deleteFromKeys :: Ref r -> [KeyBack r a] -> STM ()
+deleteFromKeys ref ks = for_ ks $ \(KeyBack pk) -> deleteFromKey ref pk
+modifyInKey :: RefContainer s => a -> Ref r -> PreKeyBack s r a -> ContT () STM ()
+modifyInKey new ref (PreKeyBack g ii tv) =
+    brackets before after where
+        before =
+            runMaybeT $ do
+              let i = refIndex ref
+              imp <- lift $ readTVar ii
+              oldI <- liftMaybe $ M.lookup i imp
+              mp <- lift $ readTVar tv
+              let newI = g new
+              guard $ newI /= oldI
+              oldS <- liftMaybe $ M.lookup oldI mp
+              let tempMp = M.update (const $ delRef ref oldS) oldI mp
+              newS <- liftMaybe $ insRef ref $ M.lookup newI tempMp
+              return (M.insert i newI imp, M.insert newI newS tempMp)
+        after Nothing = return ()
+        after (Just ~(newImp, newMp)) =
+            do writeTVar ii $! newImp
+               writeTVar tv $! newMp
+modifyInKeys :: a -> Ref r -> [KeyBack r a] -> STM ()
+modifyInKeys a ref ks =
+    runContT (for_ ks $ \(KeyBack pk) -> modifyInKey a ref pk) return
+ src/Data/HMemDb/Persistence.hs view
@@ -0,0 +1,61 @@+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)
+-- serialization
+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
+-- ^ This function saves the table to the ByteString.
+-- Note that it doesn't really matter if the type of values in the table
+-- are serializable.
+--
+-- NB: if any index used to access the values in this table depended on any foreign keys,
+-- and targets of these keys have changed,
+-- the index could be different after storing and restoring the table.
+putTable (Table pt) = runCont (putPreTable pt) pure
+-- deserialization
+getTable :: CreateTable u => FullSpec a u -> GS (Table a, u a ForeignKey)
+-- ^ This function reads the table from the ByteString.
+-- As the table structure is NOT stored,
+-- one should provide the same one that was used to create this table
+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
+ src/Data/HMemDb/RefContainer.hs view
@@ -0,0 +1,20 @@+module Data.HMemDb.RefContainer (RefContainer(insRef, delRef)) where
+import Control.Compose (Id(Id))
+import Data.Foldable (Foldable)
+import Data.Set (Set, delete, empty, insert, singleton)
+import Data.HMemDb.References
+-- | This class is a closed one; the user is not supposed to create new instances.
+-- It allows treating unique and non-unique keys in the same way.
+class Foldable s => RefContainer s where
+    insRef :: Ref r -> Maybe (s (Ref r)) -> Maybe (s (Ref r))
+    delRef :: Ref r -> s (Ref r) -> Maybe (s (Ref r))
+instance RefContainer Id where
+    insRef ref Nothing = Just $ Id ref
+    insRef _ (Just _) = Nothing
+    delRef _ _ = Nothing
+instance RefContainer Set where
+    insRef ref Nothing = Just $ singleton ref
+    insRef ref (Just s) = Just $ insert ref s
+    delRef ref s =
+        let s' = delete ref s
+        in if s' == empty then Nothing else Just s'
+ src/Data/HMemDb/RefConverter.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE GADTs #-}
+module Data.HMemDb.RefConverter
+    (PreRefConv(PreRefConv, rcFrom, rcTo), RefConv(RefConv)) where
+import Control.Applicative (Applicative(pure, (<*>)))
+import Control.Monad (liftM2)
+import Data.HMemDb.Bin (Bin, TableRefs(TRNil, TRPair))
+import Data.HMemDb.Binary (MS)
+data PreRefConv r input output =
+    PreRefConv {rcFrom :: input -> MS r, rcTo :: r -> MS output}
+data RefConv input output where
+    RefConv :: Bin r => TableRefs r -> PreRefConv r input output -> RefConv input output
+(|*|) ::
+    PreRefConv r1 input (middle -> output)
+    -> PreRefConv r2 input middle
+    -> PreRefConv (r1, r2) input output
+p1 |*| p2 = PreRefConv from to where
+   from input = liftM2 (,) (rcFrom p1 input) (rcFrom p2 input)
+   to (r1, r2) = liftM2 ($) (rcTo p1 r1) (rcTo p2 r2)
+instance Functor (RefConv input) where fmap h r = pure h <*> r
+instance Applicative (RefConv input) where
+    pure output =
+        RefConv TRNil $
+        PreRefConv {rcFrom = const $ return (), rcTo = \ ~() -> return output}
+    RefConv trf pf <*> RefConv trx px = RefConv (TRPair trf trx) (pf |*| px)
+ src/Data/HMemDb/References.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE GADTs#-}
+module Data.HMemDb.References
+    (CRef(CRef), Ref(Ref, refContent, refIndex), deCRef, deRef) where
+import Control.Concurrent.STM (TVar, readTVar)
+import Control.Monad.Trans (lift)
+import Data.Function (on)
+import Data.HMemDb.Binary (MS)
+import Data.HMemDb.Utils (liftMaybe)
+data Ref r = Ref {refContent :: TVar (Maybe r), refIndex :: Integer}
+instance Eq (Ref r) where (==) = (==) `on` refIndex
+instance Ord (Ref r) where compare = compare `on` refIndex
+deRef :: Ref r -> MS r
+deRef ref = lift (readTVar $ refContent ref) >>= liftMaybe
+data CRef a where CRef :: Ref r -> (r -> MS a) -> CRef a
+deCRef :: CRef a -> MS a
+deCRef (CRef ref to) = deRef ref >>= to
+ src/Data/HMemDb/Specs.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE KindSignatures, GADTs, TypeOperators #-}
+module Data.HMemDb.Specs
+    (
+     ColSpec,
+     FullSpec(FullSpec, keySpec, tabSpec),
+     Keys(Keys),
+     KeySpec(KeySpec),
+     TableSpec(TableSpec),
+     key,
+     makeRC,
+     nonunique,
+     val,
+     unique,
+     (:+:)((:+:))) where
+import Control.Applicative (Applicative(pure, (<*>)), (<$>))
+import Control.Compose (Id)
+import Data.Binary (Binary)
+import Data.Set (Set)
+import Data.HMemDb.Bin
+    (Proxy(Proxy, unProxy), TableGetData(TableGetData), TableRefs(TRProxy, TRVar))
+import Data.HMemDb.ForeignKeys (ForeignKey, getCRef, keyTarget)
+import Data.HMemDb.RefConverter (PreRefConv(PreRefConv, rcFrom, rcTo), RefConv(RefConv))
+import Data.HMemDb.References (deCRef)
+import Data.HMemDb.Tables (Table(Table), tabContent, tabConv)
+-- | This is the internal of the @TableSpec@ type.
+data ColSpec input output where
+    CSEnd :: output -> ColSpec input output
+    CSVal ::
+        Binary col => (input -> col)
+        -> ColSpec input (col -> output)
+        -> ColSpec input output
+    CSKey ::
+        Ord i => (input -> i)
+        -> ForeignKey Id i col
+        -> ColSpec input (col -> output)
+        -> ColSpec input output
+instance Functor (ColSpec input) where
+    fmap h (CSEnd output) = CSEnd $ h output
+    fmap h (CSVal g c) = CSVal g $ (h .) <$> c
+    fmap h (CSKey g f c) = CSKey g f $ (h .) <$> c
+instance Applicative (ColSpec input) where
+    pure = CSEnd
+    CSEnd h <*> c = h <$> c
+    CSVal g c <*> c' = CSVal g $ flip <$> c <*> c'
+    CSKey g f c <*> c' = CSKey g f $ flip <$> c <*> c'
+val :: Binary col => (input -> col) -> ColSpec input col
+-- ^ This function specifies one column in the table.
+-- It instructs the library to store one part of the value.
+val h = CSVal h $ pure id
+key :: Ord i => ForeignKey Id i col -> (input -> i) -> ColSpec input col
+-- ^ This function specifies one column in the table. Unlike @val@, it doesn't
+-- store some part of the value; instead it stores the reference to some other table.
+key k h = CSKey h k $ pure id
+newtype TableSpec a = TableSpec (ColSpec a a)
+-- ^ This type represents the table structure. It can be generated using the
+-- @Applicative@ interface of the @ColSpec@ like this:
+--
+-- > data MyData = {myField1 :: Integer, myField2 :: String}
+-- > tabSpec = TableSpec (MyData <$> val myField1 <*> val myField2)
+--
+makeRC :: ColSpec input output -> RefConv input output
+makeRC (CSEnd output) = pure output
+makeRC (CSVal g c) =
+    makeRC c <*>
+    RefConv TRProxy (PreRefConv {rcFrom = return . Proxy . g, rcTo = return . unProxy})
+makeRC (CSKey g f c) =
+    case keyTarget f of
+      Table pt ->
+          let tgd = TableGetData (rcTo $ tabConv pt) (tabContent pt)
+          in makeRC c <*>
+             RefConv (TRVar $ tgd) (PreRefConv {rcFrom = getCRef f . g, rcTo = deCRef})
+data KeySpec (s :: * -> *) i a = KeySpec (a -> i)
+-- ^ This is the specification of one @ForeignKey@. It could be unique or non-unique.
+unique :: (a -> i) -> KeySpec Id i a
+-- ^ This function specifies a unique key.
+unique = KeySpec
+nonunique :: (a -> i) -> KeySpec Set i a
+-- ^ This function specifies a non-unique key.
+nonunique = KeySpec
+data Keys a (h :: (* -> *) -> * -> * -> *) = Keys
+-- ^ This type represents an empty set of @KeySpec@'s or @ForeignKey@'s.
+data (u :+: ks) a h where (:+:) :: u a h -> h s i a -> (u :+: KeySpec s i) a h
+-- ^ This type operator adds one more @KeySpec@ to the set,
+-- or to get a @ForeignKey@ back with pattern-matching. Use it like this:
+--
+-- > do (table, ... :+: foreignKey)
+-- >      <- createTable $ FullSpec {..., keySpec = ... :+: unique myKey}
+--
+infixl 4 :+:
+data FullSpec a u = FullSpec {tabSpec :: TableSpec a, keySpec :: u a KeySpec}
+-- ^ This is the full specification, of both table and set of keys,
+-- which should be fed to @createTable@ and @getTable@ functions.
+ src/Data/HMemDb/TableVars.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs #-}
+module Data.HMemDb.TableVars 
+    (TableVar, TableVarS(TableVar), deleteTV, forTV, insert, modifyTV, readTV) where
+import Control.Applicative (Applicative)
+import Control.Compose (Id(Id), unId)
+import Control.Monad (mplus, mzero)
+import Data.Foldable (Foldable, for_)
+import Data.HMemDb.Binary (MS)
+import Data.HMemDb.RefConverter (rcTo)
+import Data.HMemDb.References (Ref, deRef)
+import Data.HMemDb.Tables
+    (PreTable(tabConv), Table(Table), deleteFromTable, insertIntoTable, modifyInTable)
+-- | This is a more generic type, which represents a set of values in the same table.
+data TableVarS s a where
+    TableVar :: s (Ref r) -> PreTable r a -> TableVarS s a
+type TableVar = TableVarS Id
+-- ^ This type represents references to individual values in the table.
+-- It is returned by @insert@ and @select@ functions.
+readTV :: TableVar a -> MS a
+-- ^ This function reads the value from the table.
+-- It fails if the value was removed before or became invalid.
+readTV (TableVar iref pt) =
+    do let ref = unId iref
+       r <- deRef ref
+       rcTo (tabConv pt) r `mplus` (deleteFromTable ref pt >> mzero)
+deleteTV :: TableVar a -> MS a
+-- ^ This function removes the value from whatever table it's in.
+-- It returnes the original value, provided that it wasn't removed before
+-- or invalidated by removing some other value this one references with @ForeignKey@.
+deleteTV (TableVar iref pt) = deleteFromTable (unId iref) pt
+modifyTV :: a -> TableVar a -> MS a
+-- ^ This function overrides the value with another one.
+-- All indices referencing the original value would be referencing the new one.
+-- It fails if the original value was removed before or became invalid.
+modifyTV new (TableVar iref pt) = modifyInTable new (unId iref) pt
+insert :: a -> Table a -> MS (TableVar a)
+-- ^ This function inserts a new value into the table and gives a @TableVar@ back.
+-- Failure indicates that one of the unique indices for this value
+-- coincides with the same index of another value already present in the table.
+-- It won't happen for non-unique indices.
+insert a (Table pt) =
+    do ref <- insertIntoTable a pt
+       return $ TableVar (Id ref) pt
+forTV :: (Foldable s, Applicative f) => (TableVar a -> f b) -> TableVarS s a -> f ()
+-- ^ This function iterates through all elements of the set.
+forTV h (TableVar s pt) = for_ s $ \ref -> h $ TableVar (Id ref) pt
+ src/Data/HMemDb/Tables.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GADTs #-}
+module Data.HMemDb.Tables
+    (
+     PreTable(PreTable, tabCount, tabContent, tabConv, tabIndices),
+     Table(Table),
+     deleteFromTable,
+     insertIntoTable,
+     insertRefIntoTable,
+     modifyInTable
+    ) where
+import Control.Concurrent.STM (TVar, modifyTVar', newTVar, readTVar, writeTVar)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Maybe (runMaybeT)
+import qualified Data.Map as M (Map, delete, insert)
+import Data.HMemDb.Bin (Bin)
+import Data.HMemDb.Binary (MS)
+import Data.HMemDb.KeyBackends (KeyBack, deleteFromKeys, insertIntoKeys, modifyInKeys)
+import Data.HMemDb.RefConverter (PreRefConv(rcFrom, rcTo))
+import Data.HMemDb.References (Ref(Ref, refContent, refIndex), deRef)
+import Data.HMemDb.Utils (liftMaybe)
+data PreTable r a =
+    PreTable
+    {
+      tabCount :: TVar Integer,
+      tabConv :: PreRefConv r a a,
+      tabContent :: TVar (M.Map Integer (TVar (Maybe r))),
+      tabIndices :: [KeyBack r a]
+    }
+data Table a where Table :: Bin r => PreTable r a -> Table a
+-- ^ This type represent tables. Each table is the set of values.
+-- Individual values can be accessed with @TableVar@'s or @ForeignKey@'s.
+-- Tables are never created manually,
+-- they should be generated by @createTable@ or loaded by @getTable@.
+-- Both functions require the structure of the table to be described as the @FullSpec@.
+insertTVarIntoTable :: a -> Integer -> TVar (Maybe r) -> PreTable r a -> MS (Ref r)
+insertTVarIntoTable a n tv pt =
+    do let ref = Ref {refContent = tv, refIndex = n}
+       insertIntoKeys a ref $ tabIndices pt
+       lift $ modifyTVar' (tabContent pt) $ M.insert n tv
+       return ref
+insertIntoTable :: a -> PreTable r a -> MS (Ref r)
+insertIntoTable a pt =
+    do n <- lift $ readTVar $ tabCount pt
+       content <- rcFrom (tabConv pt) a >>= lift . newTVar . Just
+       ref <- insertTVarIntoTable a n content pt
+       lift $ writeTVar (tabCount pt) $ n+1
+       return ref
+insertRefIntoTable :: PreTable r a -> (Integer, r) -> MS (Ref r)
+insertRefIntoTable pt ~(n, r) =
+    do tv <- lift $ newTVar $ Just r
+       a <- rcTo (tabConv pt) r
+       insertTVarIntoTable a n tv pt
+deleteFromTable :: Ref r -> PreTable r a -> MS a
+deleteFromTable ref pt =
+    do a <- lift $ runMaybeT $ deRef ref >>= rcTo (tabConv pt)
+       lift $ do
+         modifyTVar' (tabContent pt) $ M.delete $ refIndex ref
+         deleteFromKeys ref $ tabIndices pt
+         writeTVar (refContent ref) Nothing
+       liftMaybe a
+modifyInTable :: a -> Ref r -> PreTable r a -> MS a
+modifyInTable new ref pt = 
+    do old <- deRef ref >>= rcTo (tabConv pt)
+       r <- rcFrom (tabConv pt) new
+       lift $ modifyInKeys new ref $ tabIndices pt
+       lift $ writeTVar (refContent ref) $ Just r
+       return old
+ src/Data/HMemDb/Utils.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TypeOperators #-}
+module Data.HMemDb.Utils
+    (
+     bindO,
+     brackets,
+     enumElem,
+     fixArray,
+     liftMaybe,
+     liftPure,
+     oBind,
+     pureO,
+     replicateO
+    ) where
+import Control.Applicative (Applicative(pure), (<$>), (<*>))
+import Control.Compose (oFmap, oPure, unO, (:.)(O))
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Cont (Cont, ContT(ContT), cont)
+import Control.Monad.Trans.Maybe (MaybeT(MaybeT, runMaybeT))
+import Data.Foldable (Foldable, for_)
+import Data.Maybe (catMaybes)
+import Data.Traversable (sequenceA)
+liftMaybe :: Monad m => Maybe a -> MaybeT m a
+liftMaybe = MaybeT . return
+liftPure :: (Applicative f, Applicative g) => f a -> Cont ((g :. f) b) ()
+liftPure fa = cont $ \f -> const id <$> oPure fa <*> f ()
+enumElem :: (Applicative f, Foldable t) => t a -> Cont (f ()) a
+enumElem as = cont $ for_ as
+pureO :: (Applicative f, Functor g) => g a -> (g :. f) a
+pureO ga = O $ pure <$> ga
+oBind :: (Functor g, Monad f) => (g :. f) a -> (a -> f b) -> (g :. f) b
+oBind gfa afb = O $ (>>= afb) <$> unO gfa
+bindO :: Monad m => m a -> (a -> (m :. f) b) -> (m :. f) b
+bindO ma amfb = O $ ma >>= unO . amfb
+fixArray :: Monad m => [a] -> (a -> m (Maybe b)) -> Cont ((m :. f) c) [b]
+fixArray xs f = cont $ \h -> mapM f xs `bindO` (h . catMaybes)
+replicateO :: (Applicative f, Applicative g) => (g :. MaybeT f) a -> Int -> (g :. f) [a]
+replicateO gmfa len = catMaybes <$> sequenceA (replicate len $ oFmap runMaybeT gmfa)
+brackets :: Monad m => m a -> (a -> m r) -> ContT r m ()
+brackets before after =
+    do a <- lift before
+       ContT $ \f -> f () >> after a