{-# LANGUAGE KindSignatures, GADTs, TypeOperators #-}
module Data.HMemDb.Specs
    (
     ColSpec,
     FullSpec(FullSpec, keySpec, tabSpec),
     Keys(Keys),
     KeySpec(KeySpec),
     TableSpec,
     key,
     makeRC,
     mval,
     nonunique,
     tref,
     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),
     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 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)
-- | This is the internal of the 'TableSpec' type.
data ColSpec input output where
    CSEnd :: output -> ColSpec input output
    CSPart ::
        TableSpecPart input col -> ColSpec input (col -> output) -> ColSpec input output
instance Functor (ColSpec input) where
    fmap h (CSEnd output) = CSEnd $ h output
    fmap h (CSPart csp c) = CSPart csp $ (h .) <$> c
instance Applicative (ColSpec input) where
    pure = CSEnd
    CSEnd h <*> c = h <$> c
    CSPart csp c <*> c' = CSPart csp $ flip <$> c <*> c'
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 = 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.
key k h = CSPart (TSPKey h k) (pure id)
tref :: Table col -> (input -> TableVarId col) -> ColSpec input (TableVarId col)
-- ^ This function eases the use of 'TableVarId's as columns of the table.
tref t h = CSPart (TSPRef h t) (pure id)
type TableSpec a = ColSpec a a
-- ^ This type represents the table structure. It can be generated using the
-- 'Applicative' interface of the 'ColSpec' like this:
--
-- > data MyData = {myField1 :: Integer, myField2 :: String}
-- > tabSpec = TableSpec (MyData <$> val myField1 <*> val myField2)
--
cspToRC :: TableSpecPart input col -> RefConv input col
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 ->
          let tgd = TableGetData (rcTo $ tabConv pt) (tabContent 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 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
data KeySpec (s :: * -> *) i a = KeySpec (a -> i)
-- ^ This is the specification of one 'ForeignKey'. It could be unique or non-unique.
unique :: (a -> i) -> KeySpec Id i a
-- ^ This function specifies a unique key.
unique = KeySpec
nonunique :: (a -> i) -> KeySpec Set i a
-- ^ This function specifies a non-unique key.
nonunique = KeySpec
data Keys a (h :: (* -> *) -> * -> * -> *) = Keys
-- ^ This type represents an empty set of 'KeySpec's or 'ForeignKey's.
data (u :+: ks) a h where (:+:) :: u a h -> h s i a -> (u :+: KeySpec s i) a h
-- ^ This type operator adds one more 'KeySpec' to the set,
-- or allows to get a 'ForeignKey' back with pattern-matching. Use it like this:
--
-- > do (table, ... :+: foreignKey)
-- >      <- createTable $ FullSpec {..., keySpec = ... :+: unique myKey}
--
infixl 4 :+:
data FullSpec a u = FullSpec {tabSpec :: TableSpec a, keySpec :: u a KeySpec}
-- ^ This is the full specification, of both table and set of keys,
-- which should be fed to 'Data.HMemDb.createTable' and 'Data.HMemDb.getTable' functions.