{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
module Database.Relational.Sequence (
Sequence, seqTable, seqExtract, seqKey, seqRelation,
unsafeSpecifySequence,
SeqBinding, boundTable, boundKey, boundSequence,
unsafeSpecifyBinding, primaryBinding,
SequenceDerivable (..),
Binding (..), fromRelation,
Number, unsafeSpecifyNumber, extractNumber,
($$!), ($$),
updateNumber', updateNumber,
) where
import Prelude hiding (seq)
import Database.Record (PersistableWidth)
import Database.Relational.Internal.Config (Config, defaultConfig)
import Database.Relational.Monad.Class (wheres)
import Database.Relational.Monad.BaseType (Relation)
import Database.Relational.Monad.Trans.Assigning ((<-#))
import Database.Relational.Table (TableDerivable, derivedTable, Table)
import Database.Relational.Pi (Pi)
import Database.Relational.Constraint
(HasConstraintKey (..), Key, Primary, projectionKey)
import Database.Relational.Projectable ((.<=.), value, unitPH, (!))
import Database.Relational.ProjectableClass (LiteralSQL)
import Database.Relational.Relation (tableOf)
import qualified Database.Relational.Relation as Relation
import Database.Relational.Type (Update, typedUpdate')
data Sequence s i =
Sequence
{ seqTable :: Table s
, seqExtract :: s -> i
, seqKey :: Pi s i
}
unsafeSpecifySequence :: TableDerivable s => (s -> i) -> Pi s i -> Sequence s i
unsafeSpecifySequence = Sequence derivedTable
seqRelation :: TableDerivable s => Sequence s i -> Relation () s
seqRelation = Relation.table . seqTable
class TableDerivable s => SequenceDerivable s i | s -> i where
derivedSequence :: Sequence s i
data SeqBinding r s i =
SeqBinding
{ boundTable :: Table r
, boundKey :: Pi r i
, boundSequence :: Sequence s i
}
unsafeSpecifyBinding :: (TableDerivable r, SequenceDerivable s i)
=> Pi r i -> SeqBinding r s i
unsafeSpecifyBinding k = SeqBinding derivedTable k derivedSequence
primaryBinding :: (TableDerivable r, SequenceDerivable s i,
HasConstraintKey Primary r i)
=> SeqBinding r s i
primaryBinding = unsafeSpecifyBinding $ primaryKey constraintKey
where
primaryKey :: Key Primary r ct -> Pi r ct
primaryKey = projectionKey
class (TableDerivable r, SequenceDerivable s i)
=> Binding r s i | r -> s where
binding :: SeqBinding r s i
default binding :: HasConstraintKey Primary r i => SeqBinding r s i
binding = primaryBinding
fromTable :: Binding r s i => Table r -> Sequence s i
fromTable = const derivedSequence
fromRelation :: Binding r s i
=> Relation () r
-> Sequence s i
fromRelation = fromTable . tableOf
newtype Number r i = Number i deriving (Eq, Ord, Show)
unsafeSpecifyNumber :: Binding r s i => i -> Number r i
unsafeSpecifyNumber = Number
extractNumber :: Number r i -> i
extractNumber (Number i) = i
($$!) :: (i -> r)
-> Number r i
-> r
($$!) = (. extractNumber)
($$) :: Binding r s i
=> (i -> r)
-> Number r i
-> r
($$) = ($$!)
updateNumber' :: (PersistableWidth s, Integral i, LiteralSQL i)
=> Config
-> i
-> Sequence s i
-> Update ()
updateNumber' config i seqt = typedUpdate' config (seqTable seqt) $ \ proj -> do
let iv = value i
seqKey seqt <-# iv
wheres $ proj ! seqKey seqt .<=. iv
return unitPH
updateNumber :: (PersistableWidth s, Integral i, LiteralSQL i)
=> i
-> Sequence s i
-> Update ()
updateNumber = updateNumber' defaultConfig