hmemdb 0.3.1.2 → 0.4.0.0

raw patch · 2 files changed

+230/−43 lines, 2 files

Files

• hmemdb.cabal +2/−2
• src/Data/HMemDb.hs +228/−41

@@ -2,9 +2,9 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hmemdb
-version:             0.3.1.2
+version:             0.4.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.
+description:         Library that provides a sort of relational database in memory (which could be saved to the disk, however).
 license:             BSD3
 license-file:        LICENSE
 author:              Miguel Mitrofanov

@@ -1,7 +1,110 @@+{-# OPTIONS_HADDOCK show-extensions #-}
 {-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types, TypeOperators #-}
 -- | Tables of values and keys for that tables.
 --
 -- Each value in the table may be accompanied with references to other tables.
+--
+-- = Usage
+--
+-- Each table is just an unordered collection of values.
+--
+-- == Simple values
+--
+-- Suppose we want to keep a collection of values of some type 'T'. We should use a very
+-- simple specification to create a table:
+--
+-- > createTable (Spec Refs Keys :: Spec Refs Keys T)
+--
+-- Here we have to specify the type 'T', as otherwise Haskell would have no way of knowing
+-- what type to use. Generally it's not really needed.
+--
+-- == Keys
+--
+-- Of course, just keeping a collection of values is not very useful. Let's say a company
+-- wants to keep a table of it's employees, looking for information about them by their
+-- id numbers or names. Id number is unique, while the names could probably coincide.
+--
+-- > data Employee = Employee {empId :: Int, empName :: String}
+-- > cEmps <- createTable $ Spec Refs (Keys :+: K (single empId) :+: K (multiple empName))
+-- > case cEmps of
+-- >   Created employees (Keys :+: K idKey :+: K nameKey) -> ...
+--
+-- Here 'employees' would be the table of employees itself, 'idKey' would be the key that
+-- can be used to look up an employee by the id, and 'nameKey' would be the key that can be
+-- used to look up an employee by the name.
+--
+-- 'select' function can do the looking up by id part.
+--
+-- > ceoVar <- select idKey 0
+-- > ceo <- readVar employees ceoVar
+--
+-- For multiple values the function 'select_' should be used instead.
+--
+-- > workersNamedDaniel <- select_ nameKey "Daniel" (==)
+-- > mapM (\workerVar -> runMaybeT $ readVar employees workerVar) workersNamedDaniel
+--
+-- We can also use other comparison operators, like
+--
+-- > workersFromZ <- select_ nameKey "Z" (<=)
+--
+-- for selecting all workers whose names satisfy the inequality @\"Z\" <= name@.
+--
+-- == References
+--
+-- Tables can reference other tables, created before. For example, assume that we have a set
+-- of departments and a set of employees, and each of employees can be in one of the
+-- departments. We shouldn't keep that information inside the 'Employee' data type (as it
+-- is quite changeable); instead we keep a reference into the 'departments' table along
+-- with the 'Employee' value in the 'employees' table
+--
+-- > cDepts <- createTable $ ...
+-- > case cDepts of
+-- >   Created departments ... ->
+-- >     do cEmps <- case createTable $ Spec (Refs :&: R (only departments)) (Keys ...)
+-- >        case cEmps of
+-- >          Created employees (Keys ...) -> ...
+--
+-- Given the 'TableVar' we can find out the references associated with it:
+--
+-- > Refs :&: R deptVar <- readRefs employees ceoVar
+-- > dept <- readVar departments deptVar
+--
+-- References can also be used as keys, if they are unique:
+--
+-- > createTable $ Spec (...) (Keys :+: K (single_ (\_ (Refs :&: deptVar) -> deptVar)))
+--
+-- == Circular references
+--
+-- It's possible to have tables referencing each other, but that requires some finesse.
+-- Suppose that each department has a manager. Again, we don't keep that information
+-- in the 'Department' data type itself, but we want to keep a reference along the
+-- value in the table.
+--
+-- First of all, we need to create a data type that keeps both tables inside.
+--
+-- > data Company where
+-- >   Company
+-- >     :: Table (Refs :&: Ref d Department Single) e Employee ->
+-- >        Table (Refs :&: Ref e Employee Single) d Department ->
+-- >        Company
+--
+-- Then we make specifications from table tokens (tables aren't created yet):
+--
+-- > makeSpecs (Tokens :*: tE :*: tD) =
+-- >   Specs :&&: Spec (Refs :&: R (only tD)) Keys :&&: Spec (Refs :&: R (only tE)) Keys
+--
+-- and make the final result (the 'Company' type) from the tables:
+--
+-- > generate (Tables :*: T employees Keys :*: T departments Keys) =
+-- >   return $ Company employees departments
+--
+-- All that should be launched by the 'createTables' function:
+--
+-- > company <- createTables $ C $ C $ Exists makeSpecs generate
+-- > case company of
+-- >   Company employees departments -> ...
+--
+-- Here we should use two 'C' constructors to indicate that we are creating two tables.
 module Data.HMemDb
     (
      MS,
@@ -13,17 +116,22 @@ -- * Specifications
      Spec (Spec, sRefs, sKeys),
 -- ** Foreign table references
-     TableRef, only, some,
-     RefsC, Refs (Refs), RefsComponent, Ref, (:&:)((:&:)), splitRef,
+     TableRef, ToRef (only, some),
+     RefsC, Refs (Refs), RefsComponent, Ref (R), (:&:)((:&:)), splitRef,
 -- ** Keys
      KeySpec, single, multiple, single_, multiple_,
-     KeysC, Keys (Keys), KeysComponent, KeyRef, (:+:)((:+:)), splitKey,
+     KeysC, Keys (Keys), KeysComponent, KeyRef (K), (:+:)((:+:)), splitKey,
 -- * Table manipulation
      Created (Created),
-     createTable, select, select_, selectBetween, insert, update, update_, delete,
+     createTable, select, select_, selectBetween, nullVar, insert, update, update_, delete,
 -- * Persistence
      getTable, getTable_, getTable__,
-     putTable, putTable_, putTable__
+     putTable, putTable_, putTable__,
+-- * Recursive tables
+     Token (Token), Tokens (Tokens), (:*:)((:*:)), TokensC, IsToken,
+     Specs (Specs, (:&&:)),
+     Tables (Tables), TablesC, TableData(T), IsTableData,
+     CreateTables, Exists (Exists), (:**:)(C), createTables
     ) where
 import Control.Concurrent.STM (STM, TVar, modifyTVar', newTVar, readTVar, writeTVar)
 import Control.Monad (forM, forM_, guard, liftM, liftM2, replicateM)
@@ -118,13 +226,13 @@ -- | One key specification.
 -- Note that it can't be used in the 'sKeys' field by itself,
 -- but rather should be combined with 'Keys' with the ':+:' operator.
-data KeyRef i u
+newtype KeyRef i u f = K (f i u)
 -- | Combining operator for key specifications.
-data (ks :+: k) f where (:+:) :: ks f -> f i u -> (ks :+: KeyRef i u) f
+data (ks :+: k) (f :: * -> * -> *) = ks f :+: k f
 infixl 5 :+:
 -- | Splitting keys.
 splitKey :: (ks :+: KeyRef i u) f -> (ks f, f i u)
-splitKey (ksf :+: fiu) = (ksf, fiu)
+splitKey (ksf :+: K fiu) = (ksf, fiu)
 -- | Class of the part of key specification, corresponding to one key.
 class KeysComponent k where
     forKeysComponent
@@ -134,8 +242,8 @@         -> 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)
+    forKeysComponent (ksf :+: K fiu) action =
+        liftM2 (:+:) (forKeys ksf action) (liftM K $ action fiu)
 -- | Class of table reference specifications, used in the 'sRefs' field of the 'Spec'.
 class RefsC r where
     putRefs
@@ -156,13 +264,13 @@ -- | One table reference specification.
 -- Note that it can't be used in the 'sRefs' field by itself,
 -- but rather should be combined with 'Refs' with the ':&:' operator.
-data Ref t a u
+newtype Ref t a u f = R (f t a u)
 -- | Combining operator for reference specifications.
-data (rs :&: r) f where (:&:) :: rs f -> f t a u -> (rs :&: Ref t a u) f
-infix 5 :&:
+data (rs :&: r) (f :: * -> * -> * -> *) = rs f :&: r f
+infixl 5 :&:
 -- | Splitting references.
 splitRef :: (rs :&: Ref t a u) f -> (rs f, f t a u)
-splitRef (rsf :&: ftau) = (rsf, ftau)
+splitRef (rsf :&: R ftau) = (rsf, ftau)
 -- | Class of the part of reference specification, corresponding to one reference.
 class RefsComponent r where
     putRefsComponent
@@ -178,15 +286,17 @@     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
+    putRefsComponent (rsf :&: R ftau) action = putRefs rsf action >> action ftau
+    getRefsComponent action = liftM2 (:&:) (getRefs action) (liftM R action)
 -- | Abstract type, which represents a collection of values of type 'a',
 -- possibly accompanied with some references to other 'Table's.
 -- The type 't' is an abstract type, used to ensure that we don't confuse
 -- different tables with values of the same type.
 -- 'r' is a type of references accompanying each value.
-data Table t r a where
-    Table :: (KeysC k, RefsC r) => PreTable t r k a -> TVar Integer -> Table t r a
+data Table r t a where
+    Table :: (KeysC k, RefsC r) => PreTable t r k a -> TVar Integer -> Table r t a
+-- | Type that can be used as a substitute for 'Table' in 'only' and 'some' functions.
+data Token t a = Token
 -- | Abstract type, which allows us to 'select' one or many values from the 'Table'.
 -- Type 't' is an abstract type, same as in the 'Table'.
 -- Type 'a' is a type of values, also same as in the 'Table'.
@@ -226,12 +336,19 @@ -- depending on whether the reference, accompanying the value,
 -- should be single-value or multiple-value
 data TableRef t a u = TableRef
--- | Each value in the table-to-be should be accompanied with a single-value reference.
-only :: Table t r a -> TableRef t a Single
-only = const TableRef
--- | Each value in the table-to-be should be accompanied with a multiple-value reference.
-some :: Table t r a -> TableRef t a Multiple
-some = const TableRef
+class ToRefBase (tbl :: * -> * -> *)
+instance ToRefBase (Table r)
+instance ToRefBase Token
+-- | Class of things you can reference. Normally that would be only tables, but you can use tokens as substitutes.
+class ToRefBase tbl => ToRef tbl where
+    -- | Each value in the table-to-be should be accompanied with a single-value reference.
+    only :: tbl t a -> TableRef t a Single
+    only = const TableRef
+    -- | Each value in the table-to-be should be accompanied with a multiple-value reference.
+    some :: tbl t a -> TableRef t a Multiple
+    some = const TableRef
+instance ToRef (Table r)
+instance ToRef Token
 -- | Type of table specifications.
 data Spec r k a =
     Spec
@@ -242,7 +359,7 @@       sKeys :: k (KeySpec r a) -- ^ Keys for the table-to-be
     }
 -- | Output of the 'createTable' function. Contains the created table and the keys to it.
-data Created r k a where Created :: Table t r a -> k (Key t a) -> Created r k a
+data Created r k a where Created :: Table r t a -> k (Key t a) -> Created r k a
 data KeyProcess r a i u =
     KeyProcess
     {
@@ -260,18 +377,85 @@     -> (forall i u. (Multitude u, Ord i) => f i u -> m ())
     -> m ()
 forKeys_ ks action = forKeys ks (\k -> action k >> return k) >> return ()
+-- | Empty tokens set.
+data Tokens = Tokens
+-- | Combining operator for tokens or tables sets.
+data  tps :*: tp = tps :*: tp
+infixl 5 :*:
+-- | Class of 'Token's
+class IsToken t where token :: t
+instance IsToken (Token t a) where token = Token
+-- | Class of token sets, used primarily in the argument of 'createTables' function.
+class TokensC toks where tokens :: toks
+instance TokensC Tokens where tokens = Tokens
+instance (IsToken t, TokensC toks) => TokensC (toks :*: t) where tokens = tokens :*: token
+-- | Empty tables set.
+data Tables = Tables
+-- | Table, paired with keys to it
+data TableData r k t a = T (Table r t a) (k (Key t a))
+-- | Set of specs, of the same size as given sets of tokens and tables.
+data Specs toks tbls where
+    Specs :: Specs Tokens Tables
+    (:&&:)
+        :: (KeysC k, RefsC r, TokensC toks) =>
+           Specs toks tbls ->
+           Spec r k a ->
+           Specs (toks :*: Token t a) (tbls :*: TableData r k t a)
+infixl 5 :&&:
+-- | Class of tables sets, used primarily in the argument of 'createTables' function.
+class TablesC tbls where
+    makeTables :: TokensC toks => (toks -> Specs toks tbls) -> (tbls -> STM z) -> STM z
+-- | Class of all 'TableData's
+class IsTableData tbl where
+    makeTables_
+        :: (TablesC tbls, TokensC toks) =>
+           (toks -> Specs toks (tbls :*: tbl)) -> (tbls :*: tbl -> STM z) -> STM z
+instance IsTableData (TableData r k t a) where
+    makeTables_ makeSpecs gen =
+        case makeSpecs tokens of
+          _ :&&: spec ->
+              do counter <- newTVar 0
+                 tm <- newTVar M.empty
+                 tk <-
+                     forKeys (sKeys spec) $ \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
+                     makeSpecs' toks =
+                         case makeSpecs $ toks :*: Token of specs :&&: _ -> specs
+                     gen' tables = gen $ tables :*: T cTable cKeys
+                 makeTables makeSpecs' gen'
+instance TablesC Tables where makeTables _ gen = gen Tables
+instance (IsTableData tbl, TablesC tbls) => TablesC (tbls :*: tbl) where
+    makeTables = makeTables_
+-- | Data type that hides references and keys specifications inside.
+data Exists toks z where
+    Exists
+        :: TablesC tbls =>
+           (toks -> Specs toks tbls) -> (tbls -> STM z) -> Exists toks z
+-- | Data type that quantifies universally over the table types.
+-- It should be applied as many times as there are tables being created.
+newtype (crts :**: a) toks z = C (forall t. crts (toks :*: Token t a) z)
+infixl 5 :**:
+-- | Class of the data used to generate 'Spec's
+-- for tables that need to reference each other.
+class CreateTables crts where createTables_ :: TokensC toks => crts toks z -> STM z
+instance CreateTables Exists where
+    createTables_ (Exists makeSpecs gen) = makeTables makeSpecs gen
+instance CreateTables crts => CreateTables (crts :**: a) where
+    createTables_ (C crts) = createTables_ crts
+-- | Function that actually creates multiple tables, possibly referencing each other,
+-- at once.
+createTables :: CreateTables crts => crts Tokens z -> STM z
+createTables = createTables_
 -- | Function that creates the table (along with keys and everything) based on a 'Spec'.
 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
+createTable spec =
+    createTables $ C $
+    let makeSpecs (Tokens :*: Token) = Specs :&&: spec
+        gen (Tables :*: T table keys) = return $ Created table keys
+    in Exists makeSpecs gen
 -- | Function that selects one value from a 'Key'.
 -- Note that the value is not returned directly.
 -- Instead, a reference to it is returned, which allows to get other references,
@@ -329,10 +513,13 @@            mvs = return $ M.elems m >>= mToList
            gvs = if bg then fmap mToList g else Nothing
        return $ map (TableVar . Single) $ [lvs, mvs, gvs] >>= listUnMaybe
+-- | An invalid reference to any table. Dereferencing it always fails.
+nullVar :: TableVar t a
+nullVar = TableVar $ Single (-1)
 -- | Function that lets one to insert a new value to the 'Table'.
 -- Of course, we have to provide accompanying references as well.
 -- This function can fail if some key clashes with an already existing one.
-insert :: Table t r a -> a -> r TableVarU -> MS (TableVar t a)
+insert :: Table r t a -> a -> r TableVarU -> MS (TableVar t a)
 insert (Table pt counter) a r =
     do c <- lift $ readTVar counter
        kps <-
@@ -348,20 +535,20 @@          return $ TableVar $ Single c
 -- | Function that dereferences a value from table.
 -- Note that we have to provide the 'Table' along with 'TableVar'.
-readVar :: Table t r a -> TableVar t a -> MS a
+readVar :: Table r t 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
 -- | Function that reads all references accompanying the value.
-readRefs :: Table t r a -> TableVar t a -> MS (r TableVarU)
+readRefs :: Table r t 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
 -- | More generic version of 'update'.
 -- It allows changing accompanying references as well as the value.
-update_ :: Table t r a -> TableVar t a -> a -> r TableVarU -> MS ()
+update_ :: Table r t 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
@@ -381,11 +568,11 @@ -- It doesn't change the accompanying references.
 -- In case that it fails due to some single-value key prohibiting the new value,
 -- nothing is changed, and the 'Table' remains the same.
-update :: Table t r a -> TableVar t a -> a -> MS ()
+update :: Table r t a -> TableVar t a -> a -> MS ()
 update t v a = readRefs t v >>= update_ t v a
 -- | Function that removes the value (along with accompanying references)
 -- from the 'Table'. It only fails if the value was already removed.
-delete :: Table t r a -> TableVar t a -> MS ()
+delete :: Table r t a -> TableVar t a -> MS ()
 delete (Table pt _) v =
     do let n = sVal $ tvVal v
        tm <- lift $ readTVar $ tMap pt