module Database.Record.ToSql (
ToSqlM, RecordToSql, runFromRecord,
createRecordToSql,
(<&>),
ToSql (recordToSql),
putRecord, putEmpty, fromRecord, wrapToSql,
valueRecordToSql,
updateValuesByUnique',
updateValuesByUnique,
updateValuesByPrimary,
untypedUpdateValuesIndex,
unsafeUpdateValuesWithIndexes
) where
import Data.Array (listArray, (!))
import Data.Set (toList, fromList, (\\))
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.DList (DList)
import qualified Data.DList as DList
import Database.Record.Persistable
(PersistableSqlType, runPersistableNullValue, PersistableType (persistableType),
PersistableRecordWidth, runPersistableRecordWidth, PersistableWidth(persistableWidth))
import Database.Record.KeyConstraint
(Primary, Unique, KeyConstraint, HasKeyConstraint(keyConstraint), unique, indexes)
type ToSqlM q a = Writer (DList q) a
runToSqlM :: ToSqlM q a -> [q]
runToSqlM = DList.toList . execWriter
newtype RecordToSql q a = RecordToSql (a -> ToSqlM q ())
runRecordToSql :: RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql (RecordToSql f) = f
wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql = RecordToSql
runFromRecord :: RecordToSql q a
-> a
-> [q]
runFromRecord r = runToSqlM . runRecordToSql r
createRecordToSql :: (a -> [q])
-> RecordToSql q a
createRecordToSql f = wrapToSql $ tell . DList.fromList . f
(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)
ra <&> rb = RecordToSql $ \(a, b) -> do
runRecordToSql ra a
runRecordToSql rb b
maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a)
maybeRecord qt w ra = wrapToSql d where
d (Just r) = runRecordToSql ra r
d Nothing = tell $ DList.replicate (runPersistableRecordWidth w) (runPersistableNullValue qt)
infixl 4 <&>
class ToSql q a where
recordToSql :: RecordToSql q a
instance (ToSql q a, ToSql q b) => ToSql q (a, b) where
recordToSql = recordToSql <&> recordToSql
instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where
recordToSql = maybeRecord persistableType persistableWidth recordToSql
instance ToSql q () where
recordToSql = wrapToSql $ \() -> tell DList.empty
putRecord :: ToSql q a => a -> ToSqlM q ()
putRecord = runRecordToSql recordToSql
putEmpty :: () -> ToSqlM q ()
putEmpty = putRecord
fromRecord :: ToSql q a => a -> [q]
fromRecord = runToSqlM . putRecord
valueRecordToSql :: (a -> q) -> RecordToSql q a
valueRecordToSql = createRecordToSql . ((:[]) .)
untypedUpdateValuesIndex :: [Int]
-> Int
-> [Int]
untypedUpdateValuesIndex key width = otherThanKey where
maxIx = width 1
otherThanKey = toList $ fromList [0 .. maxIx] \\ fromList key
unsafeUpdateValuesWithIndexes :: RecordToSql q ra
-> [Int]
-> ra
-> [q]
unsafeUpdateValuesWithIndexes pr key a =
[ valsA ! i | i <- otherThanKey ++ key ] where
vals = runFromRecord pr a
width = length vals
valsA = listArray (0, width 1) vals
otherThanKey = untypedUpdateValuesIndex key width
updateValuesByUnique' :: RecordToSql q ra
-> KeyConstraint Unique ra
-> ra
-> [q]
updateValuesByUnique' pr uk = unsafeUpdateValuesWithIndexes pr (indexes uk)
updateValuesByUnique :: ToSql q ra
=> KeyConstraint Unique ra
-> ra
-> [q]
updateValuesByUnique = updateValuesByUnique' recordToSql
updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra)
=> ra -> [q]
updateValuesByPrimary = updateValuesByUnique (unique keyConstraint)