module Database.Selda.Compile
( Result, Res
, toRes, compQuery, compQueryWithFreshScope
, compile, compileWith, compileWithTables
, compileInsert, compileUpdate, compileDelete
)
where
import Database.Selda.Column
import Database.Selda.Query.Type
import Database.Selda.SQL
import Database.Selda.SQL.Print
import Database.Selda.SQL.Print.Config
import Database.Selda.SqlType
import Database.Selda.Table
import Database.Selda.Table.Compile
import Database.Selda.Transform
import Database.Selda.Types
import Data.Proxy
import Data.Text (Text, empty)
import Data.Typeable (Typeable)
import Data.IORef
import System.IO.Unsafe
compile :: Result a => Query s a -> (Text, [Param])
compile = snd . compileWithTables defPPConfig
compileWith :: Result a => PPConfig -> Query s a -> (Text, [Param])
compileWith cfg = snd . compileWithTables cfg
compileWithTables :: Result a
=> PPConfig
-> Query s a
-> ([TableName], (Text, [Param]))
compileWithTables cfg = compSql cfg . snd . compQuery 0
compileInsert :: Insert a => PPConfig -> Table a -> [a] -> [(Text, [Param])]
compileInsert _ _ [] =
[(empty, [])]
compileInsert cfg tbl rows =
case ppMaxInsertParams cfg of
Nothing -> [compInsert cfg tbl rows']
Just n -> map (compInsert cfg tbl) (chunk (n `div` rowlen) rows')
where
rows' = map params rows
rowlen = length (head rows')
chunk chunksize xs =
case splitAt chunksize xs of
([], []) -> []
(x, []) -> [x]
(x, xs') -> x : chunk chunksize xs'
compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))
=> PPConfig
-> Table a
-> (Cols s a -> Cols s a)
-> (Cols s a -> Col s Bool)
-> (Text, [Param])
compileUpdate cfg tbl upd check =
compUpdate cfg (tableName tbl) predicate updated
where
names = map colName (tableCols tbl)
cs = toTup names
updated = zip names (finalCols (upd cs))
C predicate = check cs
compileDelete :: Columns (Cols s a)
=> PPConfig -> Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])
compileDelete cfg tbl check = compDelete cfg (tableName tbl) predicate
where C predicate = check $ toTup $ map colName $ tableCols tbl
compQuery :: Result a => Scope -> Query s a -> (Int, SQL)
compQuery ns q =
(nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing False)
where
(cs, st) = runQueryM ns q
final = finalCols cs
sql = state2sql st
live = colNames final ++ allNonOutputColNames sql
srcs = removeDeadCols live sql
scopeSupply :: IORef Scope
scopeSupply = unsafePerformIO $ newIORef 1
compQueryWithFreshScope :: Result a => Query s a -> (Int, SQL)
compQueryWithFreshScope q = unsafePerformIO $ do
s <- atomicModifyIORef' scopeSupply (\s -> (s+1, s))
return $ compQuery s q
class Typeable (Res r) => Result r where
type Res r
toRes :: Proxy r -> [SqlValue] -> Res r
finalCols :: r -> [SomeCol SQL]
instance (SqlType a, Result b) => Result (Col s a :*: b) where
type Res (Col s a :*: b) = a :*: Res b
toRes _ (x:xs) = fromSql x :*: toRes (Proxy :: Proxy b) xs
toRes _ _ = error "backend bug: too few result columns to toRes"
finalCols (a :*: b) = finalCols a ++ finalCols b
instance SqlType a => Result (Col s a) where
type Res (Col s a) = a
toRes _ [x] = fromSql x
toRes _ [] = error "backend bug: too few result columns to toRes"
toRes _ _ = error "backend bug: too many result columns to toRes"
finalCols (C c) = [Some c]