{-# LANGUAGE OverloadedStrings, CPP #-}
module Database.Selda.Table.Compile where
import Database.Selda.Table.Type
( IndexMethod,
ColAttr(Indexed, Primary, Unique),
ColInfo(colFKs, colType, colName, colAttrs),
Table(Table, tableAttrs, tableName, tableCols),
isAutoPrimary )
import Database.Selda.Table.Validation ( validateOrThrow )
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List (foldl')
import Data.Text (Text, intercalate, pack)
import qualified Data.Text as Text
import Database.Selda.SQL ( Param )
import Database.Selda.SQL.Print.Config
( PPConfig(ppIndexMethodHook, ppTypeHook, ppColAttrsHook,
ppColAttrs, ppTypePK, ppType, ppAutoIncInsert) )
import Database.Selda.SqlType (SqlTypeRep(..))
import Database.Selda.Types
( TableName,
ColName,
modColName,
addColPrefix,
fromColName,
intercalateColNames,
fromTableName,
rawTableName )
data OnError = Fail | Ignore
deriving (OnError -> OnError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OnError -> OnError -> Bool
$c/= :: OnError -> OnError -> Bool
== :: OnError -> OnError -> Bool
$c== :: OnError -> OnError -> Bool
Eq, Eq OnError
OnError -> OnError -> Bool
OnError -> OnError -> Ordering
OnError -> OnError -> OnError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OnError -> OnError -> OnError
$cmin :: OnError -> OnError -> OnError
max :: OnError -> OnError -> OnError
$cmax :: OnError -> OnError -> OnError
>= :: OnError -> OnError -> Bool
$c>= :: OnError -> OnError -> Bool
> :: OnError -> OnError -> Bool
$c> :: OnError -> OnError -> Bool
<= :: OnError -> OnError -> Bool
$c<= :: OnError -> OnError -> Bool
< :: OnError -> OnError -> Bool
$c< :: OnError -> OnError -> Bool
compare :: OnError -> OnError -> Ordering
$ccompare :: OnError -> OnError -> Ordering
Ord, Int -> OnError -> ShowS
[OnError] -> ShowS
OnError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OnError] -> ShowS
$cshowList :: [OnError] -> ShowS
show :: OnError -> String
$cshow :: OnError -> String
showsPrec :: Int -> OnError -> ShowS
$cshowsPrec :: Int -> OnError -> ShowS
Show)
compileCreateTable :: PPConfig -> OnError -> Table a -> Text
compileCreateTable :: forall a. PPConfig -> OnError -> Table a -> Text
compileCreateTable PPConfig
cfg OnError
ifex Table a
tbl =
[ColInfo]
ensureValid seq :: forall a b. a -> b -> b
`seq` Text
createTable
where
createTable :: Text
createTable = forall a. Monoid a => [a] -> a
mconcat
[ Text
"CREATE TABLE ", forall {a}. IsString a => OnError -> a
ifNotExists OnError
ifex, TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table a
tbl), Text
"("
, Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (PPConfig -> ColInfo -> Text
compileTableCol PPConfig
cfg) (forall a. Table a -> [ColInfo]
tableCols Table a
tbl) forall a. [a] -> [a] -> [a]
++ [Text]
multiUniques forall a. [a] -> [a] -> [a]
++ [Text]
multiPrimary)
, case [(ColName, (Table (), ColName))]
allFKs of
[] -> Text
""
[(ColName, (Table (), ColName))]
_ -> Text
", " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " [Text]
compFKs
, Text
")"
]
multiPrimary :: [Text]
multiPrimary =
[ forall a. Monoid a => [a] -> a
mconcat [Text
"PRIMARY KEY(", Text -> [Text] -> Text
intercalate Text
", " ([Int] -> [Text]
colNames [Int]
ixs), Text
")"]
| ([Int]
ixs, ColAttr
Primary) <- forall a. Table a -> [([Int], ColAttr)]
tableAttrs Table a
tbl
]
multiUniques :: [Text]
multiUniques =
[ forall a. Monoid a => [a] -> a
mconcat [Text
"UNIQUE(", Text -> [Text] -> Text
intercalate Text
", " ([Int] -> [Text]
colNames [Int]
ixs), Text
")"]
| ([Int]
ixs, ColAttr
Unique) <- forall a. Table a -> [([Int], ColAttr)]
tableAttrs Table a
tbl
]
colNames :: [Int] -> [Text]
colNames [Int]
ixs = [ColName -> Text
fromColName (ColInfo -> ColName
colName (forall a. Table a -> [ColInfo]
tableCols Table a
tbl forall a. [a] -> Int -> a
!! Int
ix)) | Int
ix <- [Int]
ixs]
ifNotExists :: OnError -> a
ifNotExists OnError
Fail = a
""
ifNotExists OnError
Ignore = a
"IF NOT EXISTS "
allFKs :: [(ColName, (Table (), ColName))]
allFKs = [(ColInfo -> ColName
colName ColInfo
ci, (Table (), ColName)
fk) | ColInfo
ci <- forall a. Table a -> [ColInfo]
tableCols Table a
tbl, (Table (), ColName)
fk <- ColInfo -> [(Table (), ColName)]
colFKs ColInfo
ci]
compFKs :: [Text]
compFKs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ColName -> (Table (), ColName) -> Int -> Text
compileFK) [(ColName, (Table (), ColName))]
allFKs [Int
0..]
ensureValid :: [ColInfo]
ensureValid = TableName -> [ColInfo] -> [ColInfo]
validateOrThrow (forall a. Table a -> TableName
tableName Table a
tbl) (forall a. Table a -> [ColInfo]
tableCols Table a
tbl)
compileCreateIndexes :: PPConfig -> OnError -> Table a -> [Text]
compileCreateIndexes :: forall a. PPConfig -> OnError -> Table a -> [Text]
compileCreateIndexes PPConfig
cfg OnError
ifex Table a
tbl =
[ PPConfig
-> OnError -> TableName -> [ColName] -> Maybe IndexMethod -> Text
compileCreateIndex PPConfig
cfg OnError
ifex (forall a. Table a -> TableName
tableName Table a
tbl) (Int -> ColName
colNameOfIdx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
idxs) Maybe IndexMethod
mmethod
| ([Int]
idxs, Indexed Maybe IndexMethod
mmethod) <- forall a. Table a -> [([Int], ColAttr)]
tableAttrs Table a
tbl
]
where
idxMap :: IntMap ColName
idxMap :: IntMap ColName
idxMap = forall a. [(Int, a)] -> IntMap a
IntMap.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (ColInfo -> ColName
colName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Table a -> [ColInfo]
tableCols Table a
tbl))
colNameOfIdx :: Int -> ColName
colNameOfIdx :: Int -> ColName
colNameOfIdx Int
colIdx =
case forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
colIdx IntMap ColName
idxMap of
Maybe ColName
Nothing -> forall a. HasCallStack => String -> a
error String
"Impossible: Index has non-existant column-index."
Just ColName
name -> ColName
name
indexNameFor :: TableName -> [ColName] -> Text
indexNameFor :: TableName -> [ColName] -> Text
indexNameFor TableName
t [ColName]
cs =
let escUnderscore :: ColName -> ColName
escUnderscore ColName
c = ColName -> (Text -> Text) -> ColName
modColName ColName
c (Text -> Text -> Text -> Text
Text.replace Text
"_" Text
"__") in
let ixPrefix :: Text -> Text
ixPrefix Text
partial = Text
"ix" forall a. Semigroup a => a -> a -> a
<> TableName -> Text
rawTableName TableName
t forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
partial
in Text -> Text
ixPrefix (Text -> [ColName] -> Text
intercalateColNames Text
"_" (ColName -> ColName
escUnderscore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ColName]
cs))
compileCreateIndex :: PPConfig
-> OnError
-> TableName
-> [ColName]
-> Maybe IndexMethod
-> Text
compileCreateIndex :: PPConfig
-> OnError -> TableName -> [ColName] -> Maybe IndexMethod -> Text
compileCreateIndex PPConfig
cfg OnError
ifex TableName
tbl [ColName]
cols Maybe IndexMethod
mmethod = forall a. Monoid a => [a] -> a
mconcat
[ Text
"CREATE INDEX"
, if OnError
ifex forall a. Eq a => a -> a -> Bool
== OnError
Ignore then Text
" IF NOT EXISTS " else Text
" "
, TableName -> [ColName] -> Text
indexNameFor TableName
tbl [ColName]
cols, Text
" ON ", TableName -> Text
fromTableName TableName
tbl
, case Maybe IndexMethod
mmethod of
Just IndexMethod
method -> Text
" " forall a. Semigroup a => a -> a -> a
<> PPConfig -> IndexMethod -> Text
ppIndexMethodHook PPConfig
cfg IndexMethod
method
Maybe IndexMethod
Nothing -> Text
""
, Text
" (", Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
cols), Text
")"
]
compileFK :: ColName -> (Table (), ColName) -> Int -> Text
compileFK :: ColName -> (Table (), ColName) -> Int -> Text
compileFK ColName
col (Table TableName
ftbl [ColInfo]
_ Bool
_ [([Int], ColAttr)]
_, ColName
fcol) Int
n = forall a. Monoid a => [a] -> a
mconcat
[ Text
"CONSTRAINT ", Text
fkName, Text
" FOREIGN KEY (", ColName -> Text
fromColName ColName
col, Text
") "
, Text
"REFERENCES ", TableName -> Text
fromTableName TableName
ftbl, Text
"(", ColName -> Text
fromColName ColName
fcol, Text
")"
]
where
fkName :: Text
fkName = ColName -> Text
fromColName forall a b. (a -> b) -> a -> b
$ ColName -> Text -> ColName
addColPrefix ColName
col (Text
"fk" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Int
n) forall a. Semigroup a => a -> a -> a
<> Text
"_")
compileTableCol :: PPConfig -> ColInfo -> Text
compileTableCol :: PPConfig -> ColInfo -> Text
compileTableCol PPConfig
cfg ColInfo
ci = [Text] -> Text
Text.unwords
[ ColName -> Text
fromColName (ColInfo -> ColName
colName ColInfo
ci)
, Text
typeHook forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
colAttrsHook
]
where
typeHook :: Text
typeHook = PPConfig -> SqlTypeRep -> [ColAttr] -> (SqlTypeRep -> Text) -> Text
ppTypeHook PPConfig
cfg SqlTypeRep
cty [ColAttr]
attrs (PPConfig -> SqlTypeRep -> Text
ppType' PPConfig
cfg)
colAttrsHook :: Text
colAttrsHook = PPConfig -> SqlTypeRep -> [ColAttr] -> ([ColAttr] -> Text) -> Text
ppColAttrsHook PPConfig
cfg SqlTypeRep
cty [ColAttr]
attrs (PPConfig -> [ColAttr] -> Text
ppColAttrs PPConfig
cfg)
cty :: SqlTypeRep
cty = ColInfo -> SqlTypeRep
colType ColInfo
ci
attrs :: [ColAttr]
attrs = ColInfo -> [ColAttr]
colAttrs ColInfo
ci
ppType' :: PPConfig -> SqlTypeRep -> Text
ppType'
| SqlTypeRep
cty forall a. Eq a => a -> a -> Bool
== SqlTypeRep
TRowID Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ColAttr -> Bool
isAutoPrimary [ColAttr]
attrs = PPConfig -> SqlTypeRep -> Text
ppTypePK
| Bool
otherwise = PPConfig -> SqlTypeRep -> Text
ppType
compileDropTable :: OnError -> Table a -> Text
compileDropTable :: forall a. OnError -> Table a -> Text
compileDropTable OnError
Fail Table a
t =
[Text] -> Text
Text.unwords [Text
"DROP TABLE",TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table a
t)]
compileDropTable OnError
_ Table a
t =
[Text] -> Text
Text.unwords [Text
"DROP TABLE IF EXISTS",TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table a
t)]
compInsert :: PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert :: forall a.
PPConfig -> Table a -> [[Either Param Param]] -> (Text, [Param])
compInsert PPConfig
cfg Table a
tbl [[Either Param Param]]
defs =
(Text
query, [Param]
parameters)
where
colNames :: [ColName]
colNames = forall a b. (a -> b) -> [a] -> [b]
map ColInfo -> ColName
colName forall a b. (a -> b) -> a -> b
$ forall a. Table a -> [ColInfo]
tableCols Table a
tbl
values :: Text
values = Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
vals
([Text]
vals, [Param]
parameters) = Int
-> [[Either Param Param]]
-> [Text]
-> [[Param]]
-> ([Text], [Param])
mkRows Int
1 [[Either Param Param]]
defs [] []
query :: Text
query = [Text] -> Text
Text.unwords
[ Text
"INSERT INTO"
, TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table a
tbl)
, Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map ColName -> Text
fromColName [ColName]
colNames) forall a. Semigroup a => a -> a -> a
<> Text
")"
, Text
"VALUES"
, Text
values
]
mkRows :: Int
-> [[Either Param Param]]
-> [Text]
-> [[Param]]
-> ([Text], [Param])
mkRows Int
n ([Either Param Param]
ps:[[Either Param Param]]
pss) [Text]
rts [[Param]]
paramss =
case Int -> [Either Param Param] -> [ColInfo] -> (Int, [Text], [Param])
mkRow Int
n [Either Param Param]
ps (forall a. Table a -> [ColInfo]
tableCols Table a
tbl) of
(Int
n', [Text]
names, [Param]
params) -> Int
-> [[Either Param Param]]
-> [Text]
-> [[Param]]
-> ([Text], [Param])
mkRows Int
n' [[Either Param Param]]
pss (Text
rowTextforall a. a -> [a] -> [a]
:[Text]
rts) ([Param]
paramsforall a. a -> [a] -> [a]
:[[Param]]
paramss)
where rowText :: Text
rowText = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a. [a] -> [a]
reverse [Text]
names) forall a. Semigroup a => a -> a -> a
<> Text
")"
mkRows Int
_ [[Either Param Param]]
_ [Text]
rts [[Param]]
ps =
(forall a. [a] -> [a]
reverse [Text]
rts, forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Param]]
ps)
mkRow :: Int -> [Either Param Param] -> [ColInfo] -> (Int, [Text], [Param])
mkRow Int
n [Either Param Param]
ps [ColInfo]
names = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, [Text], [Param])
-> (Either Param Param, ColInfo) -> (Int, [Text], [Param])
mkCols (Int
n, [], []) (forall a b. [a] -> [b] -> [(a, b)]
zip [Either Param Param]
ps [ColInfo]
names)
mkCol :: Int -> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param])
mkCol :: Int
-> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param])
mkCol Int
n (Left Param
def) ColInfo
col [Param]
ps
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ColAttr -> Bool
isAutoPrimary (ColInfo -> [ColAttr]
colAttrs ColInfo
col) =
(Int
n, PPConfig -> Text
ppAutoIncInsert PPConfig
cfg, [Param]
ps)
| Bool
otherwise =
(Int
nforall a. Num a => a -> a -> a
+Int
1, String -> Text
pack (Char
'$'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Int
n), Param
defforall a. a -> [a] -> [a]
:[Param]
ps)
mkCol Int
n (Right Param
val) ColInfo
_ [Param]
ps =
(Int
nforall a. Num a => a -> a -> a
+Int
1, String -> Text
pack (Char
'$'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Int
n), Param
valforall a. a -> [a] -> [a]
:[Param]
ps)
mkCols :: (Int, [Text], [Param]) -> (Either Param Param, ColInfo) -> (Int, [Text], [Param])
mkCols :: (Int, [Text], [Param])
-> (Either Param Param, ColInfo) -> (Int, [Text], [Param])
mkCols (Int
n, [Text]
names, [Param]
params) (Either Param Param
param, ColInfo
col) =
case Int
-> Either Param Param -> ColInfo -> [Param] -> (Int, Text, [Param])
mkCol Int
n Either Param Param
param ColInfo
col [Param]
params of
(Int
n', Text
name, [Param]
params') -> (Int
n', Text
nameforall a. a -> [a] -> [a]
:[Text]
names, [Param]
params')