module Data.HMemDb.CreateTable
(CreateTable(makeTable, fixKeys), IsKeySpec, createTable) where
import Control.Concurrent.STM (STM, newTVar)
import qualified Data.Map as M (empty)
import Data.HMemDb.Bin (Bin)
import Data.HMemDb.ForeignKeys
(ForeignKey, PreForeignKey(PreForeignKey), makeForeignKey)
import Data.HMemDb.KeyBackends (KeyBack(KeyBack), PreKeyBack(PreKeyBack))
import Data.HMemDb.MapTVar (readTVarMap)
import Data.HMemDb.RefContainer (RefContainer)
import Data.HMemDb.RefConverter (PreRefConv, RefConv(RefConv))
import Data.HMemDb.Specs
(FullSpec(keySpec, tabSpec), Keys(Keys), KeySpec(KeySpec), makeRC, (:+:)((:+:)))
import Data.HMemDb.Tables
(PreTable(tabIndices), Table(Table), emptyPreTable)
class CreateTable u where
makeTable ::
Bin 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
instance CreateTable Keys where
makeTable pr ~Keys =
do pt <- emptyPreTable pr
return (pt, Keys)
fixKeys _ ~Keys = Keys
class IsKeySpec ks where
makeTableKS ::
(Bin r, CreateTable u) => 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 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 :+: PreForeignKey (readTVarMap tv))
instance (CreateTable u, IsKeySpec ks) => CreateTable (u :+: ks) where
makeTable = makeTableKS
fixKeys pt (uf :+: pfk) = fixKeys pt uf :+: makeForeignKey pt pfk
createTable :: CreateTable u => FullSpec a u -> STM (Table a, u a ForeignKey)
createTable fs =
case makeRC $ tabSpec fs of
RefConv _ pr ->
do (pt, pfks) <- makeTable pr (keySpec fs)
return (Table pt, fixKeys pt pfks)