module Database.Selda.Compile where
import Database.Selda.Column
import Database.Selda.Query.Type
import Database.Selda.SQL
import Database.Selda.SQL.Print
import Database.Selda.SqlType
import Database.Selda.Table
import Database.Selda.Table.Compile
import Database.Selda.Transform
import Database.Selda.Types
import Data.Maybe (catMaybes)
import Data.Proxy
import Data.Text (Text, empty)
import Data.Typeable
compile :: Result a => Query s a -> (Text, [Param])
compile = snd . compileWithTables
compileWithTables :: Result a => Query s a -> ([TableName], (Text, [Param]))
compileWithTables = compSql . snd . compQuery
compileInsert :: Insert a => Text -> Table a -> [a] -> (Text, [Param])
compileInsert _ _ [] = (empty, [])
compileInsert defkw tbl rows = (compInsert defkw tbl defs, catMaybes $ concat ps)
where ps = map params rows
defs = map (map (maybe True (const False))) ps
compileUpdate :: forall s a. (Columns (Cols s a), Result (Cols s a))
=> Table a
-> (Cols s a -> Cols s a)
-> (Cols s a -> Col s Bool)
-> (Text, [Param])
compileUpdate tbl upd check =
compUpdate (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)
=> Table a -> (Cols s a -> Col s Bool) -> (Text, [Param])
compileDelete tbl check = compDelete (tableName tbl) predicate
where C predicate = check $ toTup $ map colName $ tableCols tbl
compQuery :: Result a => Query s a -> (Int, SQL)
compQuery q =
(nameSupply st, SQL final (Product [srcs]) [] [] [] Nothing)
where
(cs, st) = runQueryM q
final = finalCols cs
sql = state2sql st
live = colNames final ++ allNonOutputColNames sql
srcs = removeDeadCols live sql
class Typeable (Res r) => Result r where
type Res r
toRes :: Proxy r -> [SqlValue] -> Res r
finalCols :: r -> [SomeCol]
instance (Typeable a, 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 (Typeable a, 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]