{-# LANGUAGE OverloadedStrings #-}
module Database.Selda.Table.Compile where
import Database.Selda.Table
import Data.List ((\\), foldl')
import Data.Monoid
import Data.Text (Text, intercalate, pack)
import qualified Data.Text as Text
import Database.Selda.SQL hiding (params, param)
import Database.Selda.SQL.Print.Config
import Database.Selda.SqlType (SqlTypeRep(..))
import Database.Selda.Types
data OnError = Fail | Ignore
deriving (Eq, Ord, Show)
compileCreateTable :: PPConfig -> OnError -> Table a -> Text
compileCreateTable customColType ifex tbl = ensureValid `seq` mconcat
[ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("
, intercalate ", " (map (compileTableCol customColType) (tableCols tbl))
, case allFKs of
[] -> ""
_ -> ", " <> intercalate ", " compFKs
, ")"
]
where
ifNotExists Fail = ""
ifNotExists Ignore = "IF NOT EXISTS "
allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci]
compFKs = zipWith (uncurry compileFK) allFKs [0..]
ensureValid = validate (tableName tbl) (tableCols tbl)
compileFK :: ColName -> (Table (), ColName) -> Int -> Text
compileFK col (Table ftbl _ _, fcol) n = mconcat
[ "CONSTRAINT ", fkName, " FOREIGN KEY (", fromColName col, ") "
, "REFERENCES ", fromTableName ftbl, "(", fromColName fcol, ")"
]
where
fkName = fromColName $ addColPrefix col ("fk" <> pack (show n) <> "_")
compileTableCol :: PPConfig -> ColInfo -> Text
compileTableCol cfg ci = Text.unwords
[ fromColName (colName ci)
, typeHook <> " " <> colAttrsHook
]
where
typeHook = ppTypeHook cfg cty attrs (ppType' cfg)
colAttrsHook = ppColAttrsHook cfg cty attrs (ppColAttrs cfg)
cty = colType ci
attrs = colAttrs ci
ppType'
| cty == TRowID && [Primary, AutoIncrement] `areIn` attrs = ppTypePK
| otherwise = ppType
areIn x y = null (x \\ y)
compileDropTable :: OnError -> Table a -> Text
compileDropTable Fail t =
Text.unwords ["DROP TABLE",fromTableName (tableName t)]
compileDropTable _ t =
Text.unwords ["DROP TABLE IF EXISTS",fromTableName (tableName t)]
compInsert :: PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert cfg tbl defs =
(query, parameters)
where
colNames = map colName $ tableCols tbl
values = Text.intercalate ", " vals
(vals, parameters) = mkRows 1 defs [] []
query = Text.unwords
[ "INSERT INTO"
, fromTableName (tableName tbl)
, "(" <> Text.intercalate ", " (map fromColName colNames) <> ")"
, "VALUES"
, values
]
mkRows n (ps:pss) rts paramss =
case mkRow n ps (tableCols tbl) of
(n', names, params) -> mkRows n' pss (rowText:rts) (params:paramss)
where rowText = "(" <> Text.intercalate ", " (reverse names) <> ")"
mkRows _ _ rts ps =
(reverse rts, reverse $ concat ps)
mkRow n ps names = foldl' mkCols (n, [], []) (zip ps names)
mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param])
mkCol n (Left def) col ps
| AutoIncrement `elem` colAttrs col =
(n, ppAutoIncInsert cfg, ps)
| otherwise =
(n+1, pack ('$':show n), def:ps)
mkCol n (Right val) _ ps =
(n+1, pack ('$':show n), val:ps)
mkCols :: (Int, [Text], [Param]) -> (Either Param Param, ColInfo) -> (Int, [Text], [Param])
mkCols (n, names, params) (param, col) =
case mkCol n param col params of
(n', name, params') -> (n', name:names, params')