{-# LANGUAGE GADTs, TypeOperators, TypeFamilies, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module Database.Selda.Compile
( Result, Res
, buildResult, compQuery, compQueryWithFreshScope
, compile, compileWith
, compileInsert, compileUpdate, compileDelete
)
where
import Control.Monad (liftM2)
import Database.Selda.Column
( UntypedCol(Untyped),
SomeCol(Some),
Row(..),
Col(..),
Columns(toTup) )
import Database.Selda.Generic ( Relational, params )
import Database.Selda.Query.Type
( GenState(nameSupply), Query, Scope, runQueryM )
import Database.Selda.SQL ( Param, SQL(SQL), SqlSource(Product) )
import Database.Selda.SQL.Print ( compSql, compUpdate, compDelete )
import Database.Selda.SQL.Print.Config
( PPConfig(ppMaxInsertParams), defPPConfig )
import Database.Selda.SqlRow
( SqlRow(nextResult), ResultReader, runResultReader, next )
import Database.Selda.SqlType ( SqlValue, SqlType(fromSql) )
import Database.Selda.Table
( ColInfo(colName), Table(tableCols, tableName), tableExpr )
import Database.Selda.Table.Compile ( compInsert )
import Database.Selda.Transform
( removeDeadCols, implicitlyLiveCols, colNames, state2sql )
import Database.Selda.Types ( type (:*:)(..) )
import Data.Proxy ( Proxy(..) )
import Data.Text (Text, empty)
import Data.Typeable (Typeable)
import Data.IORef ( IORef, atomicModifyIORef', newIORef )
import System.IO.Unsafe ( unsafePerformIO )
compile :: Result a => Query s a -> (Text, [Param])
compile :: forall a s. Result a => Query s a -> (Text, [Param])
compile = forall a s. Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith PPConfig
defPPConfig
compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith :: forall a s. Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith PPConfig
cfg = PPConfig -> SQL -> (Text, [Param])
compSql PPConfig
cfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Result a => Scope -> Query s a -> (Scope, SQL)
compQuery Scope
0
compileInsert :: Relational a => PPConfig -> Table a -> [a] -> [(Text, [Param])]
compileInsert :: forall a.
Relational a =>
PPConfig -> Table a -> [a] -> [(Text, [Param])]
compileInsert PPConfig
_ Table a
_ [] =
[(Text
empty, [])]
compileInsert PPConfig
cfg Table a
tbl [a]
rows =
case PPConfig -> Maybe Scope
ppMaxInsertParams PPConfig
cfg of
Maybe Scope
Nothing -> [forall a.
PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert PPConfig
cfg Table a
tbl [[Either Param Param]]
rows']
Just Scope
n -> forall a b. (a -> b) -> [a] -> [b]
map (forall a.
PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert PPConfig
cfg Table a
tbl) (forall {a}. Scope -> [a] -> [[a]]
chunk (Scope
n forall a. Integral a => a -> a -> a
`div` Scope
rowlen) [[Either Param Param]]
rows')
where
rows' :: [[Either Param Param]]
rows' = forall a b. (a -> b) -> [a] -> [b]
map forall a. Relational a => a -> [Either Param Param]
params [a]
rows
rowlen :: Scope
rowlen = forall (t :: * -> *) a. Foldable t => t a -> Scope
length (forall a. [a] -> a
head [[Either Param Param]]
rows')
chunk :: Scope -> [a] -> [[a]]
chunk Scope
chunksize [a]
xs =
case forall a. Scope -> [a] -> ([a], [a])
splitAt Scope
chunksize [a]
xs of
([], []) -> []
([a]
x, []) -> [[a]
x]
([a]
x, [a]
xs') -> [a]
x forall a. a -> [a] -> [a]
: Scope -> [a] -> [[a]]
chunk Scope
chunksize [a]
xs'
compileUpdate :: forall s a. (Relational a, SqlRow a)
=> PPConfig
-> Table a
-> (Row s a -> Row s a)
-> (Row s a -> Col s Bool)
-> (Text, [Param])
compileUpdate :: forall s a.
(Relational a, SqlRow a) =>
PPConfig
-> Table a
-> (Row s a -> Row s a)
-> (Row s a -> Col s Bool)
-> (Text, [Param])
compileUpdate PPConfig
cfg Table a
tbl Row s a -> Row s a
upd Row s a -> Col s Bool
check =
PPConfig
-> TableName
-> Exp SQL Bool
-> [(ColName, SomeCol SQL)]
-> (Text, [Param])
compUpdate PPConfig
cfg (forall a. Table a -> TableName
tableName Table a
tbl) Exp SQL Bool
predicate [(ColName, SomeCol SQL)]
updated
where
names :: [ColName]
names = forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> ColName
colName (forall a. Table a -> [ColInfo]
tableCols Table a
tbl)
cs :: Row s a
cs = forall a s. Table a -> Row s a
tableExpr Table a
tbl
updated :: [(ColName, SomeCol SQL)]
updated = forall a b. [a] -> [b] -> [(a, b)]
zip [ColName]
names (forall r. Result r => r -> [SomeCol SQL]
finalCols (Row s a -> Row s a
upd Row s a
cs))
One Exp SQL Bool
predicate = Row s a -> Col s Bool
check Row s a
cs
compileDelete :: Relational a
=> PPConfig
-> Table a
-> (Row s a -> Col s Bool)
-> (Text, [Param])
compileDelete :: forall a s.
Relational a =>
PPConfig -> Table a -> (Row s a -> Col s Bool) -> (Text, [Param])
compileDelete PPConfig
cfg Table a
tbl Row s a -> Col s Bool
check = PPConfig -> TableName -> Exp SQL Bool -> (Text, [Param])
compDelete PPConfig
cfg (forall a. Table a -> TableName
tableName Table a
tbl) Exp SQL Bool
predicate
where One Exp SQL Bool
predicate = Row s a -> Col s Bool
check forall a b. (a -> b) -> a -> b
$ forall a. Columns a => [ColName] -> a
toTup forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> ColName
colName forall a b. (a -> b) -> a -> b
$ forall a. Table a -> [ColInfo]
tableCols Table a
tbl
compQuery :: Result a => Scope -> Query s a -> (Int, SQL)
compQuery :: forall a s. Result a => Scope -> Query s a -> (Scope, SQL)
compQuery Scope
ns Query s a
q =
(GenState -> Scope
nameSupply GenState
st, [SomeCol SQL]
-> SqlSource
-> [Exp SQL Bool]
-> [SomeCol SQL]
-> [(Order, SomeCol SQL)]
-> Maybe (Scope, Scope)
-> [SomeCol SQL]
-> Bool
-> SQL
SQL [SomeCol SQL]
final ([SQL] -> SqlSource
Product [SQL
srcs]) [] [] [] forall a. Maybe a
Nothing [] Bool
False)
where
(a
cs, GenState
st) = forall s a. Scope -> Query s a -> (a, GenState)
runQueryM Scope
ns Query s a
q
final :: [SomeCol SQL]
final = forall r. Result r => r -> [SomeCol SQL]
finalCols a
cs
sql :: SQL
sql = GenState -> SQL
state2sql GenState
st
live :: [ColName]
live = [SomeCol SQL] -> [ColName]
colNames [SomeCol SQL]
final forall a. [a] -> [a] -> [a]
++ SQL -> [ColName]
implicitlyLiveCols SQL
sql
srcs :: SQL
srcs = [ColName] -> SQL -> SQL
removeDeadCols [ColName]
live SQL
sql
{-# NOINLINE scopeSupply #-}
scopeSupply :: IORef Scope
scopeSupply :: IORef Scope
scopeSupply = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Scope
1
compQueryWithFreshScope :: Result a => Query s a -> (Int, SQL)
compQueryWithFreshScope :: forall a s. Result a => Query s a -> (Scope, SQL)
compQueryWithFreshScope Query s a
q = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Scope
s <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Scope
scopeSupply (\Scope
s -> (Scope
sforall a. Num a => a -> a -> a
+Scope
1, Scope
s))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a s. Result a => Scope -> Query s a -> (Scope, SQL)
compQuery Scope
s Query s a
q
buildResult :: Result r => Proxy r -> [SqlValue] -> Res r
buildResult :: forall r. Result r => Proxy r -> [SqlValue] -> Res r
buildResult Proxy r
p = forall a. ResultReader a -> [SqlValue] -> a
runResultReader (forall r. Result r => Proxy r -> ResultReader (Res r)
toRes Proxy r
p)
type family Res r where
Res (Col s a :*: b) = a :*: Res b
Res (Row s a :*: b) = a :*: Res b
Res (Col s a) = a
Res (Row s a) = a
class Typeable (Res r) => Result r where
toRes :: Proxy r -> ResultReader (Res r)
finalCols :: r -> [SomeCol SQL]
instance (SqlType a, Result b) => Result (Col s a :*: b) where
toRes :: Proxy (Col s a :*: b) -> ResultReader (Res (Col s a :*: b))
toRes Proxy (Col s a :*: b)
_ = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a b. a -> b -> a :*: b
(:*:) (forall a. SqlType a => SqlValue -> a
fromSql forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResultReader SqlValue
next) (forall r. Result r => Proxy r -> ResultReader (Res r)
toRes (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))
finalCols :: (Col s a :*: b) -> [SomeCol SQL]
finalCols (Col s a
a :*: b
b) = forall r. Result r => r -> [SomeCol SQL]
finalCols Col s a
a forall a. [a] -> [a] -> [a]
++ forall r. Result r => r -> [SomeCol SQL]
finalCols b
b
instance (SqlRow a, Result b) => Result (Row s a :*: b) where
toRes :: Proxy (Row s a :*: b) -> ResultReader (Res (Row s a :*: b))
toRes Proxy (Row s a :*: b)
_ = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a b. a -> b -> a :*: b
(:*:) forall a. SqlRow a => ResultReader a
nextResult (forall r. Result r => Proxy r -> ResultReader (Res r)
toRes (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))
finalCols :: (Row s a :*: b) -> [SomeCol SQL]
finalCols (Row s a
a :*: b
b) = forall r. Result r => r -> [SomeCol SQL]
finalCols Row s a
a forall a. [a] -> [a] -> [a]
++ forall r. Result r => r -> [SomeCol SQL]
finalCols b
b
instance SqlType a => Result (Col s a) where
toRes :: Proxy (Col s a) -> ResultReader (Res (Col s a))
toRes Proxy (Col s a)
_ = forall a. SqlType a => SqlValue -> a
fromSql forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResultReader SqlValue
next
finalCols :: Col s a -> [SomeCol SQL]
finalCols (One Exp SQL a
c) = [forall sql a. Exp sql a -> SomeCol sql
Some Exp SQL a
c]
instance SqlRow a => Result (Row s a) where
toRes :: Proxy (Row s a) -> ResultReader (Res (Row s a))
toRes Proxy (Row s a)
_ = forall a. SqlRow a => ResultReader a
nextResult
finalCols :: Row s a -> [SomeCol SQL]
finalCols (Many [UntypedCol SQL]
cs) = [forall sql a. Exp sql a -> SomeCol sql
Some Exp SQL a
c | Untyped Exp SQL a
c <- [UntypedCol SQL]
cs]