{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Hasql.Interpolate.Internal.TH
  ( sql,
    addParam,
    parseSqlExpr,
    compileSqlExpr,
    SqlExpr (..),
    SqlBuilderExp (..),
    ParamEncoder (..),
    SpliceBind (..),
  )
where

import Control.Applicative
import Control.Monad (replicateM)
import Control.Monad.State.Strict (State, StateT, execStateT, get, put, state)
import Data.Array (listArray, (!))
import Data.ByteString.Builder (Builder, stringUtf8)
import Data.Char
import Data.Functor
import Data.Functor.Contravariant
import qualified Data.IntSet as IS
import Data.Monoid (Ap (..))
import Data.Void
import qualified Hasql.Encoders as E
import Hasql.Interpolate.Internal.Encoder (EncodeField (..))
import Hasql.Interpolate.Internal.Sql
import Language.Haskell.Meta (parseExp)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Megaparsec
  ( ParseErrorBundle,
    Parsec,
    anySingle,
    chunk,
    eof,
    notFollowedBy,
    runParser,
    single,
    takeWhileP,
    try,
  )

data SqlExpr = SqlExpr
  { SqlExpr -> [SqlBuilderExp]
sqlBuilderExp :: [SqlBuilderExp],
    SqlExpr -> [ParamEncoder]
paramEncoder :: [ParamEncoder],
    SqlExpr -> [SpliceBind]
spliceBinds :: [SpliceBind],
    SqlExpr -> Int
bindCount :: Int
  }
  deriving stock (Int -> SqlExpr -> ShowS
[SqlExpr] -> ShowS
SqlExpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlExpr] -> ShowS
$cshowList :: [SqlExpr] -> ShowS
show :: SqlExpr -> String
$cshow :: SqlExpr -> String
showsPrec :: Int -> SqlExpr -> ShowS
$cshowsPrec :: Int -> SqlExpr -> ShowS
Show, SqlExpr -> SqlExpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlExpr -> SqlExpr -> Bool
$c/= :: SqlExpr -> SqlExpr -> Bool
== :: SqlExpr -> SqlExpr -> Bool
$c== :: SqlExpr -> SqlExpr -> Bool
Eq)

data SqlBuilderExp
  = Sbe'Var Int
  | Sbe'Param
  | Sbe'Quote String
  | Sbe'Ident String
  | Sbe'DollarQuote String String
  | Sbe'Cquote String
  | Sbe'Sql String
  deriving stock (Int -> SqlBuilderExp -> ShowS
[SqlBuilderExp] -> ShowS
SqlBuilderExp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SqlBuilderExp] -> ShowS
$cshowList :: [SqlBuilderExp] -> ShowS
show :: SqlBuilderExp -> String
$cshow :: SqlBuilderExp -> String
showsPrec :: Int -> SqlBuilderExp -> ShowS
$cshowsPrec :: Int -> SqlBuilderExp -> ShowS
Show, SqlBuilderExp -> SqlBuilderExp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SqlBuilderExp -> SqlBuilderExp -> Bool
$c/= :: SqlBuilderExp -> SqlBuilderExp -> Bool
== :: SqlBuilderExp -> SqlBuilderExp -> Bool
$c== :: SqlBuilderExp -> SqlBuilderExp -> Bool
Eq)

data ParamEncoder
  = Pe'Exp Exp
  | Pe'Var Int
  deriving stock (Int -> ParamEncoder -> ShowS
[ParamEncoder] -> ShowS
ParamEncoder -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParamEncoder] -> ShowS
$cshowList :: [ParamEncoder] -> ShowS
show :: ParamEncoder -> String
$cshow :: ParamEncoder -> String
showsPrec :: Int -> ParamEncoder -> ShowS
$cshowsPrec :: Int -> ParamEncoder -> ShowS
Show, ParamEncoder -> ParamEncoder -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParamEncoder -> ParamEncoder -> Bool
$c/= :: ParamEncoder -> ParamEncoder -> Bool
== :: ParamEncoder -> ParamEncoder -> Bool
$c== :: ParamEncoder -> ParamEncoder -> Bool
Eq)

data SpliceBind = SpliceBind
  { SpliceBind -> Int
sbBuilder :: Int,
    SpliceBind -> Int
sbParamEncoder :: Int,
    SpliceBind -> Exp
sbExp :: Exp
  }
  deriving stock (Int -> SpliceBind -> ShowS
[SpliceBind] -> ShowS
SpliceBind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpliceBind] -> ShowS
$cshowList :: [SpliceBind] -> ShowS
show :: SpliceBind -> String
$cshow :: SpliceBind -> String
showsPrec :: Int -> SpliceBind -> ShowS
$cshowsPrec :: Int -> SpliceBind -> ShowS
Show, SpliceBind -> SpliceBind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpliceBind -> SpliceBind -> Bool
$c/= :: SpliceBind -> SpliceBind -> Bool
== :: SpliceBind -> SpliceBind -> Bool
$c== :: SpliceBind -> SpliceBind -> Bool
Eq)

dollar :: Builder
dollar :: Builder
dollar = Builder
"$"

cquote :: Builder
cquote :: Builder
cquote = Builder
"E'"

sq :: Builder
sq :: Builder
sq = Builder
"'"

dq :: Builder
dq :: Builder
dq = Builder
"\""

data ParserState = ParserState
  { ParserState -> [SqlBuilderExp] -> [SqlBuilderExp]
ps'sqlBuilderExp :: [SqlBuilderExp] -> [SqlBuilderExp],
    ParserState -> [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder],
    ParserState -> [SpliceBind] -> [SpliceBind]
ps'spliceBinds :: [SpliceBind] -> [SpliceBind],
    ParserState -> Int
ps'nextUnique :: Int
  }

type Parser a = StateT (ParserState) (Parsec Void String) a

sqlExprParser :: Parser ()
sqlExprParser :: Parser ()
sqlExprParser = Parser ()
go
  where
    go :: Parser ()
go =
      Parser ()
quoted
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
ident
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
dollarQuotes
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
cquoted
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
param
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
splice
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
comment
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
multilineComment
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
someSql
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

    nextUnique :: Parser Int
    nextUnique :: Parser Int
nextUnique = do
      ParserState
st <- forall s (m :: * -> *). MonadState s m => m s
get
      let next :: Int
next = ParserState -> Int
ps'nextUnique ParserState
st
          !nextnext :: Int
nextnext = Int
next forall a. Num a => a -> a -> a
+ Int
1
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
st {ps'nextUnique :: Int
ps'nextUnique = Int
nextnext}
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
next

    appendSqlBuilderExp :: SqlBuilderExp -> Parser ()
    appendSqlBuilderExp :: SqlBuilderExp -> Parser ()
appendSqlBuilderExp SqlBuilderExp
x = do
      ParserState
st <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
st {ps'sqlBuilderExp :: [SqlBuilderExp] -> [SqlBuilderExp]
ps'sqlBuilderExp = ParserState -> [SqlBuilderExp] -> [SqlBuilderExp]
ps'sqlBuilderExp ParserState
st forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SqlBuilderExp
x forall a. a -> [a] -> [a]
:)}

    appendEncoder :: ParamEncoder -> Parser ()
    appendEncoder :: ParamEncoder -> Parser ()
appendEncoder ParamEncoder
x = do
      ParserState
st <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
st {ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder = ParserState -> [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder ParserState
st forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParamEncoder
x forall a. a -> [a] -> [a]
:)}

    addSpliceBinding :: Exp -> Parser ()
    addSpliceBinding :: Exp -> Parser ()
addSpliceBinding Exp
x = do
      Int
exprVar <- Parser Int
nextUnique
      Int
paramVar <- Parser Int
nextUnique
      ParserState
st <- forall s (m :: * -> *). MonadState s m => m s
get
      forall s (m :: * -> *). MonadState s m => s -> m ()
put
        ParserState
st
          { ps'spliceBinds :: [SpliceBind] -> [SpliceBind]
ps'spliceBinds =
              ParserState -> [SpliceBind] -> [SpliceBind]
ps'spliceBinds ParserState
st
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpliceBind {sbBuilder :: Int
sbBuilder = Int
exprVar, sbParamEncoder :: Int
sbParamEncoder = Int
paramVar, sbExp :: Exp
sbExp = Exp
x} forall a. a -> [a] -> [a]
:)
          }
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (Int -> SqlBuilderExp
Sbe'Var Int
exprVar)
      ParamEncoder -> Parser ()
appendEncoder (Int -> ParamEncoder
Pe'Var Int
paramVar)

    comment :: Parser ()
comment = do
      Tokens String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"--"
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"comment") (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
      Parser ()
go

    multilineComment :: Parser ()
multilineComment = do
      Parser ()
multilineCommentBegin
      Parser ()
go

    multilineCommentBegin :: Parser ()
multilineCommentBegin = do
      Tokens String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"/*"
      Parser ()
multilineCommentEnd

    multilineCommentEnd :: Parser ()
multilineCommentEnd = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"multiline comment") (\Token String
c -> Token String
c forall a. Eq a => a -> a -> Bool
/= Char
'*' Bool -> Bool -> Bool
&& Token String
c forall a. Eq a => a -> a -> Bool
/= Char
'/')
      (Parser ()
multilineCommentBegin forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
multilineCommentEnd) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"*/") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
multilineCommentEnd)

    escapedContent :: String -> Token s -> Token s -> m [a] -> m [a]
escapedContent String
name Token s
terminal Token s
escapeChar m [a]
escapeParser =
      let loop :: ([a] -> [a]) -> m [a]
loop [a] -> [a]
sofar = do
            [a]
content <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
name) (\Token s
c -> Token s
c forall a. Eq a => a -> a -> Bool
/= Token s
terminal Bool -> Bool -> Bool
&& Token s
c forall a. Eq a => a -> a -> Bool
/= Token s
escapeChar)
            forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
            (forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m [a]
escapeParser forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[a]
esc -> ([a] -> [a]) -> m [a]
loop ([a] -> [a]
sofar forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a]
content forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a]
esc forall a. [a] -> [a] -> [a]
++)))
              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Token s
terminal forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [a] -> [a]
sofar [a]
content)
       in ([a] -> [a]) -> m [a]
loop forall a. a -> a
id

    betwixt :: String -> Tokens s -> Token s -> Token s -> m [a] -> m [a]
betwixt String
name Tokens s
initial Token s
terminal Token s
escapeChar m [a]
escapeParser = do
      Tokens s
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
initial
      forall {s} {a} {e} {m :: * -> *}.
(Tokens s ~ [a], MonadParsec e s m) =>
String -> Token s -> Token s -> m [a] -> m [a]
escapedContent String
name Token s
terminal Token s
escapeChar m [a]
escapeParser

    quoted :: Parser ()
quoted = do
      String
content <- forall {s} {a} {m :: * -> *} {e}.
(Tokens s ~ [a], MonadParsec e s m) =>
String -> Tokens s -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"single quotes" Tokens String
"'" Char
'\'' Char
'\'' (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"''")
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Quote String
content)
      Parser ()
go

    cquoted :: Parser ()
cquoted = do
      String
content <- forall {s} {a} {m :: * -> *} {e}.
(Tokens s ~ [a], MonadParsec e s m) =>
String -> Tokens s -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"C-style escape quote" Tokens String
"E'" Char
'\'' Char
'\\' do
        Char
a <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\\'
        Char
b <- forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
a, Char
b]
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Cquote String
content)
      Parser ()
go

    ident :: Parser ()
ident = do
      String
content <- forall {s} {a} {m :: * -> *} {e}.
(Tokens s ~ [a], MonadParsec e s m) =>
String -> Tokens s -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"identifier" Tokens String
"\"" Char
'"' Char
'"' (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"\"\"")
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Ident String
content)
      Parser ()
go

    dollarQuotes :: Parser ()
dollarQuotes = do
      Token String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'$'
      String
tag <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"identifier") Char -> Bool
isAlphaNum
      Token String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'$'
      let bonk :: ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk ShowS
sofar = do
            forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
            String
c <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"dollar quoted content") (forall a. Eq a => a -> a -> Bool
/= Char
'$')
            (Parser ()
parseEndQuote forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ShowS
sofar forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c forall a. [a] -> [a] -> [a]
++))) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk (ShowS
sofar forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c forall a. [a] -> [a] -> [a]
++))
          parseEndQuote :: Parser ()
parseEndQuote = do
            Token String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'$'
            Tokens String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk String
tag
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'$'
      String
content <- (forall a b. (a -> b) -> a -> b
$ String
"") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk forall a. a -> a
id
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> String -> SqlBuilderExp
Sbe'DollarQuote String
tag String
content)
      Parser ()
go

    param :: Parser ()
param = do
      Tokens String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"#{"
      String
content <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"parameter") (forall a. Eq a => a -> a -> Bool
/= Char
'}')
      Token String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'}'
      Exp
alpha <-
        case String -> Either String Exp
parseExp String
content of
          Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right Exp
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
x
      ParamEncoder -> Parser ()
appendEncoder (Exp -> ParamEncoder
Pe'Exp Exp
alpha)
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp SqlBuilderExp
Sbe'Param
      Parser ()
go

    splice :: Parser ()
splice = do
      Tokens String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"^{"
      String
content <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"splice") (forall a. Eq a => a -> a -> Bool
/= Char
'}')
      Token String
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'}'
      Exp
alpha <-
        case String -> Either String Exp
parseExp String
content of
          Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right Exp
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
x
      Exp -> Parser ()
addSpliceBinding Exp
alpha
      Parser ()
go

    breakCharsIS :: IntSet
breakCharsIS = [Int] -> IntSet
IS.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => a -> Int
fromEnum String
breakChars)
    breakChars :: String
breakChars =
      [ Char
'\'',
        Char
'E',
        Char
'"',
        Char
'#',
        Char
'^',
        Char
'$',
        Char
'-',
        Char
'/'
      ]

    someSql :: Parser ()
someSql = do
      Char
s <- forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
      String
content <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"sql") (\Token String
c -> Int -> IntSet -> Bool
IS.notMember (forall a. Enum a => a -> Int
fromEnum Token String
c) IntSet
breakCharsIS)
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Sql (Char
s forall a. a -> [a] -> [a]
: String
content))
      Parser ()
go

addParam :: State Int Builder
addParam :: State Int Builder
addParam = forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state \Int
i ->
  let !i' :: Int
i' = Int
i forall a. Num a => a -> a -> a
+ Int
1
   in (Builder
dollar forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 (forall a. Show a => a -> String
show Int
i), Int
i')

parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr
parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr
parseSqlExpr String
str = do
  ParserState
ps <- forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Parser ()
sqlExprParser (([SqlBuilderExp] -> [SqlBuilderExp])
-> ([ParamEncoder] -> [ParamEncoder])
-> ([SpliceBind] -> [SpliceBind])
-> Int
-> ParserState
ParserState forall a. a -> a
id forall a. a -> a
id forall a. a -> a
id Int
0)) String
"" String
str
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    SqlExpr
      { sqlBuilderExp :: [SqlBuilderExp]
sqlBuilderExp = ParserState -> [SqlBuilderExp] -> [SqlBuilderExp]
ps'sqlBuilderExp ParserState
ps [],
        paramEncoder :: [ParamEncoder]
paramEncoder = ParserState -> [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder ParserState
ps [],
        spliceBinds :: [SpliceBind]
spliceBinds = ParserState -> [SpliceBind] -> [SpliceBind]
ps'spliceBinds ParserState
ps [],
        bindCount :: Int
bindCount = ParserState -> Int
ps'nextUnique ParserState
ps
      }

-- | QuasiQuoter that supports interpolation and splices. Produces a
-- 'Sql'.
--
-- @#{..}@ interpolates a haskell expression into a sql query.
--
-- @
-- example1 :: EncodeValue a => a -> Sql
-- example1 x = [sql| select \#{x} |]
-- @
--
-- @^{..}@ introduces a splice, which allows us to inject a sql
-- snippet along with the associated parameters into another sql
-- snippet.
--
-- @
-- example2 :: Sql
-- example2 = [sql| ^{example1 True} where true |]
-- @
sql :: QuasiQuoter
sql :: QuasiQuoter
sql =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = \String
str -> do
        case String -> Either (ParseErrorBundle String Void) SqlExpr
parseSqlExpr String
str of
          Left ParseErrorBundle String Void
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show ParseErrorBundle String Void
err)
          Right SqlExpr
sqlExpr -> SqlExpr -> Q Exp
compileSqlExpr SqlExpr
sqlExpr,
      quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => a
undefined,
      quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => a
undefined,
      quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => a
undefined
    }

compileSqlExpr :: SqlExpr -> Q Exp
compileSqlExpr :: SqlExpr -> Q Exp
compileSqlExpr (SqlExpr [SqlBuilderExp]
sqlBuilder [ParamEncoder]
enc [SpliceBind]
spliceBindings Int
bindCount) = do
  Array Int Name
nameArr <- forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
bindCount forall a. Num a => a -> a -> a
- Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
bindCount (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
  let spliceDecs :: [Dec]
spliceDecs =
        forall a b. (a -> b) -> [a] -> [b]
map
          ( \SpliceBind {Int
sbBuilder :: Int
sbBuilder :: SpliceBind -> Int
sbBuilder, Int
sbParamEncoder :: Int
sbParamEncoder :: SpliceBind -> Int
sbParamEncoder, Exp
sbExp :: Exp
sbExp :: SpliceBind -> Exp
sbExp} ->
              Pat -> Body -> [Dec] -> Dec
ValD (Name -> [Pat] -> Pat
conP_compat 'Sql (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Array Int Name
nameArr forall i e. Ix i => Array i e -> i -> e
! Int
sbBuilder, Array Int Name
nameArr forall i e. Ix i => Array i e -> i -> e
! Int
sbParamEncoder])) (Exp -> Body
NormalB Exp
sbExp) []
          )
          [SpliceBind]
spliceBindings
  Exp
sqlBuilderExp <-
    let go :: SqlBuilderExp -> Q Exp -> Q Exp
go SqlBuilderExp
a Q Exp
b = case SqlBuilderExp
a of
          Sbe'Var Int
i -> [e|Ap $(varE (nameArr ! i)) <> $b|]
          SqlBuilderExp
Sbe'Param -> [e|Ap addParam <> $b|]
          Sbe'Quote String
content -> [e|pure (sq <> stringUtf8 content <> sq) <> $b|]
          Sbe'Ident String
content -> [e|pure (dq <> stringUtf8 content <> dq) <> $b|]
          Sbe'DollarQuote String
tag String
content -> [e|pure (dollar <> stringUtf8 tag <> dollar <> stringUtf8 content <> dollar <> stringUtf8 tag <> dollar) <> $b|]
          Sbe'Cquote String
content -> [e|pure (cquote <> content <> sq) <> $b|]
          Sbe'Sql String
content -> [e|pure (stringUtf8 content) <> $b|]
     in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SqlBuilderExp -> Q Exp -> Q Exp
go [e|pure mempty|] [SqlBuilderExp]
sqlBuilder
  Exp
encExp <-
    let go :: ParamEncoder -> Q Exp -> Q Exp
go ParamEncoder
a Q Exp
b = case ParamEncoder
a of
          Pe'Exp Exp
x -> [e|$(pure x) >$ E.param encodeField <> $b|]
          Pe'Var Int
x -> [e|$(varE (nameArr ! x)) <> $b|]
     in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ParamEncoder -> Q Exp -> Q Exp
go [e|mempty|] [ParamEncoder]
enc
  Exp
body <- [e|Sql (getAp $(pure sqlBuilderExp)) $(pure encExp)|]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure case [Dec]
spliceDecs of
    [] -> Exp
body
    [Dec]
_ -> [Dec] -> Exp -> Exp
LetE [Dec]
spliceDecs Exp
body

-- In template-haskell-2.18.0.0, the ConP constructor grew a new [Type] field for matching with type applications.
conP_compat :: Name -> [Pat] -> Pat
#if MIN_VERSION_template_haskell(2,18,0)
conP_compat :: Name -> [Pat] -> Pat
conP_compat Name
name [Pat]
fields = Name -> [Type] -> [Pat] -> Pat
ConP Name
name [] [Pat]
fields
#else
conP_compat name fields = ConP name fields
#endif