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)
import Database.Selda.Types
data OnError = Fail | Ignore
deriving (Eq, Ord, Show)
compileCreateTable :: (Text -> [ColAttr] -> Maybe Text) -> OnError -> Table a -> Text
compileCreateTable customColType ifex tbl = 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..]
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 :: (Text -> [ColAttr] -> Maybe Text) -> ColInfo -> Text
compileTableCol customColType ci = Text.unwords
[ fromColName (colName ci)
, case customColType typ attrs of
Just s -> s
_ -> typ <> " " <> Text.unwords (map compileColAttr attrs)
]
where
typ = colType ci
attrs = colAttrs ci
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 :: Text -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert defaultKeyword 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, defaultKeyword, 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')
compileColAttr :: ColAttr -> Text
compileColAttr Primary = "PRIMARY KEY"
compileColAttr AutoIncrement = "AUTOINCREMENT"
compileColAttr Required = "NOT NULL"
compileColAttr Optional = "NULL"
compileColAttr Unique = "UNIQUE"