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