module Database.Relational.Sequence (
Sequence (..), seqRelation,
unsafeSpecifySequence,
SequenceDerivable (..),
Binding (..), fromRelation,
Number, unsafeSpecifyNumber, extractNumber,
($$!), ($$),
updateNumber,
) where
import Prelude hiding (seq)
import Database.Record (PersistableWidth)
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.Projectable ((.<=.), value, unitPlaceHolder, (!))
import Database.Relational.ProjectableClass (ShowConstantTermsSQL)
import Database.Relational.Relation (tableOf)
import qualified Database.Relational.Relation as Relation
import Database.Relational.Effect (updateTarget')
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
class (TableDerivable r, SequenceDerivable s i)
=> Binding r s i | r -> s where
fromTable :: 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, ShowConstantTermsSQL i)
=> i
-> Sequence s i
-> Update ()
updateNumber i seqt = typedUpdate (seqTable seqt) . updateTarget' $ \ proj -> do
let iv = value i
seqKey seqt <-# iv
wheres $ proj ! seqKey seqt .<=. iv
return unitPlaceHolder