module Data.HMemDb.Specs
(
ColSpec,
FullSpec(FullSpec, keySpec, tabSpec),
Keys(Keys),
KeySpec(KeySpec),
TableSpec(TableSpec),
key,
makeRC,
nonunique,
val,
unique,
(:+:)((:+:))) where
import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Control.Compose (Id)
import Data.Binary (Binary)
import Data.Set (Set)
import Data.HMemDb.Bin
(Proxy(Proxy, unProxy), TableGetData(TableGetData), TableRefs(TRProxy, TRVar))
import Data.HMemDb.ForeignKeys (ForeignKey, getCRef, keyTarget)
import Data.HMemDb.RefConverter (PreRefConv(PreRefConv, rcFrom, rcTo), RefConv(RefConv))
import Data.HMemDb.References (deCRef)
import Data.HMemDb.Tables (Table(Table), tabContent, tabConv)
data ColSpec input output where
CSEnd :: output -> ColSpec input output
CSVal ::
Binary col => (input -> col)
-> ColSpec input (col -> output)
-> ColSpec input output
CSKey ::
Ord i => (input -> i)
-> ForeignKey Id i col
-> ColSpec input (col -> output)
-> ColSpec input output
instance Functor (ColSpec input) where
fmap h (CSEnd output) = CSEnd $ h output
fmap h (CSVal g c) = CSVal g $ (h .) <$> c
fmap h (CSKey g f c) = CSKey g f $ (h .) <$> c
instance Applicative (ColSpec input) where
pure = CSEnd
CSEnd h <*> c = h <$> c
CSVal g c <*> c' = CSVal g $ flip <$> c <*> c'
CSKey g f c <*> c' = CSKey g f $ flip <$> c <*> c'
val :: Binary col => (input -> col) -> ColSpec input col
val h = CSVal h $ pure id
key :: Ord i => ForeignKey Id i col -> (input -> i) -> ColSpec input col
key k h = CSKey h k $ pure id
newtype TableSpec a = TableSpec (ColSpec a a)
makeRC :: ColSpec input output -> RefConv input output
makeRC (CSEnd output) = pure output
makeRC (CSVal g c) =
makeRC c <*>
RefConv TRProxy (PreRefConv {rcFrom = return . Proxy . g, rcTo = return . unProxy})
makeRC (CSKey g f c) =
case keyTarget f of
Table pt ->
let tgd = TableGetData (rcTo $ tabConv pt) (tabContent pt)
in makeRC c <*>
RefConv (TRVar $ tgd) (PreRefConv {rcFrom = getCRef f . g, rcTo = deCRef})
data KeySpec (s :: * -> *) i a = KeySpec (a -> i)
unique :: (a -> i) -> KeySpec Id i a
unique = KeySpec
nonunique :: (a -> i) -> KeySpec Set i a
nonunique = KeySpec
data Keys a (h :: (* -> *) -> * -> * -> *) = Keys
data (u :+: ks) a h where (:+:) :: u a h -> h s i a -> (u :+: KeySpec s i) a h
infixl 4 :+:
data FullSpec a u = FullSpec {tabSpec :: TableSpec a, keySpec :: u a KeySpec}