{-# LANGUAGE OverloadedStrings, CPP #-}
-- | Generating SQL for creating and deleting tables.
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)

-- | Compile a sequence of queries to create the given table, including indexes.
--   The first query in the sequence is always @CREATE TABLE@.
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)

-- | Compile the @CREATE INDEX@ queries for all indexes on the given table.
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

-- | Get the name to use for an index on the given column(s) in the given table.
--
-- To ensure uniqueness
--
-- 1. Name multi-column indexes by connecting column names
--    with underscores.
-- 2. Escape underscores in column names.
--
-- Thus the index of columns @["foo","bar"]@ becomes @ixTable_foo_bar@ while
-- the index @["foo_bar"]@ receives an extra underscore to become
-- @ixTable_foo__bar@.
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))

-- | Compile a @CREATE INDEX@ query for the given index.
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
")"
  ]

-- | Compile a foreign key constraint.
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
"_")

-- | Compile a table column.
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

-- | Compile a @DROP TABLE@ query.
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)]

-- | Compile an @INSERT INTO@ query inserting @m@ rows with @n@ cols each.
--   Note that backends expect insertions to NOT have a semicolon at the end.
--   In addition to the compiled query, this function also returns the list of
--   parameters to be passed to the backend.
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
      ]

    -- Build all rows: just recurse over the list of defaults (which encodes
    -- the # of elements in total as well), building each row, keeping track
    -- of the next parameter identifier.
    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)

    -- Build a row: use the NULL/DEFAULT keyword for default rows, otherwise
    -- use a parameter.
    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)

    -- Build a column: default values only available for for auto-incrementing
    -- primary keys.
    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)

    -- Create a colum and return the next parameter id, plus the column itself.
    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')