CreateTable.hs

{-# LANGUAGE GADTs, TypeOperators #-}
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, TableRefs)
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)
-- | 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
        -> 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 _ tr pr ~Keys =
        do pt <- emptyPreTable tr pr
           return (pt, Keys)
    fixKeys _ _ ~Keys = Keys
-- | This class is here for technical reasons; it has just one instance.
class IsKeySpec ks where
    makeTableKS ::
        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 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 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')
-- and the set of keys ('Data.HMemDb.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 'Data.HMemDb.TableSpec'.
createTable fs =
    case makeRC $ tabSpec fs of
      RefConv b tr pr ->
          do (pt, pfks) <- makeTable b tr pr (keySpec fs)
             return (Table b pt, fixKeys b pt pfks)