{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Internal to the arbiter packages. Not covered by the PVP.
--
-- A SQL query bundling its text, its positional parameters, and its row
-- decoder in one value. The text is a list of literals and parameter holes, rendered
-- in the placeholder form each backend needs. Built by the @sql@
-- quasiquoter in "Arbiter.Core.Sql.QQ". The parameters and decoder use the
-- same t'Arbiter.Core.Codec.Col'-driven vocabulary as the profunctor codec in
-- "Arbiter.Core.Codec".
module Arbiter.Core.Sql.Query
  ( Query (..)
  , mkQuery
  , raw
  , param
  , rows
  , rawRows
  , sepBy
  , mwhen
  , Piece (..)
  , ToFragment (..)
  ) where

import Data.List (intercalate, mapAccumL)
import Data.Text (Text)
import Data.Text qualified as T

import Arbiter.Core.Codec (Params, RowCodec, SomeParam)
import Arbiter.Core.Enum (showText)

-- | One run of literal SQL or one parameter hole.
data Piece
  = -- | Literal SQL text.
    Lit !Text
  | -- | A parameter hole.
    Hole
  deriving stock (Piece -> Piece -> Bool
(Piece -> Piece -> Bool) -> (Piece -> Piece -> Bool) -> Eq Piece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Piece -> Piece -> Bool
== :: Piece -> Piece -> Bool
$c/= :: Piece -> Piece -> Bool
/= :: Piece -> Piece -> Bool
Eq, Int -> Piece -> ShowS
[Piece] -> ShowS
Piece -> String
(Int -> Piece -> ShowS)
-> (Piece -> String) -> ([Piece] -> ShowS) -> Show Piece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Piece -> ShowS
showsPrec :: Int -> Piece -> ShowS
$cshow :: Piece -> String
show :: Piece -> String
$cshowList :: [Piece] -> ShowS
showList :: [Piece] -> ShowS
Show)

-- | A parameterized query paired with the decoder for its result rows.
data Query a = Query
  { forall a. Query a -> [Piece]
qPieces :: [Piece]
  -- ^ The text as literals and holes, one hole per entry of 'qParams'.
  , forall a. Query a -> Params
qParams :: Params
  -- ^ Positional parameters, in hole order.
  , forall a. Query a -> Text
qSql :: Text
  -- ^ The text with @?@ placeholders.
  , forall a. Query a -> Text
qPositional :: Text
  -- ^ The text with @$n@ placeholders.
  , forall a. Query a -> RowCodec a
qDecode :: RowCodec a
  -- ^ Decoder for the result rows.
  }
  deriving stock ((forall a b. (a -> b) -> Query a -> Query b)
-> (forall a b. a -> Query b -> Query a) -> Functor Query
forall a b. a -> Query b -> Query a
forall a b. (a -> b) -> Query a -> Query b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Query a -> Query b
fmap :: forall a b. (a -> b) -> Query a -> Query b
$c<$ :: forall a b. a -> Query b -> Query a
<$ :: forall a b. a -> Query b -> Query a
Functor)

-- | A query from its pieces, parameters and decoder.
mkQuery :: [Piece] -> Params -> RowCodec a -> Query a
mkQuery :: forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery [Piece]
pieces Params
params RowCodec a
decode =
  Query
    { qPieces :: [Piece]
qPieces = [Piece]
pieces
    , qParams :: Params
qParams = Params
params
    , qSql :: Text
qSql = (Int -> Text) -> [Piece] -> Text
render (Text -> Int -> Text
forall a b. a -> b -> a
const Text
"?") [Piece]
pieces
    , qPositional :: Text
qPositional = (Int -> Text) -> [Piece] -> Text
render Int -> Text
forall {a}. Show a => a -> Text
positional [Piece]
pieces
    , qDecode :: RowCodec a
qDecode = RowCodec a
decode
    }
  where
    positional :: a -> Text
positional a
index = Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall {a}. Show a => a -> Text
showText a
index

-- | Render the pieces, numbering the holes from one.
render :: (Int -> Text) -> [Piece] -> Text
render :: (Int -> Text) -> [Piece] -> Text
render Int -> Text
hole = [Text] -> Text
T.concat ([Text] -> Text) -> ([Piece] -> [Text]) -> [Piece] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Text]) -> [Text]
forall a b. (a, b) -> b
snd ((Int, [Text]) -> [Text])
-> ([Piece] -> (Int, [Text])) -> [Piece] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Piece -> (Int, Text)) -> Int -> [Piece] -> (Int, [Text])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> Piece -> (Int, Text)
step Int
1
  where
    step :: Int -> Piece -> (Int, Text)
step !Int
index (Lit Text
literal) = (Int
index, Text
literal)
    step !Int
index Piece
Hole = (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Text
hole Int
index)

-- | Concatenation is defined for @Query ()@, a fragment with text and parameters and no output columns.
instance Semigroup (Query ()) where
  Query ()
query1 <> :: Query () -> Query () -> Query ()
<> Query ()
query2 = [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery (Query () -> [Piece]
forall a. Query a -> [Piece]
qPieces Query ()
query1 [Piece] -> [Piece] -> [Piece]
forall a. Semigroup a => a -> a -> a
<> Query () -> [Piece]
forall a. Query a -> [Piece]
qPieces Query ()
query2) (Query () -> Params
forall a. Query a -> Params
qParams Query ()
query1 Params -> Params -> Params
forall a. Semigroup a => a -> a -> a
<> Query () -> Params
forall a. Query a -> Params
qParams Query ()
query2) (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

instance Monoid (Query ()) where
  mempty :: Query ()
mempty = [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery [] [] (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  mconcat :: [Query ()] -> Query ()
mconcat [Query ()]
queries = [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery ((Query () -> [Piece]) -> [Query ()] -> [Piece]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Query () -> [Piece]
forall a. Query a -> [Piece]
qPieces [Query ()]
queries) ((Query () -> Params) -> [Query ()] -> Params
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Query () -> Params
forall a. Query a -> Params
qParams [Query ()]
queries) (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Literal SQL with no parameters (table names, static clauses).
raw :: Text -> Query ()
raw :: Text -> Query ()
raw Text
literal = [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery [Text -> Piece
Lit Text
literal] [] (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | One hole bound to a single parameter.
param :: SomeParam -> Query ()
param :: SomeParam -> Query ()
param SomeParam
value = [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery [Piece
Hole] [SomeParam
value] (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Attach a handwritten row decoder to a parameterized fragment.
rows :: RowCodec a -> Query () -> Query a
rows :: forall a. RowCodec a -> Query () -> Query a
rows RowCodec a
decoder Query ()
query = Query ()
query {qDecode = decoder}

-- | Attach a decoder to literal, parameter-free SQL rendered as plain 'Text'.
rawRows :: RowCodec a -> Text -> Query a
rawRows :: forall a. RowCodec a -> Text -> Query a
rawRows RowCodec a
decoder = RowCodec a -> Query () -> Query a
forall a. RowCodec a -> Query () -> Query a
rows RowCodec a
decoder (Query () -> Query a) -> (Text -> Query ()) -> Text -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query ()
raw

-- | Join fragments with a separator, concatenating their text and parameters
-- in order.
sepBy :: Text -> [Query ()] -> Query ()
sepBy :: Text -> [Query ()] -> Query ()
sepBy Text
sep [Query ()]
queries =
  [Piece] -> Params -> RowCodec () -> Query ()
forall a. [Piece] -> Params -> RowCodec a -> Query a
mkQuery
    ([Piece] -> [[Piece]] -> [Piece]
forall a. [a] -> [[a]] -> [a]
intercalate [Text -> Piece
Lit Text
sep] ((Query () -> [Piece]) -> [Query ()] -> [[Piece]]
forall a b. (a -> b) -> [a] -> [b]
map Query () -> [Piece]
forall a. Query a -> [Piece]
qPieces [Query ()]
queries))
    ((Query () -> Params) -> [Query ()] -> Params
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Query () -> Params
forall a. Query a -> Params
qParams [Query ()]
queries)
    (() -> RowCodec ()
forall a. a -> Ap NullCol a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | The fragment under a true flag. @mempty@ under a false one.
mwhen :: (Monoid m) => Bool -> m -> m
mwhen :: forall m. Monoid m => Bool -> m -> m
mwhen Bool
True m
fragment = m
fragment
mwhen Bool
False m
_ = m
forall a. Monoid a => a
mempty

-- | Values a @${...}@ splice accepts: raw 'Text' (a bare clause or table name)
-- or a 'Query' fragment (whose parameters interleave at the splice site).
class ToFragment a where
  -- | The value as a fragment.
  toFragment :: a -> Query ()

instance ToFragment Text where
  toFragment :: Text -> Query ()
toFragment = Text -> Query ()
raw

instance ToFragment (Query ()) where
  toFragment :: Query () -> Query ()
toFragment = Query () -> Query ()
forall a. a -> a
id