{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
module Database.Record.ToSql (
ToSqlM, execToSqlM, RecordToSql, runFromRecord, wrapToSql,
createRecordToSql,
(<&>),
ToSql (recordToSql),
putRecord, putEmpty, fromRecord,
valueRecordToSql,
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
execToSqlM :: ToSqlM q a -> [q]
execToSqlM :: forall q a. ToSqlM q a -> [q]
execToSqlM = forall a. DList a -> [a]
DList.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w a. Writer w a -> w
execWriter
newtype RecordToSql q a = RecordToSql (a -> ToSqlM q ())
runRecordToSql :: RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql :: forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql (RecordToSql a -> ToSqlM q ()
f) = a -> ToSqlM q ()
f
wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql :: forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql = forall q a. (a -> ToSqlM q ()) -> RecordToSql q a
RecordToSql
runFromRecord :: RecordToSql q a
-> a
-> [q]
runFromRecord :: forall q a. RecordToSql q a -> a -> [q]
runFromRecord RecordToSql q a
r = forall q a. ToSqlM q a -> [q]
execToSqlM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql RecordToSql q a
r
createRecordToSql :: (a -> [q])
-> RecordToSql q a
createRecordToSql :: forall a q. (a -> [q]) -> RecordToSql q a
createRecordToSql a -> [q]
f = forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> DList a
DList.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [q]
f
mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a
mapToSql :: forall a b q. (a -> b) -> RecordToSql q b -> RecordToSql q a
mapToSql a -> b
f RecordToSql q b
x = forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql forall a b. (a -> b) -> a -> b
$ forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql RecordToSql q b
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
-> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
productToSql :: forall c a b q.
(c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
-> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
productToSql c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ()
run RecordToSql q a
ra RecordToSql q b
rb = forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql forall a b. (a -> b) -> a -> b
$ \c
c -> c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ()
run c
c forall a b. (a -> b) -> a -> b
$ \a
a b
b -> do
forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql RecordToSql q a
ra a
a
forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql RecordToSql q b
rb b
b
(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)
<&> :: forall q a b.
RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)
(<&>) = forall c a b q.
(c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
-> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
productToSql forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry
maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a)
maybeRecord :: forall q a.
PersistableSqlType q
-> PersistableRecordWidth a
-> RecordToSql q a
-> RecordToSql q (Maybe a)
maybeRecord PersistableSqlType q
qt PersistableRecordWidth a
w RecordToSql q a
ra = forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql Maybe a -> ToSqlM q ()
d where
d :: Maybe a -> ToSqlM q ()
d (Just a
r) = forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql RecordToSql q a
ra a
r
d Maybe a
Nothing = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> DList a
DList.replicate (forall a. PersistableRecordWidth a -> Int
runPersistableRecordWidth PersistableRecordWidth a
w) (forall q. PersistableSqlType q -> q
runPersistableNullValue PersistableSqlType q
qt)
infixl 4 <&>
class PersistableWidth a => ToSql q a where
recordToSql :: RecordToSql q a
default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a
recordToSql = forall a x. Generic a => a -> Rep a x
from forall a b q. (a -> b) -> RecordToSql q b -> RecordToSql q a
`mapToSql` forall q (f :: * -> *) a. GToSql q f => RecordToSql q (f a)
gToSql
class GToSql q f where
gToSql :: RecordToSql q (f a)
instance GToSql q U1 where
gToSql :: forall a. RecordToSql q (U1 a)
gToSql = forall a q. (a -> ToSqlM q ()) -> RecordToSql q a
wrapToSql forall a b. (a -> b) -> a -> b
$ \U1 a
U1 -> forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall a. DList a
DList.empty
instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where
gToSql :: forall a. RecordToSql q ((:*:) a b a)
gToSql = forall c a b q.
(c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
-> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
productToSql (\ (a a
a:*:b a
b) a a -> b a -> ToSqlM q ()
f -> a a -> b a -> ToSqlM q ()
f a a
a b a
b) forall q (f :: * -> *) a. GToSql q f => RecordToSql q (f a)
gToSql forall q (f :: * -> *) a. GToSql q f => RecordToSql q (f a)
gToSql
instance GToSql q a => GToSql q (M1 i c a) where
gToSql :: forall a. RecordToSql q (M1 i c a a)
gToSql = (\(M1 a a
a) -> a a
a) forall a b q. (a -> b) -> RecordToSql q b -> RecordToSql q a
`mapToSql` forall q (f :: * -> *) a. GToSql q f => RecordToSql q (f a)
gToSql
instance ToSql q a => GToSql q (K1 i a) where
gToSql :: forall a. RecordToSql q (K1 i a a)
gToSql = (\(K1 a
a) -> a
a) forall a b q. (a -> b) -> RecordToSql q b -> RecordToSql q a
`mapToSql` forall q a. ToSql q a => RecordToSql q a
recordToSql
instance (PersistableType q, ToSql q a) => ToSql q (Maybe a) where
recordToSql :: RecordToSql q (Maybe a)
recordToSql = forall q a.
PersistableSqlType q
-> PersistableRecordWidth a
-> RecordToSql q a
-> RecordToSql q (Maybe a)
maybeRecord forall q. PersistableType q => PersistableSqlType q
persistableType forall a. PersistableWidth a => PersistableRecordWidth a
persistableWidth forall q a. ToSql q a => RecordToSql q a
recordToSql
instance ToSql q ()
putRecord :: ToSql q a => a -> ToSqlM q ()
putRecord :: forall q a. ToSql q a => a -> ToSqlM q ()
putRecord = forall q a. RecordToSql q a -> a -> ToSqlM q ()
runRecordToSql forall q a. ToSql q a => RecordToSql q a
recordToSql
putEmpty :: () -> ToSqlM q ()
putEmpty :: forall q. () -> ToSqlM q ()
putEmpty = forall q a. ToSql q a => a -> ToSqlM q ()
putRecord
fromRecord :: ToSql q a => a -> [q]
fromRecord :: forall q a. ToSql q a => a -> [q]
fromRecord = forall q a. ToSqlM q a -> [q]
execToSqlM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall q a. ToSql q a => a -> ToSqlM q ()
putRecord
valueRecordToSql :: (a -> q) -> RecordToSql q a
valueRecordToSql :: forall a q. (a -> q) -> RecordToSql q a
valueRecordToSql = forall a q. (a -> [q]) -> RecordToSql q a
createRecordToSql forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
untypedUpdateValuesIndex :: [Int]
-> Int
-> [Int]
untypedUpdateValuesIndex :: [Int] -> Int -> [Int]
untypedUpdateValuesIndex [Int]
key Int
width = [Int]
otherThanKey where
maxIx :: Int
maxIx = Int
width forall a. Num a => a -> a -> a
- Int
1
otherThanKey :: [Int]
otherThanKey = forall a. Set a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
fromList [Int
0 .. Int
maxIx] forall a. Ord a => Set a -> Set a -> Set a
\\ forall a. Ord a => [a] -> Set a
fromList [Int]
key
unsafeUpdateValuesWithIndexes :: ToSql q ra
=> [Int]
-> ra
-> [q]
unsafeUpdateValuesWithIndexes :: forall q ra. ToSql q ra => [Int] -> ra -> [q]
unsafeUpdateValuesWithIndexes [Int]
key ra
a =
[ Array Int q
valsA forall i e. Ix i => Array i e -> i -> e
! Int
i | Int
i <- [Int]
otherThanKey forall a. [a] -> [a] -> [a]
++ [Int]
key ] where
vals :: [q]
vals = forall q a. ToSqlM q a -> [q]
execToSqlM forall a b. (a -> b) -> a -> b
$ forall q a. ToSql q a => a -> ToSqlM q ()
putRecord ra
a
width :: Int
width = forall (t :: * -> *) a. Foldable t => t a -> Int
length [q]
vals
valsA :: Array Int q
valsA = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
width forall a. Num a => a -> a -> a
- Int
1) [q]
vals
otherThanKey :: [Int]
otherThanKey = [Int] -> Int -> [Int]
untypedUpdateValuesIndex [Int]
key Int
width
updateValuesByUnique :: ToSql q ra
=> KeyConstraint Unique ra
-> ra
-> [q]
updateValuesByUnique :: forall q ra. ToSql q ra => KeyConstraint Unique ra -> ra -> [q]
updateValuesByUnique KeyConstraint Unique ra
uk = forall q ra. ToSql q ra => [Int] -> ra -> [q]
unsafeUpdateValuesWithIndexes (forall c r. KeyConstraint c r -> [Int]
indexes KeyConstraint Unique ra
uk)
updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra)
=> ra -> [q]
updateValuesByPrimary :: forall ra q. (HasKeyConstraint Primary ra, ToSql q ra) => ra -> [q]
updateValuesByPrimary = forall q ra. ToSql q ra => KeyConstraint Unique ra -> ra -> [q]
updateValuesByUnique (forall r. PrimaryConstraint r -> UniqueConstraint r
unique forall c a. HasKeyConstraint c a => KeyConstraint c a
keyConstraint)