{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# 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.State.Strict
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
(Int -> SqlExpr -> ShowS)
-> (SqlExpr -> String) -> ([SqlExpr] -> ShowS) -> Show SqlExpr
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
(SqlExpr -> SqlExpr -> Bool)
-> (SqlExpr -> SqlExpr -> Bool) -> Eq SqlExpr
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
(Int -> SqlBuilderExp -> ShowS)
-> (SqlBuilderExp -> String)
-> ([SqlBuilderExp] -> ShowS)
-> Show SqlBuilderExp
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
(SqlBuilderExp -> SqlBuilderExp -> Bool)
-> (SqlBuilderExp -> SqlBuilderExp -> Bool) -> Eq SqlBuilderExp
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
(Int -> ParamEncoder -> ShowS)
-> (ParamEncoder -> String)
-> ([ParamEncoder] -> ShowS)
-> Show ParamEncoder
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
(ParamEncoder -> ParamEncoder -> Bool)
-> (ParamEncoder -> ParamEncoder -> Bool) -> Eq ParamEncoder
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
(Int -> SpliceBind -> ShowS)
-> (SpliceBind -> String)
-> ([SpliceBind] -> ShowS)
-> Show SpliceBind
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
(SpliceBind -> SpliceBind -> Bool)
-> (SpliceBind -> SpliceBind -> Bool) -> Eq SpliceBind
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
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
ident
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
dollarQuotes
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
cquoted
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
param
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
splice
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
comment
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
multilineComment
        Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
someSql
        Parser () -> Parser () -> Parser ()
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
      ParserState
st <- StateT ParserState (Parsec Void String) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      let next :: Int
next = ParserState -> Int
ps'nextUnique ParserState
st
          !nextnext :: Int
nextnext = Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      ParserState -> Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
st {ps'nextUnique :: Int
ps'nextUnique = Int
nextnext}
      Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
next

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

    appendEncoder :: ParamEncoder -> Parser ()
    appendEncoder :: ParamEncoder -> Parser ()
appendEncoder ParamEncoder
x = do
      ParserState
st <- StateT ParserState (Parsec Void String) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      ParserState -> Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParserState
st {ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder = ParserState -> [ParamEncoder] -> [ParamEncoder]
ps'paramEncoder ParserState
st ([ParamEncoder] -> [ParamEncoder])
-> ([ParamEncoder] -> [ParamEncoder])
-> [ParamEncoder]
-> [ParamEncoder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParamEncoder
x ParamEncoder -> [ParamEncoder] -> [ParamEncoder]
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 <- StateT ParserState (Parsec Void String) ParserState
forall s (m :: * -> *). MonadState s m => m s
get
      ParserState -> Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
        ParserState
st
          { ps'spliceBinds :: [SpliceBind] -> [SpliceBind]
ps'spliceBinds =
              ParserState -> [SpliceBind] -> [SpliceBind]
ps'spliceBinds ParserState
st
                ([SpliceBind] -> [SpliceBind])
-> ([SpliceBind] -> [SpliceBind]) -> [SpliceBind] -> [SpliceBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpliceBind :: Int -> Int -> Exp -> SpliceBind
SpliceBind {sbBuilder :: Int
sbBuilder = Int
exprVar, sbParamEncoder :: Int
sbParamEncoder = Int
paramVar, sbExp :: Exp
sbExp = Exp
x} SpliceBind -> [SpliceBind] -> [SpliceBind]
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
      String
_ <- 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
"--"
      StateT ParserState (Parsec Void String) String -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT ParserState (Parsec Void String) String -> Parser ())
-> StateT ParserState (Parsec Void String) 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
"comment") (Char -> Char -> Bool
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
_ <- 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 ()
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
multilineCommentEnd) Parser () -> Parser () -> Parser ()
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
"*/")

    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 <- 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)
            m () -> m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
            (m [a] -> m [a]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try m [a]
escapeParser m [a] -> ([a] -> m [a]) -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[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]
++)))
              m [a] -> m [a] -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Token s -> m (Token s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Token s
terminal m (Token s) -> [a] -> m [a]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [a] -> [a]
sofar [a]
content)
       in ([a] -> [a]) -> m [a]
loop [a] -> [a]
forall a. a -> a
id

    betwixt :: String -> [a] -> Token s -> Token s -> m [a] -> m [a]
betwixt String
name [a]
initial Token s
terminal Token s
escapeChar m [a]
escapeParser = do
      [a]
_ <- Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk [a]
Tokens s
initial
      String -> Token s -> Token s -> m [a] -> m [a]
forall e s (m :: * -> *) a.
(MonadParsec e s m, Tokens s ~ [a]) =>
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 <- String
-> String
-> Token String
-> Token String
-> StateT ParserState (Parsec Void String) String
-> StateT ParserState (Parsec Void String) String
forall (m :: * -> *) e s a.
(MonadParsec e s m, Tokens s ~ [a]) =>
String -> [a] -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"single quotes" 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 Tokens String
"''")
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Quote String
content)
      Parser ()
go

    cquoted :: Parser ()
cquoted = do
      String
content <- String
-> String
-> Token String
-> Token String
-> StateT ParserState (Parsec Void String) String
-> StateT ParserState (Parsec Void String) String
forall (m :: * -> *) e s a.
(MonadParsec e s m, Tokens s ~ [a]) =>
String -> [a] -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"C-style escape quote" String
"E'" Char
Token String
'\'' Char
Token String
'\\' do
        Char
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
'\\'
        Char
b <- StateT ParserState (Parsec Void String) Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
        String -> StateT ParserState (Parsec Void String) String
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 <- String
-> String
-> Token String
-> Token String
-> StateT ParserState (Parsec Void String) String
-> StateT ParserState (Parsec Void String) String
forall (m :: * -> *) e s a.
(MonadParsec e s m, Tokens s ~ [a]) =>
String -> [a] -> Token s -> Token s -> m [a] -> m [a]
betwixt String
"identifier" 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 Tokens String
"\"\"")
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Ident String
content)
      Parser ()
go

    dollarQuotes :: Parser ()
dollarQuotes = do
      Char
_ <- 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
'$'
      String
tag <- 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
"identifier") Char -> Bool
Token String -> Bool
isAlphaNum
      Char
_ <- 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
'$'
      let bonk :: ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk ShowS
sofar = do
            Parser () -> 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
            String
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") (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'$')
            (Parser ()
parseEndQuote Parser () -> ShowS -> StateT ParserState (Parsec Void String) ShowS
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ShowS
sofar ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++))) StateT ParserState (Parsec Void String) ShowS
-> StateT ParserState (Parsec Void String) ShowS
-> StateT ParserState (Parsec Void String) ShowS
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk (ShowS
sofar ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++))
          parseEndQuote :: Parser ()
parseEndQuote = do
            Char
_ <- 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
'$'
            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
tag
            StateT ParserState (Parsec Void String) Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT ParserState (Parsec Void String) Char -> Parser ())
-> StateT ParserState (Parsec Void String) Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ 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
'$'
      String
content <- (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"") (ShowS -> String)
-> StateT ParserState (Parsec Void String) ShowS
-> StateT ParserState (Parsec Void String) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShowS -> StateT ParserState (Parsec Void String) ShowS
bonk ShowS
forall a. a -> a
id
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> String -> SqlBuilderExp
Sbe'DollarQuote String
tag String
content)
      Parser ()
go

    param :: Parser ()
param = do
      String
_ <- 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
"#{"
      String
content <- 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
"parameter") (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
      Char
_ <- 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
'}'
      Exp
alpha <-
        case String -> Either String Exp
parseExp String
content of
          Left String
err -> String -> StateT ParserState (Parsec Void String) Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right Exp
x -> Exp -> StateT ParserState (Parsec Void String) Exp
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
      String
_ <- 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
"^{"
      String
content <- 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
"splice") (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
      Char
_ <- 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
'}'
      Exp
alpha <-
        case String -> Either String Exp
parseExp String
content of
          Left String
err -> String -> StateT ParserState (Parsec Void String) Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right Exp
x -> Exp -> StateT ParserState (Parsec Void String) Exp
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 ((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
      Char
s <- StateT ParserState (Parsec Void String) Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
      String
content <- 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
"sql") (\Token String
c -> Int -> IntSet -> Bool
IS.notMember (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
Token String
c) IntSet
breakCharsIS)
      SqlBuilderExp -> Parser ()
appendSqlBuilderExp (String -> SqlBuilderExp
Sbe'Sql (Char
s Char -> ShowS
forall a. a -> [a] -> [a]
: String
content))
      Parser ()
go

addParam :: State Int Builder
addParam :: State Int Builder
addParam = (Int -> (Builder, Int)) -> State Int Builder
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
  ParserState
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
  SqlExpr -> Either (ParseErrorBundle String Void) SqlExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    SqlExpr :: [SqlBuilderExp] -> [ParamEncoder] -> [SpliceBind] -> Int -> SqlExpr
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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 (m :: * -> *) a. MonadFail m => String -> m a
fail (ParseErrorBundle String Void -> String
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 = 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
  Array Int Name
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
newName String
"x")
  let spliceDecs :: [Dec]
spliceDecs =
        (SpliceBind -> Dec) -> [SpliceBind] -> [Dec]
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 '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
  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 (SqlBuilderExp -> Q Exp -> Q Exp)
-> Q Exp -> [SqlBuilderExp] -> Q Exp
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 (ParamEncoder -> Q Exp -> Q Exp)
-> Q Exp -> [ParamEncoder] -> Q Exp
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)|]
  Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure case [Dec]
spliceDecs of
    [] -> Exp
body
    [Dec]
_ -> [Dec] -> Exp -> Exp
LetE [Dec]
spliceDecs Exp
body