{-# 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,
    errorBundlePretty,
    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
(Int -> SqlExpr -> ShowS)
-> (SqlExpr -> String) -> ([SqlExpr] -> ShowS) -> Show SqlExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SqlExpr -> ShowS
showsPrec :: Int -> SqlExpr -> ShowS
$cshow :: SqlExpr -> String
show :: SqlExpr -> String
$cshowList :: [SqlExpr] -> ShowS
showList :: [SqlExpr] -> ShowS
Show, SqlExpr -> SqlExpr -> Bool
(SqlExpr -> SqlExpr -> Bool)
-> (SqlExpr -> SqlExpr -> Bool) -> Eq SqlExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SqlExpr -> SqlExpr -> Bool
== :: SqlExpr -> SqlExpr -> Bool
$c/= :: SqlExpr -> SqlExpr -> Bool
/= :: 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
(Int -> SqlBuilderExp -> ShowS)
-> (SqlBuilderExp -> String)
-> ([SqlBuilderExp] -> ShowS)
-> Show SqlBuilderExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SqlBuilderExp -> ShowS
showsPrec :: Int -> SqlBuilderExp -> ShowS
$cshow :: SqlBuilderExp -> String
show :: SqlBuilderExp -> String
$cshowList :: [SqlBuilderExp] -> ShowS
showList :: [SqlBuilderExp] -> ShowS
Show, SqlBuilderExp -> SqlBuilderExp -> Bool
(SqlBuilderExp -> SqlBuilderExp -> Bool)
-> (SqlBuilderExp -> SqlBuilderExp -> Bool) -> Eq SqlBuilderExp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SqlBuilderExp -> SqlBuilderExp -> Bool
== :: SqlBuilderExp -> SqlBuilderExp -> Bool
$c/= :: SqlBuilderExp -> SqlBuilderExp -> Bool
/= :: SqlBuilderExp -> SqlBuilderExp -> Bool
Eq)

data ParamEncoder
  = Pe'Exp Exp
  | Pe'Var Int
  deriving stock (Int -> ParamEncoder -> ShowS
[ParamEncoder] -> ShowS
ParamEncoder -> String
(Int -> ParamEncoder -> ShowS)
-> (ParamEncoder -> String)
-> ([ParamEncoder] -> ShowS)
-> Show ParamEncoder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParamEncoder -> ShowS
showsPrec :: Int -> ParamEncoder -> ShowS
$cshow :: ParamEncoder -> String
show :: ParamEncoder -> String
$cshowList :: [ParamEncoder] -> ShowS
showList :: [ParamEncoder] -> ShowS
Show, ParamEncoder -> ParamEncoder -> Bool
(ParamEncoder -> ParamEncoder -> Bool)
-> (ParamEncoder -> ParamEncoder -> Bool) -> Eq ParamEncoder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParamEncoder -> ParamEncoder -> Bool
== :: ParamEncoder -> ParamEncoder -> Bool
$c/= :: ParamEncoder -> ParamEncoder -> Bool
/= :: 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
(Int -> SpliceBind -> ShowS)
-> (SpliceBind -> String)
-> ([SpliceBind] -> ShowS)
-> Show SpliceBind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpliceBind -> ShowS
showsPrec :: Int -> SpliceBind -> ShowS
$cshow :: SpliceBind -> String
show :: SpliceBind -> String
$cshowList :: [SpliceBind] -> ShowS
showList :: [SpliceBind] -> ShowS
Show, SpliceBind -> SpliceBind -> Bool
(SpliceBind -> SpliceBind -> Bool)
-> (SpliceBind -> SpliceBind -> Bool) -> Eq SpliceBind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpliceBind -> SpliceBind -> Bool
== :: SpliceBind -> SpliceBind -> Bool
$c/= :: SpliceBind -> SpliceBind -> Bool
/= :: 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
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
ident
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
dollarQuotes
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
cquoted
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
param
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
splice
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
comment
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
multilineComment
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
someSql
        Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

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

    appendSqlBuilderExp :: SqlBuilderExp -> Parser ()
    appendSqlBuilderExp :: SqlBuilderExp -> Parser ()
appendSqlBuilderExp SqlBuilderExp
x = do
      st <- StateT ParserState (Parsec Void String) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)}

    appendEncoder :: ParamEncoder -> Parser ()
    appendEncoder :: ParamEncoder -> Parser ()
appendEncoder ParamEncoder
x = do
      st <- StateT ParserState (Parsec Void String) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      put st {ps'paramEncoder = ps'paramEncoder st . (x :)}

    addSpliceBinding :: Exp -> Parser ()
    addSpliceBinding :: Exp -> Parser ()
addSpliceBinding Exp
x = do
      exprVar <- Parser Int
nextUnique
      paramVar <- nextUnique
      st <- get
      put
        st
          { ps'spliceBinds =
              ps'spliceBinds st
                . (SpliceBind {sbBuilder = exprVar, sbParamEncoder = paramVar, sbExp = x} :)
          }
      appendSqlBuilderExp (Sbe'Var exprVar)
      appendEncoder (Pe'Var paramVar)

    comment :: Parser ()
comment = do
      _ <- Tokens String
-> StateT ParserState (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"--"
      void $ takeWhileP (Just "comment") (/= '\n')
      go

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

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

    multilineCommentEnd :: Parser ()
multilineCommentEnd = do
      StateT ParserState (Parsec Void String) (Tokens String)
-> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT ParserState (Parsec Void String) (Tokens String)
 -> Parser ())
-> StateT ParserState (Parsec Void String) (Tokens String)
-> Parser ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token String -> Bool)
-> StateT ParserState (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"multiline comment") (\Token String
c -> Char
Token String
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*' Bool -> Bool -> Bool
&& Char
Token String
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')
      (Parser ()
multilineCommentBegin Parser () -> Parser () -> Parser ()
forall a b.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) b
-> StateT ParserState (Parsec Void String) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
multilineCommentEnd) Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StateT ParserState (Parsec Void String) (Tokens String)
-> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens String
-> StateT ParserState (Parsec Void String) (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens String
"*/") Parser () -> Parser () -> Parser ()
forall a.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StateT ParserState (Parsec Void String) (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle StateT ParserState (Parsec Void String) (Token String)
-> Parser () -> Parser ()
forall a b.
StateT ParserState (Parsec Void String) a
-> StateT ParserState (Parsec Void String) b
-> StateT ParserState (Parsec Void String) b
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
            content <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
name) (\Token s
c -> Token s
c Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
/= Token s
terminal Bool -> Bool -> Bool
&& Token s
c Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
/= Token s
escapeChar)
            notFollowedBy eof
            (try escapeParser >>= \[a]
esc -> ([a] -> [a]) -> m [a]
loop ([a] -> [a]
sofar ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a]
content [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a]
esc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++)))
              <|> (single terminal $> sofar content)
       in ([a] -> [a]) -> m [a]
loop [a] -> [a]
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 -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
initial
      escapedContent name terminal escapeChar escapeParser

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

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

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

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

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

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

    breakCharsIS :: IntSet
breakCharsIS = [Int] -> IntSet
IS.fromList ((Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
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
      s <- StateT ParserState (Parsec Void String) Char
StateT ParserState (Parsec Void String) (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
      content <- takeWhileP (Just "sql") (\Token String
c -> Int -> IntSet -> Bool
IS.notMember (Token String -> Int
forall a. Enum a => a -> Int
fromEnum Token String
c) IntSet
breakCharsIS)
      appendSqlBuilderExp (Sbe'Sql (s : content))
      go

addParam :: State Int Builder
addParam :: State Int Builder
addParam = (Int -> (Builder, Int)) -> State Int Builder
forall a. (Int -> (a, Int)) -> StateT Int Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state \Int
i ->
  let !i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
   in (Builder
dollar Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 (Int -> String
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
  ps <- Parsec Void String ParserState
-> String
-> String
-> Either (ParseErrorBundle String Void) ParserState
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parser () -> ParserState -> Parsec Void String ParserState
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 [SqlBuilderExp] -> [SqlBuilderExp]
forall a. a -> a
id [ParamEncoder] -> [ParamEncoder]
forall a. a -> a
id [SpliceBind] -> [SpliceBind]
forall a. a -> a
id Int
0)) String
"" String
str
  pure
    SqlExpr
      { sqlBuilderExp = ps'sqlBuilderExp ps [],
        paramEncoder = ps'paramEncoder ps [],
        spliceBinds = ps'spliceBinds ps [],
        bindCount = ps'nextUnique 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 -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err)
          Right SqlExpr
sqlExpr -> SqlExpr -> Q Exp
compileSqlExpr SqlExpr
sqlExpr,
      quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined,
      quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined,
      quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
    }

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