{-# LANGUAGE OverloadedStrings, CPP #-}
module Database.Selda.Table.Compile where
import Database.Selda.Table
import Database.Selda.Table.Validation
import Data.List ((\\), foldl')
#if !MIN_VERSION_base(4, 11, 0)
import Data.Monoid
#endif
import Data.Text (Text, intercalate, pack)
import qualified Data.Text as Text
import Database.Selda.SQL hiding (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 cfg ifex tbl =
ensureValid `seq` (createTable : createIndexes)
where
createTable = mconcat
[ "CREATE TABLE ", ifNotExists ifex, fromTableName (tableName tbl), "("
, intercalate ", " (map (compileTableCol cfg) (tableCols tbl))
, case allFKs of
[] -> ""
_ -> ", " <> intercalate ", " compFKs
, ")"
]
createIndexes =
[ compileCreateIndex cfg (tableName tbl) (colName col) mmethod
| col <- tableCols tbl
, Indexed mmethod <- colAttrs col
]
ifNotExists Fail = ""
ifNotExists Ignore = "IF NOT EXISTS "
allFKs = [(colName ci, fk) | ci <- tableCols tbl, fk <- colFKs ci]
compFKs = zipWith (uncurry compileFK) allFKs [0..]
ensureValid = validateOrThrow (tableName tbl) (tableCols tbl)
compileCreateIndex :: PPConfig -> TableName -> ColName -> Maybe IndexMethod -> Text
compileCreateIndex cfg tbl col mmethod = mconcat
[ "CREATE INDEX "
, fromColName $ addColPrefix col ("ix" <> rawTableName tbl <> "_")
, " ON ", fromTableName tbl
, case mmethod of
Just method -> " " <> ppIndexMethodHook cfg method
_ -> ""
, " (", fromColName col, ")"
]
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')