{-# 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 'Data.HMemDb.KeySpec's and 'Data.HMemDb.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 ('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 (FullSpec {tabSpec = TableSpec cs, keySpec = ks}) =
    case makeRC cs of RefConv _ pr -> first Table <$> makeTable pr ks