{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Tools to deal with templates and statements are defined here.
module PostgreSQL.Statement
  ( Template
  , code
  , identifier
  , string
  , param
  , paramWith
  , constant

  , Statement (..)
  , renderTemplate

  , PreparedStatement (..)

  , tpl
  , stmt
  )
where

import           Control.Applicative ((<|>))
import           Control.Monad (join)
import qualified Control.Monad.State.Strict as State
import qualified Crypto.Hash as Hash
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as ByteString.Char8
import           Data.Char (isAlphaNum)
import           Data.Foldable (asum, fold)
import           Data.Functor.Contravariant (Contravariant (..))
import qualified Data.Sequence as Sequence
import           Data.String (IsString (..))
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Text.Encoding (encodeUtf8)
import           Data.Traversable (for)
import           Data.Void (Void)
import           GHC.OverloadedLabels (IsLabel (..))
import           GHC.Records (HasField (..))
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as Quote
import           Numeric.Natural (Natural)
import qualified PostgreSQL.Param as Param
import           PostgreSQL.Types (Oid)
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char as Megaparsec.Char

data Segment a
  = Parameter (Param.Info (a -> Param.Value))
  | Code Text

instance Contravariant Segment where
  contramap :: (a -> b) -> Segment b -> Segment a
contramap a -> b
f = \case
    Parameter Info (b -> Value)
g -> Info (a -> Value) -> Segment a
forall a. Info (a -> Value) -> Segment a
Parameter (Info (a -> Value) -> Segment a) -> Info (a -> Value) -> Segment a
forall a b. (a -> b) -> a -> b
$ ((b -> Value) -> a -> Value)
-> Info (b -> Value) -> Info (a -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) Info (b -> Value)
g
    Code Text
text -> Text -> Segment a
forall a. Text -> Segment a
Code Text
text

  {-# INLINE contramap #-}

-- | SQL statement template
--
-- @since 0.0.0
newtype Template a = Template
  { Template a -> Seq (Segment a)
_unStatement :: Sequence.Seq (Segment a) }
  deriving newtype
    ( Semigroup -- ^ @since 0.0.0
    , Monoid -- ^ @since 0.0.0
    )

-- | @since 0.0.0
instance Contravariant Template where
  contramap :: (a -> b) -> Template b -> Template a
contramap a -> b
f (Template Seq (Segment b)
seqs) = Seq (Segment a) -> Template a
forall a. Seq (Segment a) -> Template a
Template ((Segment b -> Segment a) -> Seq (Segment b) -> Seq (Segment a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Segment b -> Segment a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f) Seq (Segment b)
seqs)

  {-# INLINE contramap #-}

-- | @OverloadedStrings@ helper for 'code'
--
-- > "my code" === code "my code"
--
-- @since 0.0.0
instance IsString (Template a) where
  fromString :: String -> Template a
fromString = Text -> Template a
forall a. Text -> Template a
code (Text -> Template a) -> (String -> Text) -> String -> Template a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

  {-# INLINE fromString #-}

-- | @OverloadedLabels@ helper for 'param'
--
-- > #myParam === param (getField @"myParam")
--
-- Use this with a database:
--
-- > data MyFoo = MyFoo { bar :: Int, baz :: String }
-- >
-- > myStatementTpl :: Template MyFoo
-- > myStatementTpl = "SELECT * FROM my_foo WHERE bar = " <> #bar <> " AND baz = " <> #baz
--
--
-- @since 0.0.0
instance (HasField n r a, Param.Param a) => IsLabel n (Template r) where
  fromLabel :: Template r
fromLabel = (r -> a) -> Template r
forall b a. Param b => (a -> b) -> Template a
param (HasField n r a => r -> a
forall k (x :: k) r a. HasField x r a => r -> a
getField @n @r @a)

  {-# INLINE fromLabel #-}

-- | Create a code-only statement.
--
-- @since 0.0.0
code :: Text -> Template a
code :: Text -> Template a
code = Seq (Segment a) -> Template a
forall a. Seq (Segment a) -> Template a
Template (Seq (Segment a) -> Template a)
-> (Text -> Seq (Segment a)) -> Text -> Template a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment a -> Seq (Segment a)
forall a. a -> Seq a
Sequence.singleton (Segment a -> Seq (Segment a))
-> (Text -> Segment a) -> Text -> Seq (Segment a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Segment a
forall a. Text -> Segment a
Code

{-# INLINE code #-}

-- | Create a code segment that mentions the given identifier (e.g. table or column name).
--
-- @since 0.0.0
identifier :: Text -> Template a
identifier :: Text -> Template a
identifier Text
name =
  Text -> Template a
forall a. Text -> Template a
code (Text -> Template a) -> Text -> Template a
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
"\"", Text
safeName, Text
"\""]
  where
    safeName :: Text
safeName = Text -> [Text] -> Text
Text.intercalate Text
"\"\"" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"') Text
name

{-# INLINE identifier #-}

-- | Encase the given string literal in single quotes. Single quotes in the literal are
-- automatically escaped.
--
-- @since 0.0.0
string :: Text -> Template a
string :: Text -> Template a
string Text
str = Template a
"'" Template a -> Template a -> Template a
forall a. Semigroup a => a -> a -> a
<> Text -> Template a
forall a. Text -> Template a
code (Text -> Text -> Text -> Text
Text.replace Text
"'" Text
"''" Text
str) Template a -> Template a -> Template a
forall a. Semigroup a => a -> a -> a
<> Template a
"'"

{-# INLINE string #-}

-- | Annotate the given statement with a type signature.
annotateParamType :: Maybe Text -> Template a -> Template a
annotateParamType :: Maybe Text -> Template a -> Template a
annotateParamType Maybe Text
typeAnnotation Template a
stmt =
  case Maybe Text
typeAnnotation of
    Just Text
paramType -> Template a
"(" Template a -> Template a -> Template a
forall a. Semigroup a => a -> a -> a
<> Template a
stmt Template a -> Template a -> Template a
forall a. Semigroup a => a -> a -> a
<> Text -> Template a
forall a. Text -> Template a
code (Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
paramType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
    Maybe Text
Nothing -> Template a
stmt

{-# INLINE annotateParamType #-}

-- | Reference a parameter.
--
-- @since 0.0.0
param :: forall b a. Param.Param b => (a -> b) -> Template a
param :: (a -> b) -> Template a
param a -> b
f = Info (a -> Value) -> Template a
forall a. Info (a -> Value) -> Template a
paramWith (Info (a -> Value) -> Template a)
-> Info (a -> Value) -> Template a
forall a b. (a -> b) -> a -> b
$ ((b -> Value) -> a -> Value)
-> Info (b -> Value) -> Info (a -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (Info (b -> Value) -> Info (a -> Value))
-> Info (b -> Value) -> Info (a -> Value)
forall a b. (a -> b) -> a -> b
$ Param b => Info (b -> Value)
forall a. Param a => Info (a -> Value)
Param.paramInfo @b

{-# INLINE param #-}

-- | Reference a parameter.
--
-- @since 0.0.0
paramWith :: Param.Info (a -> Param.Value) -> Template a
paramWith :: Info (a -> Value) -> Template a
paramWith Info (a -> Value)
info =
  Maybe Text -> Template a -> Template a
forall a. Maybe Text -> Template a -> Template a
annotateParamType (Info (a -> Value) -> Maybe Text
forall a. Info a -> Maybe Text
Param.info_typeName Info (a -> Value)
info) (Template a -> Template a) -> Template a -> Template a
forall a b. (a -> b) -> a -> b
$ Seq (Segment a) -> Template a
forall a. Seq (Segment a) -> Template a
Template (Seq (Segment a) -> Template a) -> Seq (Segment a) -> Template a
forall a b. (a -> b) -> a -> b
$ Segment a -> Seq (Segment a)
forall a. a -> Seq a
Sequence.singleton (Segment a -> Seq (Segment a)) -> Segment a -> Seq (Segment a)
forall a b. (a -> b) -> a -> b
$ Info (a -> Value) -> Segment a
forall a. Info (a -> Value) -> Segment a
Parameter Info (a -> Value)
info

{-# INLINE paramWith #-}

-- | Constant part of a query.
--
-- @since 0.0.0
constant :: forall b a. Param.Param b => b -> Template a
constant :: b -> Template a
constant b
x = Info (a -> Value) -> Template a
forall a. Info (a -> Value) -> Template a
paramWith (Info (a -> Value) -> Template a)
-> Info (a -> Value) -> Template a
forall a b. (a -> b) -> a -> b
$ ((b -> Value) -> a -> Value)
-> Info (b -> Value) -> Info (a -> Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> Value) -> (a -> b) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> b
forall a b. a -> b -> a
const b
x) (Info (b -> Value) -> Info (a -> Value))
-> Info (b -> Value) -> Info (a -> Value)
forall a b. (a -> b) -> a -> b
$ Param b => Info (b -> Value)
forall a. Param a => Info (a -> Value)
Param.paramInfo @b

{-# INLINE constant #-}

-- | Rendered SQL statement
--
-- @since 0.0.0
data Statement a = Statement
  { Statement a -> ByteString
statement_code :: ByteString
  , Statement a -> a -> [PackedParam]
statement_mkParams :: a -> [Param.PackedParam]
  , Statement a -> [Oid]
statement_types :: [Oid]
  , Statement a -> ByteString
statement_name :: ByteString
  }

-- | @since 0.0.0
instance Contravariant Statement where
  contramap :: (a -> b) -> Statement b -> Statement a
contramap a -> b
f Statement b
statement = Statement :: forall a.
ByteString
-> (a -> [PackedParam]) -> [Oid] -> ByteString -> Statement a
Statement
    { statement_code :: ByteString
statement_code = Statement b -> ByteString
forall a. Statement a -> ByteString
statement_code Statement b
statement
    , statement_mkParams :: a -> [PackedParam]
statement_mkParams = Statement b -> b -> [PackedParam]
forall a. Statement a -> a -> [PackedParam]
statement_mkParams Statement b
statement (b -> [PackedParam]) -> (a -> b) -> a -> [PackedParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
    , statement_types :: [Oid]
statement_types = Statement b -> [Oid]
forall a. Statement a -> [Oid]
statement_types Statement b
statement
    , statement_name :: ByteString
statement_name = Statement b -> ByteString
forall a. Statement a -> ByteString
statement_name Statement b
statement
    }

  {-# INLINE contramap #-}

-- | Render the SQL statement.
--
-- @since 0.0.0
renderTemplate :: Template a -> Statement a
renderTemplate :: Template a -> Statement a
renderTemplate (Template Seq (Segment a)
segments :: Template a) = Statement :: forall a.
ByteString
-> (a -> [PackedParam]) -> [Oid] -> ByteString -> Statement a
Statement
  { statement_code :: ByteString
statement_code = ByteString
codeBytes
  , statement_mkParams :: a -> [PackedParam]
statement_mkParams = a -> [PackedParam]
mkParams
  , statement_types :: [Oid]
statement_types = [Oid]
types
  , statement_name :: ByteString
statement_name = String -> ByteString
ByteString.Char8.pack (Digest SHA224 -> String
forall a. Show a => a -> String
show Digest SHA224
hash)
  }
  where
    code :: Text
    code :: Text
code = Seq Text -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Seq Text -> Text) -> Seq Text -> Text
forall a b. (a -> b) -> a -> b
$ (State Natural (Seq Text) -> Natural -> Seq Text)
-> Natural -> State Natural (Seq Text) -> Seq Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Natural (Seq Text) -> Natural -> Seq Text
forall s a. State s a -> s -> a
State.evalState (Natural
1 :: Natural) (State Natural (Seq Text) -> Seq Text)
-> State Natural (Seq Text) -> Seq Text
forall a b. (a -> b) -> a -> b
$ Seq (Segment a)
-> (Segment a -> StateT Natural Identity Text)
-> State Natural (Seq Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Seq (Segment a)
segments ((Segment a -> StateT Natural Identity Text)
 -> State Natural (Seq Text))
-> (Segment a -> StateT Natural Identity Text)
-> State Natural (Seq Text)
forall a b. (a -> b) -> a -> b
$ \case
      Parameter Info (a -> Value)
_ -> do
        Natural
index <- (Natural -> (Natural, Natural)) -> StateT Natural Identity Natural
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state ((Natural -> (Natural, Natural))
 -> StateT Natural Identity Natural)
-> (Natural -> (Natural, Natural))
-> StateT Natural Identity Natural
forall a b. (a -> b) -> a -> b
$ \Natural
i -> (Natural
i, Natural
i Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
        Text -> StateT Natural Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> StateT Natural Identity Text)
-> Text -> StateT Natural Identity Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
'$' Char -> String -> String
forall a. a -> [a] -> [a]
: Natural -> String
forall a. Show a => a -> String
show Natural
index

      Code Text
text ->
        Text -> StateT Natural Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
text

    codeBytes :: ByteString
    codeBytes :: ByteString
codeBytes = Text -> ByteString
encodeUtf8 Text
code

    mkParams :: a -> [Param.PackedParam]
    mkParams :: a -> [PackedParam]
mkParams a
input =
      (Segment a -> [PackedParam] -> [PackedParam])
-> [PackedParam] -> Seq (Segment a) -> [PackedParam]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\case
          Parameter Info (a -> Value)
info -> (Info Value -> PackedParam
Param.packParam (((a -> Value) -> Value) -> Info (a -> Value) -> Info Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Value) -> a -> Value
forall a b. (a -> b) -> a -> b
$ a
input) Info (a -> Value)
info) PackedParam -> [PackedParam] -> [PackedParam]
forall a. a -> [a] -> [a]
:)
          Code{} -> [PackedParam] -> [PackedParam]
forall a. a -> a
id
        )
        []
        Seq (Segment a)
segments

    types :: [Oid]
    types :: [Oid]
types =
      (Segment a -> [Oid] -> [Oid]) -> [Oid] -> Seq (Segment a) -> [Oid]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\case
          Parameter Info (a -> Value)
info -> (Type -> Oid
Param.typeOid (Info (a -> Value) -> Type
forall a. Info a -> Type
Param.info_type Info (a -> Value)
info) Oid -> [Oid] -> [Oid]
forall a. a -> [a] -> [a]
:)
          Code{} -> [Oid] -> [Oid]
forall a. a -> a
id
        )
        []
        Seq (Segment a)
segments

    hash :: Hash.Digest Hash.SHA224
    hash :: Digest SHA224
hash =
      Context SHA224 -> Digest SHA224
forall a. HashAlgorithm a => Context a -> Digest a
Hash.hashFinalize (Context SHA224 -> Digest SHA224)
-> Context SHA224 -> Digest SHA224
forall a b. (a -> b) -> a -> b
$ Context SHA224 -> [ByteString] -> Context SHA224
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
Hash.hashUpdates Context SHA224
forall a. HashAlgorithm a => Context a
Hash.hashInit ([ByteString] -> Context SHA224) -> [ByteString] -> Context SHA224
forall a b. (a -> b) -> a -> b
$
        ByteString
codeBytes ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (Oid -> ByteString) -> [Oid] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ByteString
ByteString.Char8.pack (String -> ByteString) -> (Oid -> String) -> Oid -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Oid -> String
forall a. Show a => a -> String
show) [Oid]
types

{-# INLINE renderTemplate #-}

---

-- | Prepared statement
--
-- @since 0.0.0
data PreparedStatement a = PreparedStatement
  { PreparedStatement a -> ByteString
preparedStatement_name :: ByteString
  , PreparedStatement a -> a -> [PackedParamPrepared]
preparedStatement_mkParams :: a -> [Param.PackedParamPrepared]
  }

-- | @since 0.0.0
instance Contravariant PreparedStatement where
  contramap :: (a -> b) -> PreparedStatement b -> PreparedStatement a
contramap a -> b
f PreparedStatement b
statement = PreparedStatement :: forall a.
ByteString -> (a -> [PackedParamPrepared]) -> PreparedStatement a
PreparedStatement
    { preparedStatement_name :: ByteString
preparedStatement_name = PreparedStatement b -> ByteString
forall a. PreparedStatement a -> ByteString
preparedStatement_name PreparedStatement b
statement
    , preparedStatement_mkParams :: a -> [PackedParamPrepared]
preparedStatement_mkParams = PreparedStatement b -> b -> [PackedParamPrepared]
forall a. PreparedStatement a -> a -> [PackedParamPrepared]
preparedStatement_mkParams PreparedStatement b
statement (b -> [PackedParamPrepared])
-> (a -> b) -> a -> [PackedParamPrepared]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
    }

---

parseName :: Megaparsec.Parsec Void String String
parseName :: Parsec Void String String
parseName =
  Maybe String
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P Maybe String
forall a. Maybe a
Nothing ((Token String -> Bool)
 -> ParsecT Void String Identity (Tokens String))
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall a b. (a -> b) -> a -> b
$ \Token String
c ->
    Char -> Bool
isAlphaNum Char
Token String
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem @[] Char
Token String
c String
"_'"

data QuoteSegment
  = QuoteCode String
  | QuoteParam String
  | QuoteSubst String

parseQuote :: Megaparsec.Parsec Void String (TH.Q TH.Exp)
parseQuote :: Parsec Void String (Q Exp)
parseQuote =
  [QuoteSegment] -> Q Exp
combine ([QuoteSegment] -> Q Exp)
-> ParsecT Void String Identity [QuoteSegment]
-> Parsec Void String (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity QuoteSegment
-> ParsecT Void String Identity [QuoteSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Megaparsec.many ([ParsecT Void String Identity QuoteSegment]
-> ParsecT Void String Identity QuoteSegment
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ParsecT Void String Identity QuoteSegment
nonSegment, ParsecT Void String Identity QuoteSegment
dollar, ParsecT Void String Identity QuoteSegment
interactive])
  where
    nonSegment :: ParsecT Void String Identity QuoteSegment
nonSegment = String -> QuoteSegment
QuoteCode (String -> QuoteSegment)
-> Parsec Void String String
-> ParsecT Void String Identity QuoteSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'$')

    dollar :: ParsecT Void String Identity QuoteSegment
dollar = String -> QuoteSegment
QuoteCode String
"$" QuoteSegment
-> ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity QuoteSegment
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Megaparsec.Char.string Tokens String
"$$"

    between :: Char -> m a -> Char -> m a
between Char
lhs m a
inner Char
rhs =
      m Char -> m Char -> m a -> m a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
Megaparsec.between (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.Char.char Char
Token s
lhs) (Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.Char.char Char
Token s
rhs) m a
inner

    interactive :: ParsecT Void String Identity QuoteSegment
interactive = do
      Char
_ <- Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Megaparsec.Char.char Char
Token String
'$'
      [ParsecT Void String Identity QuoteSegment]
-> ParsecT Void String Identity QuoteSegment
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ String -> QuoteSegment
QuoteSubst (String -> QuoteSegment)
-> Parsec Void String String
-> ParsecT Void String Identity QuoteSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char
-> Parsec Void String String -> Char -> Parsec Void String String
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char) =>
Char -> m a -> Char -> m a
between Char
'(' Parsec Void String String
parseName Char
')'
        , String -> QuoteSegment
QuoteParam (String -> QuoteSegment)
-> Parsec Void String String
-> ParsecT Void String Identity QuoteSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char
-> Parsec Void String String -> Char -> Parsec Void String String
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char) =>
Char -> m a -> Char -> m a
between Char
'{' Parsec Void String String
parseName Char
'}' Parsec Void String String
-> Parsec Void String String -> Parsec Void String String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void String String
parseName)
        ]

    combine :: [QuoteSegment] -> Q Exp
combine [QuoteSegment]
segments = do
      [Q Exp]
segments <- [QuoteSegment] -> (QuoteSegment -> Q (Q Exp)) -> Q [Q Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [QuoteSegment]
segments ((QuoteSegment -> Q (Q Exp)) -> Q [Q Exp])
-> (QuoteSegment -> Q (Q Exp)) -> Q [Q Exp]
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (Q Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Q Exp -> Q (Q Exp))
-> (QuoteSegment -> Q Exp) -> QuoteSegment -> Q (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        QuoteCode String
code ->
          [e| fromString $(TH.stringE code) |]

        QuoteParam String
paramCode ->
          String -> Q Exp
integrateAsParam String
paramCode

        QuoteSubst String
paramCode ->
          String -> Q Exp
integrateAsSubst String
paramCode

      [e| mconcat $(TH.listE segments) |]

integrateAsParam :: String -> TH.ExpQ
integrateAsParam :: String -> Q Exp
integrateAsParam String
paramCode =
  [e| PostgreSQL.Statement.param $(TH.varE (TH.mkName paramCode)) |]

integrateAsSubst :: String -> TH.ExpQ
integrateAsSubst :: String -> Q Exp
integrateAsSubst String
paramCode =
  Name -> Q Exp
TH.varE (String -> Name
TH.mkName String
paramCode)

tplQuoteExp :: String -> TH.Q TH.Exp
tplQuoteExp :: String -> Q Exp
tplQuoteExp String
contents = do
  Q (Q Exp) -> Q Exp
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q Exp) -> Q Exp) -> Q (Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (ParseErrorBundle String Void -> Q (Q Exp))
-> (Q Exp -> Q (Q Exp))
-> Either (ParseErrorBundle String Void) (Q Exp)
-> Q (Q Exp)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q (Q Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Q Exp))
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> Q (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty) Q Exp -> Q (Q Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String Void) (Q Exp) -> Q (Q Exp))
-> Either (ParseErrorBundle String Void) (Q Exp) -> Q (Q Exp)
forall a b. (a -> b) -> a -> b
$
    Parsec Void String (Q Exp)
-> String
-> String
-> Either (ParseErrorBundle String Void) (Q Exp)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse
      (Parsec Void String (Q Exp)
parseQuote Parsec Void String (Q Exp)
-> ParsecT Void String Identity () -> Parsec Void String (Q Exp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof)
      String
"(PostgreSQL.Statement.tpl quasi-quotation)"
      String
contents

-- | Produces a 'Template' expression.
--
-- Supports the same features as 'stmt'.
--
-- @since 0.0.0
tpl :: Quote.QuasiQuoter
tpl :: QuasiQuoter
tpl = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
Quote.QuasiQuoter
  { quoteExp :: String -> Q Exp
Quote.quoteExp = String -> Q Exp
tplQuoteExp
  , quotePat :: String -> Q Pat
Quote.quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"'tpl' cannot be used in a pattern"
  , quoteType :: String -> Q Type
Quote.quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"'tpl' cannot be used in a type"
  , quoteDec :: String -> Q [Dec]
Quote.quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"'tpl' cannot be used in a declaration"
  }

stmtQuoteExp :: String -> TH.Q TH.Exp
stmtQuoteExp :: String -> Q Exp
stmtQuoteExp String
contents = do
  Q Exp
stmt <- (ParseErrorBundle String Void -> Q (Q Exp))
-> (Q Exp -> Q (Q Exp))
-> Either (ParseErrorBundle String Void) (Q Exp)
-> Q (Q Exp)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q (Q Exp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Q Exp))
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> Q (Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty) Q Exp -> Q (Q Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String Void) (Q Exp) -> Q (Q Exp))
-> Either (ParseErrorBundle String Void) (Q Exp) -> Q (Q Exp)
forall a b. (a -> b) -> a -> b
$
    Parsec Void String (Q Exp)
-> String
-> String
-> Either (ParseErrorBundle String Void) (Q Exp)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.parse
      (Parsec Void String (Q Exp)
parseQuote Parsec Void String (Q Exp)
-> ParsecT Void String Identity () -> Parsec Void String (Q Exp)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof)
      String
"(PostgreSQL.Statement.stmt quasi-quotation)"
      String
contents
  [e| renderTemplate $stmt |]

-- | Produces a 'Statement' expression.
--
-- > [stmt| SELECT $param * 2 |]
--
-- Use @$$@ to render a single @$@.
--
-- == Parameters
--
-- Use @$param@ or @${param}@ to reference a query parameter.
--
-- @[stmt| ${x} |]@ is equivalent to @'param' x@.
--
-- == Substitutions
--
-- Use @$(substr)@ to embed another 'Template' where @substr :: 'Template' a@.
--
-- @[stmt| $(x) |]@ is equivalent to @x@.
--
-- == Examples
--
-- > data MyParams = MyParams { foo :: Int, bar :: Text }
-- >
-- > myStatement :: Statement MyParams
-- > myStatement = [stmt| SELECT baz FROM my_table WHERE foo > ${foo} AND bar = ${bar} |]
--
-- @since 0.0.0
stmt :: Quote.QuasiQuoter
stmt :: QuasiQuoter
stmt = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
Quote.QuasiQuoter
  { quoteExp :: String -> Q Exp
Quote.quoteExp = String -> Q Exp
stmtQuoteExp
  , quotePat :: String -> Q Pat
Quote.quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"'stmt' cannot be used in a pattern"
  , quoteType :: String -> Q Type
Quote.quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"'stmt' cannot be used in a type"
  , quoteDec :: String -> Q [Dec]
Quote.quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"'stmt' cannot be used in a declaration"
  }