hmemdb 0.2.0.3 → 0.2.0.4

raw patch · 11 files changed

+102/−83 lines, 11 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• hmemdb.cabal +1/−1
• src/Data/HMemDb.hs +2/−2
• src/Data/HMemDb/Bin.hs +28/−28
• src/Data/HMemDb/CreateTable.hs +13/−11
• src/Data/HMemDb/ForeignKeys.hs +7/−7
• src/Data/HMemDb/Persistence.hs +6/−6
• src/Data/HMemDb/RefConverter.hs +5/−4
• src/Data/HMemDb/Specs.hs +25/−9
• src/Data/HMemDb/TableVarId.hs +3/−3
• src/Data/HMemDb/TableVars.hs +10/−10
• src/Data/HMemDb/Tables.hs +2/−2

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hmemdb
-version:             0.2.0.3
+version:             0.2.0.4
 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

@@ -18,7 +18,7 @@ -- * Specs      FullSpec(FullSpec, keySpec, tabSpec), -- ** Table specs-     TableSpec, ColSpec, val, key, tref,+     TableSpec, ColSpec, val, mval, key, tref, -- ** Key specs      KeySpec, unique, nonunique, -- * Creating tables@@ -40,7 +40,7 @@ import Data.HMemDb.Specs     (ColSpec, FullSpec(FullSpec, keySpec, tabSpec),      Keys(Keys), KeySpec, TableSpec,-     key, nonunique, tref, val, unique, (:+:)((:+:)))+     key, mval, nonunique, tref, val, unique, (:+:)((:+:))) import Data.HMemDb.Tables (Table, foldTable_) import Data.HMemDb.TableVarId (TableVarId, idToVar, varToId) import Data.HMemDb.TableVars

@@ -1,14 +1,14 @@ {-# LANGUAGE GADTs, TypeOperators #-}
 module Data.HMemDb.Bin
     (
-     Bin(binGet, binPut),
-     IsId(isId),
+     Bin(Bin, binGet, binPut),
      Proxy(Proxy, unProxy),
      TableGetData(TableGetData),
-     TableRefs(TRNil, TRPair, TRProxy, TRVar)
+     TableRefs(TRNil, TRPair, TRProxy, TRVar),
+     binUnit, binProxy, binCRef, binPair
     ) where
 import Control.Applicative (liftA2, (<$>))
-import Control.Compose (Id, unId, (:.))
+import Control.Compose ((:.))
 import Control.Concurrent.STM (TVar)
 import Data.Binary (Binary(get, put), Get, Put)
 import Data.Map (Map)
@@ -23,29 +23,29 @@     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
+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
-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)
+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)
+    }

@@ -17,34 +17,36 @@ -- | This is a class of sets of 'Data.HMemDb.KeySpec's and 'Data.HMemDb.ForeignKey's
 class CreateTable u where
     makeTable ::
-        Bin r => TableRefs r
+        Bin r
+        -> TableRefs r
         -> PreRefConv r a a
         -> u a KeySpec 
         -> STM (PreTable r a, u a (PreForeignKey r))
     fixKeys ::
-        Bin r => PreTable r a -> u a (PreForeignKey r) -> u a ForeignKey
+        Bin r -> PreTable r a -> u a (PreForeignKey r) -> u a ForeignKey
 instance CreateTable Keys where
-    makeTable tr pr ~Keys =
+    makeTable _ tr pr ~Keys =
         do pt <- emptyPreTable tr pr
            return (pt, Keys)
-    fixKeys _ ~Keys = Keys
+    fixKeys _ _ ~Keys = Keys
 -- | This class is here for technical reasons; it has just one instance.
 class IsKeySpec ks where
     makeTableKS ::
-        (Bin r, CreateTable u) => TableRefs r
+        CreateTable u => Bin r
+        -> TableRefs r
         -> PreRefConv r a a
         -> (u :+: ks) a KeySpec
         -> STM (PreTable r a, (u :+: ks) a (PreForeignKey r))
 instance (Ord i, RefContainer s) => IsKeySpec (KeySpec s i) where
-    makeTableKS tr pr (uk :+: KeySpec h) =
-        do ~(pt, uf) <- makeTable tr pr uk
+    makeTableKS b tr pr (uk :+: KeySpec h) =
+        do ~(pt, uf) <- makeTable b tr pr uk
            ii <- newTVar M.empty
            tv <- newTVar M.empty
            let pt' = pt {tabIndices = KeyBack (PreKeyBack h ii tv) : tabIndices pt}
            return (pt', uf :+: PreForeignKey (readTVarMap tv))
 instance (CreateTable u, IsKeySpec ks) => CreateTable (u :+: ks) where
     makeTable = makeTableKS
-    fixKeys pt (uf :+: pfk) = fixKeys pt uf :+: makeForeignKey pt pfk
+    fixKeys b pt (uf :+: pfk) = fixKeys b pt uf :+: makeForeignKey b pt pfk
 createTable :: CreateTable u => FullSpec a u -> STM (Table a, u a ForeignKey)
 -- ^ This function creates an empty table,
 -- given the table structure ('Data.HMemDb.TableSpec')
@@ -54,6 +56,6 @@ -- or to make a new 'Data.HMemDb.TableSpec'.
 createTable fs =
     case makeRC $ tabSpec fs of
-      RefConv tr pr ->
-          do (pt, pfks) <- makeTable tr pr (keySpec fs)
-             return (Table pt, fixKeys pt pfks)
+      RefConv b tr pr ->
+          do (pt, pfks) <- makeTable b tr pr (keySpec fs)
+             return (Table b pt, fixKeys b pt pfks)

@@ -20,18 +20,18 @@ -- They can't be added afterwards.
 newtype PreForeignKey r s i a = PreForeignKey {runPreForeignKey :: i -> MS (s (Ref r))}
 data ForeignKey s i a where
-    ForeignKey :: Bin r => PreTable r a -> (i -> MS (s (Ref r))) -> ForeignKey s i a
-makeForeignKey :: Bin r => PreTable r a -> PreForeignKey r s i a -> ForeignKey s i a
-makeForeignKey pt pfk = ForeignKey pt $ runPreForeignKey pfk
+    ForeignKey :: Bin r -> PreTable r a -> (i -> MS (s (Ref r))) -> ForeignKey s i a
+makeForeignKey :: Bin r -> PreTable r a -> PreForeignKey r s i a -> ForeignKey s i a
+makeForeignKey b pt pfk = ForeignKey b pt $ runPreForeignKey pfk
 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 'Data.HMemDb.TableVar's.
-select (ForeignKey pt lkp) i =
+select (ForeignKey b pt lkp) i =
     do s <- lkp i
-       return $ TableVar s pt
+       return $ TableVar b s pt
 getCRef :: Ord i => ForeignKey Id i a -> i -> MS (CRef a)
-getCRef (ForeignKey pt lkp) i =
+getCRef (ForeignKey _ pt lkp) i =
     do iref <- lkp i
        return $ CRef (unId iref) $ rcTo (tabConv pt)
 delete :: (Foldable s, Ord i) => ForeignKey s i a -> i -> STM ()
@@ -46,4 +46,4 @@ 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
+keyTarget (ForeignKey b pt _) = Table b pt

@@ -17,15 +17,15 @@ 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 =
+putPreTable :: Bin r -> PreTable r a -> Cont SP ()
+putPreTable b 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
+       liftPure $ put n >> binPut b 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
@@ -34,12 +34,12 @@ -- 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
+putTable (Table b pt) = runCont (putPreTable b pt) pure
 -- deserialization
 fillTable :: Table a -> GS ()
 -- ^ This function reads the table from the ByteString.
-fillTable (Table pt) = genPairs `oBind` insPairs where
-    genPair = (,) <$> pureO get <*> binGet (tabRefs pt)
+fillTable (Table b pt) = genPairs `oBind` insPairs where
+    genPair = (,) <$> pureO get <*> binGet b (tabRefs pt)
     genPairs = (,) <$> pureO get <*> (get `bindO` replicateO genPair)
     insPairs ~(counter, pairs) =
         do writeTVar (tabCount pt) counter

@@ -3,12 +3,12 @@     (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.Bin (Bin, TableRefs(TRNil, TRPair), binPair, binUnit)
 import Data.HMemDb.MapTVar (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
+    RefConv :: Bin r -> TableRefs r -> PreRefConv r input output -> RefConv input output
 (|*|) ::
     PreRefConv r1 input (middle -> output)
     -> PreRefConv r2 input middle
@@ -19,6 +19,7 @@ instance Functor (RefConv input) where fmap h r = pure h <*> r
 instance Applicative (RefConv input) where
     pure output =
-        RefConv TRNil $
+        RefConv binUnit TRNil $
         PreRefConv {rcFrom = const $ return (), rcTo = \ ~() -> return output}
-    RefConv trf pf <*> RefConv trx px = RefConv (TRPair trf trx) (pf |*| px)
+    RefConv bf trf pf <*> RefConv bx trx px =
+        RefConv (binPair bf bx) (TRPair trf trx) (pf |*| px)

@@ -8,6 +8,7 @@      TableSpec,
      key,
      makeRC,
+     mval,
      nonunique,
      tref,
      val,
@@ -18,14 +19,19 @@ import Data.Binary (Binary)
 import Data.Set (Set)
 import Data.HMemDb.Bin
-    (Proxy(Proxy, unProxy), TableGetData(TableGetData), TableRefs(TRProxy, TRVar))
+    (Proxy(Proxy, unProxy), TableGetData(TableGetData), TableRefs(TRProxy, TRVar),
+     binProxy, binCRef)
 import Data.HMemDb.ForeignKeys (ForeignKey, getCRef, keyTarget)
+import Data.HMemDb.MapTVar (liftMaybe)
 import Data.HMemDb.RefConverter (PreRefConv(PreRefConv, rcFrom, rcTo), RefConv(RefConv))
 import Data.HMemDb.References (cRefIndex, deCRef, readCRef)
 import Data.HMemDb.Tables (Table(Table), tabContent, tabConv)
 import Data.HMemDb.TableVarId (TableVarId(TableVarId))
 data TableSpecPart input col where
-    TSPVal :: Binary col => (input -> col) -> TableSpecPart input col
+    TSPVal ::
+        Binary r => (input -> r)
+        -> (r -> Maybe col)
+        -> TableSpecPart input col
     TSPKey :: Ord i => (input -> i) -> ForeignKey Id i col -> TableSpecPart input col
     TSPRef ::
         (input -> TableVarId col) -> Table col -> TableSpecPart input (TableVarId col)
@@ -44,7 +50,11 @@ 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 = CSPart (TSPVal h) (pure id)
+val = mval id Just
+mval :: Binary r => (col -> r) -> (r -> Maybe 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 in a specific way.
+mval p g h = CSPart (TSPVal (p . h) g) (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.
@@ -60,21 +70,27 @@ -- > tabSpec = TableSpec (MyData <$> val myField1 <*> val myField2)
 --
 cspToRC :: TableSpecPart input col -> RefConv input col
-cspToRC (TSPVal g) =
-    RefConv TRProxy (PreRefConv {rcFrom = return . Proxy . g, rcTo = return . unProxy})
+cspToRC (TSPVal g d) =
+    RefConv binProxy
+            TRProxy
+            (PreRefConv {rcFrom = return . Proxy . g, rcTo = liftMaybe . d . unProxy})
 cspToRC (TSPKey g f) =
     case keyTarget f of
-      Table pt ->
+      Table _ pt ->
           let tgd = TableGetData (rcTo $ tabConv pt) (tabContent pt)
-          in RefConv (TRVar tgd) (PreRefConv {rcFrom = getCRef f . g, rcTo = deCRef})
-cspToRC (TSPRef g (Table pt)) =
+          in RefConv binCRef
+                 (TRVar tgd)
+                 (PreRefConv {rcFrom = getCRef f . g, rcTo = deCRef})
+cspToRC (TSPRef g (Table _ pt)) =
     let tv = tabContent pt
         rto = rcTo $ tabConv pt
         from input = 
             do let TableVarId index = g input
                readCRef rto tv index
         to = return . TableVarId . cRefIndex
-    in RefConv (TRVar $ TableGetData rto tv) (PreRefConv {rcFrom = from, rcTo = to})
+    in RefConv binCRef
+           (TRVar $ TableGetData rto tv)
+           (PreRefConv {rcFrom = from, rcTo = to})
 makeRC :: ColSpec input output -> RefConv input output
 makeRC (CSEnd output) = pure output
 makeRC (CSPart csp c) = makeRC c <*> cspToRC csp

@@ -13,10 +13,10 @@ instance Ord (TableVarId a) where compare = compare `on` unTVId varToId :: TableVar a -> TableVarId a -- ^ This function gets an Id of the variable.-varToId (TableVar iref _) = TableVarId $ refIndex $ unId iref+varToId (TableVar _ iref _) = TableVarId $ refIndex $ unId iref idToVar :: Table a -> TableVarId a -> MS (TableVar a) -- ^ This function looks up the specific Id in the 'Table'.-idToVar (Table pt) tvId =+idToVar (Table b pt) tvId =     do let i = unTVId tvId        tv <- readTVarMap (tabContent pt) i-       return $ TableVar (Id Ref {refContent = tv, refIndex = i}) pt+       return $ TableVar b (Id Ref {refContent = tv, refIndex = i}) pt

@@ -18,17 +18,17 @@      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 :: Bin r => s (Ref r) -> PreTable r a -> TableVarS s a
+    TableVar :: Bin r -> 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 'Data.HMemDb.select' functions.
 tableVarTarget :: TableVarS s a -> Table a
 -- ^ This function returns the 'Table' that the 'TableVar' is from.
-tableVarTarget (TableVar _ pt) = Table pt
+tableVarTarget (TableVar b _ pt) = Table b pt
 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) =
+readTV (TableVar _ iref pt) =
     do let ref = unId iref
        r <- deRef ref
        rcTo (tabConv pt) r `mplus` (deleteFromTable ref pt >> mzero)
@@ -37,26 +37,26 @@ -- It returnes the original value, provided that it wasn't removed before
 -- or invalidated by removing some other value this one references
 -- with 'Data.HMemDb.ForeignKey'.
-deleteTV (TableVar iref pt) = deleteFromTable (unId iref) pt
+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
+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) =
+insert a (Table b pt) =
     do ref <- insertIntoTable a pt
-       return $ TableVar (Id ref) pt
+       return $ TableVar b (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
+forTV h (TableVar b s pt) = for_ s $ \ref -> h $ TableVar b (Id ref) pt
 selectAll :: Table a -> STM (TableVarS Set a)
 -- ^ This function gives the set of all values in the table.
-selectAll (Table pt) =
+selectAll (Table b pt) =
     do mp <- readTVar $ tabContent pt
        let makeRef ~(n, tv) = Ref {refContent = tv, refIndex = n}
-       return $ TableVar (fromAscList $ map makeRef $ toAscList mp) pt
+       return $ TableVar b (fromAscList $ map makeRef $ toAscList mp) pt

@@ -42,7 +42,7 @@                  tabRefs = tr
                }
        return pt
-data Table a where Table :: Bin r => PreTable r a -> Table 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 'Data.HMemDb.TableVar's
 -- or 'Data.HMemDb.ForeignKey's.
@@ -87,6 +87,6 @@ foldTable_ :: (a -> MS b) -> Table a -> STM ()
 -- ^ This function traverses through all values in the table, applying the same action
 -- to all of them. Errors are silently ignored.
-foldTable_ h (Table pt) =
+foldTable_ h (Table _ pt) =
     do mp <- readTVar $ tabContent pt
        for_ mp $ \tv -> runMaybeT $ MaybeT (readTVar tv) >>= rcTo (tabConv pt) >>= h