Sql.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module defines the functions which are used only for backends creation.
module Database.Groundhog.Generic.Sql
  ( -- * SQL rendering utilities
    renderCond,
    defaultShowPrim,
    renderOrders,
    renderUpdates,
    renderFields,
    renderChain,
    renderExpr,
    renderExprPriority,
    renderExprExtended,
    renderPersistValue,
    mkExprWithConf,
    prerenderExpr,
    intercalateS,
    commasJoin,
    flatten,
    RenderS (..),
    Utf8 (..),
    fromUtf8,
    RenderConfig (..),
    StringLike (..),
    fromString,
    (<>),
    function,
    operator,
    parens,
    mkExpr,
    Snippet (..),
    SqlDb (..),
    FloatingSqlDb (..),
    tableName,
    mainTableName,
  )
where

import Data.Maybe (mapMaybe, maybeToList)
import Data.Semigroup (Semigroup (..))
import Data.String
import qualified Data.Text.Lazy.Builder as B
import Database.Groundhog.Core
import Database.Groundhog.Expression
import Database.Groundhog.Generic (isSimple)
import Database.Groundhog.Instances ()

class (Semigroup a, Monoid a, IsString a) => StringLike a where
  fromChar :: Char -> a

data RenderS db r = RenderS
  { getQuery :: Utf8,
    getValues :: [PersistValue] -> [PersistValue]
  }

instance StringLike Utf8 where
  fromChar = Utf8 . B.singleton

-- | Escape function, priority of the outer operator. The result is a list for the embedded data which may expand to several RenderS.
newtype Snippet db r = Snippet (RenderConfig -> Int -> [RenderS db r])

newtype RenderConfig = RenderConfig
  { esc :: Utf8 -> Utf8
  }

-- | This class distinguishes databases which support SQL-specific expressions. It contains ad hoc members for features whose syntax differs across the databases.
class (DbDescriptor db, QueryRaw db ~ Snippet db) => SqlDb db where
  append :: (ExpressionOf db r a String, ExpressionOf db r b String) => a -> b -> Expr db r String
  signum' :: (ExpressionOf db r x a, Num a) => x -> Expr db r a
  quotRem' :: (ExpressionOf db r x a, ExpressionOf db r y a, Integral a) => x -> y -> (Expr db r a, Expr db r a)

  equalsOperator :: RenderS db r -> RenderS db r -> RenderS db r
  notEqualsOperator :: RenderS db r -> RenderS db r -> RenderS db r

-- | This class distinguishes databases which support trigonometry and other math functions. For example, PostgreSQL has them but Sqlite does not. It contains ad hoc members for features whose syntax differs across the databases.
class SqlDb db => FloatingSqlDb db where
  -- | Natural logarithm
  log' :: (ExpressionOf db r x a, Floating a) => x -> Expr db r a

  logBase' :: (ExpressionOf db r b a, ExpressionOf db r x a, Floating a) => b -> x -> Expr db r a

-- | If we reuse complex expression several times, prerendering it saves time. `RenderConfig` can be obtained with `mkExprWithConf`
prerenderExpr :: forall db r a. (SqlDb db, PersistField a) => RenderConfig -> Expr db r a -> Expr db r a
prerenderExpr conf (Expr e) = Expr $ ExprRaw typ $ Snippet $ \_ _ -> prerendered
  where
    proxy = undefined :: proxy db
    typ = dbType proxy (undefined :: a)
    -- Priority of outer operation is not known. Assuming that it is high ensures that parentheses won't be missing.
    prerendered = renderExprExtended conf maxBound e

-- | Helps creating an expression which depends on render configuration. It can be used in pair with `prerenderExpr`.
-- @
-- myExpr x = mkExprWithConf $ \conf _ -> let
--        x' = prerenderExpr conf x
--     in x' + x' * x'@
-- @
mkExprWithConf :: (SqlDb db, PersistField a) => (RenderConfig -> Int -> Expr db r a) -> Expr db r a
mkExprWithConf f = expr
  where
    expr = mkExpr $ Snippet $ \conf p -> [renderExprPriority conf p $ toExpr $ f conf p `asTypeOf` expr]

renderExpr :: SqlDb db => RenderConfig -> UntypedExpr db r -> RenderS db r
renderExpr conf = renderExprPriority conf 0

renderExprPriority :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> RenderS db r
renderExprPriority conf p expr =
  case expr of
    ExprRaw _ (Snippet f) -> explicitHead (f conf p)
    ExprField f ->
      let fs = renderChain conf f []
       in RenderS (explicitHead fs) id
    ExprPure a ->
      let vals = toPurePersistValues a
       in renderPersistValue $ explicitHead (vals [])
    ExprCond a -> case renderCondPriority conf p a of
      Nothing -> error "renderExprPriority: empty condition"
      Just x -> x
  where
    explicitHead :: [a] -> a
    explicitHead xs = case xs of
      [x] -> x
      xs' -> error $ "renderExprPriority: expected one column field, found " ++ show (length xs')

renderExprExtended :: SqlDb db => RenderConfig -> Int -> UntypedExpr db r -> [RenderS db r]
renderExprExtended conf p expr =
  case expr of
    ExprRaw _ (Snippet f) -> f conf p
    ExprField f -> map (`RenderS` id) $ renderChain conf f []
    ExprPure a ->
      let vals = toPurePersistValues a []
       in map renderPersistValue vals
    ExprCond a -> maybeToList $ renderCondPriority conf p a

renderPersistValue :: PersistValue -> RenderS db r
renderPersistValue (PersistCustom s as) = RenderS s (as ++)
renderPersistValue a = RenderS (fromChar '?') (a :)

instance Semigroup (RenderS db r) where
  (RenderS f1 g1) <> (RenderS f2 g2) = RenderS (f1 <> f2) (g1 . g2)

instance Monoid (RenderS db r) where
  mempty = RenderS mempty id

#if !(MIN_VERSION_base(4,11,0))
  mappend = (<>)
#endif

instance IsString (RenderS db r) where
  fromString s = RenderS (fromString s) id

instance StringLike (RenderS db r) where
  fromChar c = RenderS (fromChar c) id

-- Has bad performance. This instance exists for testing purposes and migration
instance StringLike String where
  fromChar c = [c]

{-# INLINEABLE parens #-}
parens :: Int -> Int -> RenderS db r -> RenderS db r
parens p1 p2 expr = if p1 < p2 then fromChar '(' <> expr <> fromChar ')' else expr

operator :: (SqlDb db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r
operator pr op a b = Snippet $ \conf p ->
  [parens pr p $ renderExprPriority conf pr (toExpr a) <> fromString op <> renderExprPriority conf pr (toExpr b)]

function :: SqlDb db => String -> [UntypedExpr db r] -> Snippet db r
function func args = Snippet $ \conf _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr conf) args) <> fromChar ')']

mkExpr :: forall db r a. (SqlDb db, PersistField a) => Snippet db r -> Expr db r a
mkExpr snippet = Expr $ ExprRaw typ snippet
  where
    proxy = undefined :: proxy db
    typ = dbType proxy (undefined :: a)

{-# INLINEABLE renderCond #-}

-- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.
renderCond ::
  SqlDb db =>
  RenderConfig ->
  Cond db r ->
  Maybe (RenderS db r)
renderCond conf = renderCondPriority conf 0

flattenNullables :: DbType -> [Bool]
flattenNullables typ = go typ []
  where
    go :: DbType -> [Bool] -> [Bool]
    go t acc = case t of
      DbEmbedded (EmbeddedDef _ ts) _ -> foldr (go . snd) acc ts
      DbList _ _ -> False : acc
      DbTypePrimitive _ nullable _ _ -> nullable : acc

{-# INLINEABLE renderCondPriority #-}

-- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.
renderCondPriority ::
  forall db r.
  SqlDb db =>
  RenderConfig ->
  Int ->
  Cond db r ->
  Maybe (RenderS db r)
renderCondPriority conf@RenderConfig {..} priority cond = go cond priority
  where
    go (And a b) p = perhaps andP p " AND " a b
    go (Or a b) p = perhaps orP p " OR " a b
    go (Not CondEmpty) _ = Just "(1=0)" -- special case for False
    go (Not a) p = (\a' -> parens notP p $ "NOT " <> a') <$> go a notP
    go (Compare compOp f1 f2) p =
      case compOp of
        Eq -> renderCompOps andP " AND " 37 ops f1 f2
          where
            ops = map (\isNull -> if isNull then equalsOperator else (\a b -> a <> fromChar '=' <> b)) eitherNullable
        Ne -> renderCompOps andP " OR " 50 ops f1 f2
          where
            ops = map (\isNull -> if isNull then notEqualsOperator else (\a b -> a <> "<>" <> b)) eitherNullable
        Gt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '>' <> b) f1 f2
        Lt -> renderComp orP " OR " 38 (\a b -> a <> fromChar '<' <> b) f1 f2
        Ge -> renderComp orP " OR " 38 (\a b -> a <> ">=" <> b) f1 f2
        Le -> renderComp orP " OR " 38 (\a b -> a <> "<=" <> b) f1 f2
      where
        proxy = undefined :: proxy db

        eitherNullable = zipWith (||) (nullables f1) (nullables f2)

        nullables expr = case expr of
          ExprRaw t _ -> flattenNullables t
          ExprField ((_, t), _) -> flattenNullables t
          ExprPure a -> flattenNullables $ dbType proxy a
          ExprCond _ -> [False]

        renderZip opP op expr1 expr2 = zipWith op expr1' expr2'
          where
            expr1' = renderExprExtended conf opP expr1
            expr2' = renderExprExtended conf opP expr2

        renderZip3 opP ops expr1 expr2 = zipWith3 (\op e1 e2 -> op e1 e2) ops expr1' expr2'
          where
            expr1' = renderExprExtended conf opP expr1
            expr2' = renderExprExtended conf opP expr2

        groupComparisons interP interOp opP comparisons = case comparisons of
          [] -> Nothing
          [clause] -> Just $ parens (opP - 1) p clause -- put lower priority to make parentheses appear when the same operator is nested
          clauses -> Just $ parens interP p $ intercalateS interOp clauses

        renderComp interP interOp opP op expr1 expr2 = groupComparisons interP interOp opP $ renderZip opP op expr1 expr2
        renderCompOps interP interOp opP ops expr1 expr2 = groupComparisons interP interOp opP $ renderZip3 opP ops expr1 expr2
    go (CondRaw (Snippet f)) p = case f conf p of
      [] -> Nothing
      [a] -> Just a
      _ -> error "renderCond: cannot render CondRaw with many elements"
    go CondEmpty _ = Nothing

    notP = 35
    andP = 30
    orP = 20

    perhaps p pOuter op a b = result
      where
        -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority
        (p', result) = case (go a p', go b p') of
          (Just a', Just b') -> (p, Just $ parens p pOuter $ a' <> RenderS op id <> b')
          (Just a', Nothing) -> (pOuter, Just a')
          (Nothing, Just b') -> (pOuter, Just b')
          (Nothing, Nothing) -> (pOuter, Nothing)

{-
examples of prefixes
[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1"
[("val1", EmbeddedDef True _),  ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> ""
[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _),  ("val5", EmbeddedDef False _)] -> "val1"
[("val1", EmbeddedDef False _), ("val4", EmbeddedDef True _),  ("val5", EmbeddedDef True _)] -> "val1"
[("val1", EmbeddedDef False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1"
-}
{-# INLINEABLE renderChain #-}
renderChain :: RenderConfig -> FieldChain -> [Utf8] -> [Utf8]
renderChain RenderConfig {..} (f, prefix) acc =
  case prefix of
    ((name, EmbeddedDef False _) : fs) -> flattenP esc (Just $ goP (fromString name) fs) f acc
    _ -> flatten esc f acc
  where
    goP p ((name, EmbeddedDef False _) : fs) = goP (fromString name <> fromChar delim <> p) fs
    goP p _ = p

defaultShowPrim :: PersistValue -> String
defaultShowPrim (PersistString x) = "'" ++ x ++ "'"
defaultShowPrim (PersistText x) = "'" ++ show x ++ "'"
defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'"
defaultShowPrim (PersistInt64 x) = show x
defaultShowPrim (PersistDouble x) = show x
defaultShowPrim (PersistBool x) = if x then "1" else "0"
defaultShowPrim (PersistDay x) = show x
defaultShowPrim (PersistTimeOfDay x) = show x
defaultShowPrim (PersistUTCTime x) = show x
defaultShowPrim (PersistZonedTime x) = show x
defaultShowPrim PersistNull = "NULL"
defaultShowPrim (PersistCustom _ _) = error "Unexpected PersistCustom"

{-# INLINEABLE renderOrders #-}
renderOrders :: SqlDb db => RenderConfig -> [Order db r] -> RenderS db r
renderOrders _ [] = mempty
renderOrders conf xs = if null orders then mempty else " ORDER BY " <> commasJoin orders
  where
    orders = concatMap go xs
    rend conf' a = map (commasJoin . renderExprExtended conf' 0) $ projectionExprs a []
    go (Asc a) = rend conf a
    go (Desc a) = rend conf' a
      where
        conf' = conf {esc = \f -> esc conf f <> " DESC"}

{-# INLINEABLE renderFields #-}
-- Returns string with comma separated escaped fields like "name,age"
-- If there are other columns before renderFields result, do not put comma because the result might be an empty string. This happens when the fields have no columns like ().
-- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id", namedType (0 :: Int64)) : constrParams constr)
{-# SPECIALIZE renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8 #-}
renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s
renderFields escape = commasJoin . foldr (flatten escape) []

{-# SPECIALIZE flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}
flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])
flatten escape = flattenP escape Nothing

{-# SPECIALIZE flattenP :: (Utf8 -> Utf8) -> Maybe Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) #-}
flattenP :: StringLike s => (s -> s) -> Maybe s -> (String, DbType) -> ([s] -> [s])
flattenP escape prefix (fname, typ) acc = go typ
  where
    go typ' = case typ' of
      DbEmbedded emb _ -> handleEmb emb
      _ -> escape fullName : acc
    fullName = case prefix of
      Nothing -> fromString fname
      Just prefix' -> prefix' <> fromChar delim <> fromString fname
    handleEmb (EmbeddedDef False ts) = foldr (flattenP escape (Just fullName)) acc ts
    handleEmb (EmbeddedDef True ts) = foldr (flattenP escape Nothing) acc ts

commasJoin :: StringLike s => [s] -> s
commasJoin = intercalateS (fromChar ',')

{-# INLINEABLE intercalateS #-}
intercalateS :: StringLike s => s -> [s] -> s
intercalateS _ [] = mempty
intercalateS a (x : xs) = x <> go xs
  where
    go [] = mempty
    go (f : fs) = a <> f <> go fs

{-# INLINEABLE renderUpdates #-}
renderUpdates :: SqlDb db => RenderConfig -> [Update db r] -> Maybe (RenderS db r)
renderUpdates conf upds =
  case mapMaybe go upds of
    [] -> Nothing
    xs -> Just $ commasJoin xs
  where
    go (Update field expr) = guard $ commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs (rend expr)
      where
        rend = renderExprExtended conf 0
        fs = concatMap rend (projectionExprs field [])
        guard a = if null fs then Nothing else Just a

-- | Returns escaped table name optionally qualified with schema
{-# SPECIALIZE tableName :: (Utf8 -> Utf8) -> EntityDef -> ConstructorDef -> Utf8 #-}
tableName :: StringLike s => (s -> s) -> EntityDef -> ConstructorDef -> s
tableName esc e c = qualifySchema esc e tName
  where
    tName =
      esc $
        if isSimple (constructors e)
          then fromString $ entityName e
          else fromString (entityName e) <> fromChar delim <> fromString (constrName c)

-- | Returns escaped main table name optionally qualified with schema
{-# SPECIALIZE mainTableName :: (Utf8 -> Utf8) -> EntityDef -> Utf8 #-}
mainTableName :: StringLike s => (s -> s) -> EntityDef -> s
mainTableName esc e = qualifySchema esc e tName
  where
    tName = esc $ fromString $ entityName e

{-# SPECIALIZE qualifySchema :: (Utf8 -> Utf8) -> EntityDef -> Utf8 -> Utf8 #-}
qualifySchema :: StringLike s => (s -> s) -> EntityDef -> s -> s
qualifySchema esc e name = maybe name (\sch -> esc (fromString sch) <> fromChar '.' <> name) $ entitySchema e