{-# 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 #-}
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 #-}
newtype Template a = Template
{ Template a -> Seq (Segment a)
_unStatement :: Sequence.Seq (Segment a) }
deriving newtype
( Semigroup
, Monoid
)
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 :: 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 #-}
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
}
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 #-}
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 #-}
data PreparedStatement a = PreparedStatement
{ PreparedStatement a -> ByteString
preparedStatement_name :: ByteString
, PreparedStatement a -> a -> [PackedParamPrepared]
preparedStatement_mkParams :: a -> [Param.PackedParamPrepared]
}
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
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 |]
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"
}