module Database.Record.ToSql (
ToSqlM, RecordToSql, runFromRecord,
createRecordToSql,
(<&>),
ToSql (recordToSql),
putRecord, putEmpty, fromRecord, wrapToSql,
valueRecordToSql,
updateValuesByUnique',
updateValuesByUnique,
updateValuesByPrimary,
untypedUpdateValuesIndex,
unsafeUpdateValuesWithIndexes
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)
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
mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a
mapToSql f x = wrapToSql $ runRecordToSql x . f
productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
-> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
productToSql run ra rb = wrapToSql $ \c -> run c $ \a b -> do
runRecordToSql ra a
runRecordToSql rb b
(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)
(<&>) = productToSql $ flip uncurry
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
default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a
recordToSql = from `mapToSql` gToSql
class GToSql q f where
gToSql :: RecordToSql q (f a)
instance GToSql q U1 where
gToSql = wrapToSql $ \U1 -> tell DList.empty
instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where
gToSql = productToSql (\ (a:*:b) f -> f a b) gToSql gToSql
instance GToSql q a => GToSql q (M1 i c a) where
gToSql = (\(M1 a) -> a) `mapToSql` gToSql
instance ToSql q a => GToSql q (K1 i a) where
gToSql = (\(K1 a) -> a) `mapToSql` recordToSql
instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where
recordToSql = maybeRecord persistableType persistableWidth recordToSql
instance ToSql q ()
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)