module Database.PostgreSQL.Query.TH.SqlExp
       ( -- * QQ
         sqlExp
         -- * Types
       , Rope(..)
         -- * Parser
       , ropeParser
       , parseRope
       , squashRope
         -- * Template haskell
       , sqlQExp
       , sqlExpEmbed
       , sqlExpFile
       ) where

import Prelude hiding (takeWhile)

import Data.Attoparsec.Combinator
import Data.Attoparsec.Text
import Data.Char ( isSpace )
import Data.FileEmbed ( bsToExp )
import Database.PostgreSQL.Query.Import
import Database.PostgreSQL.Query.SqlBuilder
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

#if MIN_VERSION_haskell_src_meta(0,8,0)
import Language.Haskell.Meta.Parse
#else
import Language.Haskell.Meta.Parse.Careful
#endif

import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

{- $setup
>>> import Database.PostgreSQL.Simple
>>> import Database.PostgreSQL.Simple.Types
>>> import Database.PostgreSQL.Query.SqlBuilder
>>> import Data.Text ( Text )
>>> import qualified Data.List as L
>>> import Database.PostgreSQL.Query.TH.SqlExp
>>> c <- connect defaultConnectInfo
>>> run b = fmap fst $ runSqlBuilder c defaultLogMasker b
-}

{- | Maybe the main feature of all library. Quasiquoter which builds
'SqlBuilder' from string query. Removes line comments and block
comments (even nested) and sequences of spaces. Correctly works
handles string literals and quoted identifiers. Here is examples of usage

>>> let name = "name"
>>> let val = "some 'value'"
>>> run [sqlExp|SELECT * FROM tbl WHERE ^{Identifier name} = #{val}|]
"SELECT * FROM tbl WHERE \"name\" = 'some ''value'''"

And more comples example:

>>> let name = Just "name"
>>> let size = Just 10
>>> let active = Nothing :: Maybe Bool
>>> let condlist = catMaybes [ fmap (\a -> [sqlExp|name = #{a}|]) name, fmap (\a -> [sqlExp|size = #{a}|]) size, fmap (\a -> [sqlExp|active = #{a}|]) active]
>>> let cond = if L.null condlist then mempty else [sqlExp| WHERE ^{mconcat $ L.intersperse " AND " $ condlist} |]
>>> run [sqlExp|SELECT *   FROM tbl ^{cond} -- line comment|]
"SELECT * FROM tbl  WHERE name = 'name' AND size = 10  "

-}

sqlExp :: QuasiQuoter
sqlExp :: QuasiQuoter
sqlExp = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
         { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
sqlQExp
         , quotePat :: String -> Q Pat
quotePat  = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"sqlInt used in pattern"
         , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"sqlInt used in type"
         , quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"sqlInt used in declaration"
         }

-- | Internal type. Result of parsing sql string
data Rope
    = RLit Text             -- ^ Part of raw sql
    | RComment Text         -- ^ Sql comment
    | RSpaces Int           -- ^ Sequence of spaces
    | RInt FieldOption Text -- ^ String with haskell expression inside __#{..}__
                            -- or __#?{..}__
    | RPaste Text           -- ^ String with haskell expression inside __^{..}__
    deriving (Eq Rope
Eq Rope
-> (Rope -> Rope -> Ordering)
-> (Rope -> Rope -> Bool)
-> (Rope -> Rope -> Bool)
-> (Rope -> Rope -> Bool)
-> (Rope -> Rope -> Bool)
-> (Rope -> Rope -> Rope)
-> (Rope -> Rope -> Rope)
-> Ord Rope
Rope -> Rope -> Bool
Rope -> Rope -> Ordering
Rope -> Rope -> Rope
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rope -> Rope -> Rope
$cmin :: Rope -> Rope -> Rope
max :: Rope -> Rope -> Rope
$cmax :: Rope -> Rope -> Rope
>= :: Rope -> Rope -> Bool
$c>= :: Rope -> Rope -> Bool
> :: Rope -> Rope -> Bool
$c> :: Rope -> Rope -> Bool
<= :: Rope -> Rope -> Bool
$c<= :: Rope -> Rope -> Bool
< :: Rope -> Rope -> Bool
$c< :: Rope -> Rope -> Bool
compare :: Rope -> Rope -> Ordering
$ccompare :: Rope -> Rope -> Ordering
$cp1Ord :: Eq Rope
Ord, Rope -> Rope -> Bool
(Rope -> Rope -> Bool) -> (Rope -> Rope -> Bool) -> Eq Rope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rope -> Rope -> Bool
$c/= :: Rope -> Rope -> Bool
== :: Rope -> Rope -> Bool
$c== :: Rope -> Rope -> Bool
Eq, Int -> Rope -> ShowS
[Rope] -> ShowS
Rope -> String
(Int -> Rope -> ShowS)
-> (Rope -> String) -> ([Rope] -> ShowS) -> Show Rope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rope] -> ShowS
$cshowList :: [Rope] -> ShowS
show :: Rope -> String
$cshow :: Rope -> String
showsPrec :: Int -> Rope -> ShowS
$cshowsPrec :: Int -> Rope -> ShowS
Show)

parseRope :: String -> [Rope]
parseRope :: String -> [Rope]
parseRope String
s = (String -> [Rope])
-> ([Rope] -> [Rope]) -> Either String [Rope] -> [Rope]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> [Rope]
forall a. HasCallStack => String -> a
error [Rope] -> [Rope]
forall a. a -> a
id
              (Either String [Rope] -> [Rope]) -> Either String [Rope] -> [Rope]
forall a b. (a -> b) -> a -> b
$ Parser [Rope] -> Text -> Either String [Rope]
forall a. Parser a -> Text -> Either String a
parseOnly Parser [Rope]
ropeParser
              (Text -> Either String [Rope]) -> Text -> Either String [Rope]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s

ropeParser :: Parser [Rope]
ropeParser :: Parser [Rope]
ropeParser = Parser Text Rope -> Parser [Rope]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser Text Rope -> Parser [Rope])
-> Parser Text Rope -> Parser [Rope]
forall a b. (a -> b) -> a -> b
$ [Parser Text Rope] -> Parser Text Rope
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
             [ Parser Text Rope
quoted
             , Parser Text Rope
iquoted
             , FieldOption -> Text -> Rope
RInt FieldOption
FieldMasked (Text -> Rope) -> Parser Text Text -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
someNested Text
"#?{"
             , FieldOption -> Text -> Rope
RInt FieldOption
FieldDefault (Text -> Rope) -> Parser Text Text -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
someNested Text
"#{"
             , Text -> Rope
RPaste (Text -> Rope) -> Parser Text Text -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser Text Text
someNested Text
"^{"
             , Parser Text Rope
comment
             , Parser Text Rope
bcomment
             , Parser Text Rope
spaces
             , (Text -> Rope
RLit (Text -> Rope) -> (Char -> Text) -> Char -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) (Char -> Rope) -> Parser Text Char -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Char
anyChar
             ]
  where
    eofErf :: String -> Parser t a -> Parser t a
eofErf String
e Parser t a
p =
        [Parser t a] -> Parser t a
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
        [ Parser t ()
forall t. Chunk t => Parser t ()
endOfInput
          Parser t () -> Parser t a -> Parser t a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Parser t a
forall a. HasCallStack => String -> a
error (String -> Parser t a) -> String -> Parser t a
forall a b. (a -> b) -> a -> b
$ String
"Unexpected end of input: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e)
        , Parser t a
p
        ]

    unquoteBraces :: Text -> Text
unquoteBraces = Text -> Text -> Text -> Text
T.replace Text
"\\}" Text
"}"

    -- Prefix must be string like '#{' or something
    someNested :: Text -> Parser Text
    someNested :: Text -> Parser Text Text
someNested Text
prefix = do
        Text
_ <- Text -> Parser Text Text
string Text
prefix
        [Text]
e <- Parser Text Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser Text Text -> Parser Text [Text])
-> Parser Text Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ [Parser Text Text] -> Parser Text Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
             [ Text -> Parser Text Text
string Text
"\\}"
             , Char -> Text
T.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
notChar Char
'}'
             ]
        String -> Parser Text Text -> Parser Text Text
forall t a. Chunk t => String -> Parser t a -> Parser t a
eofErf (String
"block " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" not finished") (Parser Text Text -> Parser Text Text)
-> Parser Text Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ do
          Char
_ <- Char -> Parser Text Char
char Char
'}'
          Text -> Parser Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
unquoteBraces (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
e

    comment :: Parser Text Rope
comment = do
        Text
b <- Text -> Parser Text Text
string Text
"--"
        Text
c <- (Char -> Bool) -> Parser Text Text
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'\r', Char
'\n'])
        Parser ()
endOfLine Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall t. Chunk t => Parser t ()
endOfInput
        Rope -> Parser Text Rope
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Parser Text Rope) -> Rope -> Parser Text Rope
forall a b. (a -> b) -> a -> b
$ Text -> Rope
RComment (Text -> Rope) -> Text -> Rope
forall a b. (a -> b) -> a -> b
$ Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c
    spaces :: Parser Text Rope
spaces = (Int -> Rope
RSpaces (Int -> Rope) -> (Text -> Int) -> Text -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length) (Text -> Rope) -> Parser Text Text -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeWhile1 Char -> Bool
isSpace

    bcomment :: Parser Rope
    bcomment :: Parser Text Rope
bcomment = Text -> Rope
RComment (Text -> Rope) -> Parser Text Text -> Parser Text Rope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
go
      where
        go :: Parser Text Text
go = do
            Text
b <- Text -> Parser Text Text
string Text
"/*"
            [Text]
c <- Parser Text Text -> Parser Text [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Text Text -> Parser Text [Text])
-> Parser Text Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ [Parser Text Text] -> Parser Text Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
                 [ Parser Text Text
go
                 , Parser Text Text
justStar
                 , Char -> Text
T.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
notChar Char
'*'
                 ]
            String -> Parser Text Text -> Parser Text Text
forall t a. Chunk t => String -> Parser t a -> Parser t a
eofErf String
"block comment not finished, maybe typo" (Parser Text Text -> Parser Text Text)
-> Parser Text Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ do
                Text
e <- Text -> Parser Text Text
string Text
"*/"
                Text -> Parser Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text Text) -> Text -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
        justStar :: Parser Text Text
justStar = do
            Char
_ <- Char -> Parser Text Char
char Char
'*'
            Parser (Maybe Char)
peekChar Parser (Maybe Char)
-> (Maybe Char -> Parser Text Text) -> Parser Text Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                (Just Char
'/') -> String -> Parser Text Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no way"
                Maybe Char
_ -> Text -> Parser Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"*"

    quoted :: Parser Text Rope
quoted = do
        Char
_ <- Char -> Parser Text Char
char Char
'\''
        [Text]
ret <- Parser Text Text -> Parser Text [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Text Text -> Parser Text [Text])
-> Parser Text Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ [Parser Text Text] -> Parser Text Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
               [ Text -> Parser Text Text
string Text
"''"
               , Text -> Parser Text Text
string Text
"\\'"
               , Char -> Text
T.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
notChar Char
'\''
               ]
        String -> Parser Text Rope -> Parser Text Rope
forall t a. Chunk t => String -> Parser t a -> Parser t a
eofErf String
"string literal not finished" (Parser Text Rope -> Parser Text Rope)
-> Parser Text Rope -> Parser Text Rope
forall a b. (a -> b) -> a -> b
$ do
            Char
_ <- Char -> Parser Text Char
char Char
'\''
            Rope -> Parser Text Rope
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Parser Text Rope) -> Rope -> Parser Text Rope
forall a b. (a -> b) -> a -> b
$ Text -> Rope
RLit (Text -> Rope) -> Text -> Rope
forall a b. (a -> b) -> a -> b
$ Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ret Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

    iquoted :: Parser Text Rope
iquoted = do
        Char
_ <- Char -> Parser Text Char
char Char
'"'
        [Text]
ret <- Parser Text Text -> Parser Text [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Text Text -> Parser Text [Text])
-> Parser Text Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ [Parser Text Text] -> Parser Text Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
               [ Text -> Parser Text Text
string Text
"\"\""
               , Char -> Text
T.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
notChar Char
'"'
               ]
        String -> Parser Text Rope -> Parser Text Rope
forall t a. Chunk t => String -> Parser t a -> Parser t a
eofErf String
"quoted identifier not finished" (Parser Text Rope -> Parser Text Rope)
-> Parser Text Rope -> Parser Text Rope
forall a b. (a -> b) -> a -> b
$ do
            Char
_ <- Char -> Parser Text Char
char Char
'"'
            Rope -> Parser Text Rope
forall (m :: * -> *) a. Monad m => a -> m a
return (Rope -> Parser Text Rope) -> Rope -> Parser Text Rope
forall a b. (a -> b) -> a -> b
$ Text -> Rope
RLit (Text -> Rope) -> Text -> Rope
forall a b. (a -> b) -> a -> b
$ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ret Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""


-- | Build builder from rope
buildBuilder :: Rope
             -> Maybe (Q Exp)
buildBuilder :: Rope -> Maybe (Q Exp)
buildBuilder (RLit Text
t) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ do
    Exp
bs <- ByteString -> Q Exp
bsToExp (ByteString -> Q Exp) -> ByteString -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
t
    [e| sqlBuilderFromByteString $(pure bs) |]
buildBuilder (RInt FieldOption
fo Text
t) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty interpolation string found"
    let ex :: Exp
ex = (String -> Exp) -> (Exp -> Exp) -> Either String Exp -> Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Exp
forall a. HasCallStack => String -> a
error Exp -> Exp
forall a. a -> a
id (Either String Exp -> Exp) -> Either String Exp -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Either String Exp
parseExp (String -> Either String Exp) -> String -> Either String Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    [e| sqlBuilderFromField $(lift fo) $(pure ex) |]
buildBuilder (RPaste Text
t) = Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just (Q Exp -> Maybe (Q Exp)) -> Q Exp -> Maybe (Q Exp)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty paste string found"
    let ex :: Exp
ex = (String -> Exp) -> (Exp -> Exp) -> Either String Exp -> Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Exp
forall a. HasCallStack => String -> a
error Exp -> Exp
forall a. a -> a
id (Either String Exp -> Exp) -> Either String Exp -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Either String Exp
parseExp (String -> Either String Exp) -> String -> Either String Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    [e| toSqlBuilder $(pure ex) |]
buildBuilder Rope
_ = Maybe (Q Exp)
forall a. Maybe a
Nothing

-- | Removes sequential occurencies of 'RLit' constructors. Also
-- removes commentaries and squash sequences of spaces to single space
-- symbol
squashRope :: [Rope] -> [Rope]
squashRope :: [Rope] -> [Rope]
squashRope = [Rope] -> [Rope]
go ([Rope] -> [Rope]) -> ([Rope] -> [Rope]) -> [Rope] -> [Rope]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Rope] -> [Rope]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Rope] -> [Rope])
-> ([Rope] -> [Maybe Rope]) -> [Rope] -> [Rope]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rope -> Maybe Rope) -> [Rope] -> [Maybe Rope]
forall a b. (a -> b) -> [a] -> [b]
map Rope -> Maybe Rope
cleanRope
  where
    cleanRope :: Rope -> Maybe Rope
cleanRope (RComment Text
_) = Maybe Rope
forall a. Maybe a
Nothing
    cleanRope (RSpaces Int
_) = Rope -> Maybe Rope
forall a. a -> Maybe a
Just (Rope -> Maybe Rope) -> Rope -> Maybe Rope
forall a b. (a -> b) -> a -> b
$ Text -> Rope
RLit Text
" "
    cleanRope Rope
x = Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
x

    go :: [Rope] -> [Rope]
go ((RLit Text
a):(RLit Text
b):[Rope]
xs) = [Rope] -> [Rope]
go ((Text -> Rope
RLit (Text -> Rope) -> Text -> Rope
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
:[Rope]
xs)
    go (Rope
x:[Rope]
xs) = Rope
xRope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
:([Rope] -> [Rope]
go [Rope]
xs)
    go [] = []

-- | Build expression of type 'SqlBuilder' from SQL query with interpolation
sqlQExp :: String
        -> Q Exp                 -- ^ Expression of type 'SqlBuilder'
sqlQExp :: String -> Q Exp
sqlQExp String
s = do
    let rope :: [Rope]
rope = [Rope] -> [Rope]
squashRope ([Rope] -> [Rope]) -> [Rope] -> [Rope]
forall a b. (a -> b) -> a -> b
$ String -> [Rope]
parseRope String
s
    [Exp]
exps <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ [Maybe (Q Exp)] -> [Q Exp]
forall a. [Maybe a] -> [a]
catMaybes
            ([Maybe (Q Exp)] -> [Q Exp]) -> [Maybe (Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ (Rope -> Maybe (Q Exp)) -> [Rope] -> [Maybe (Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map Rope -> Maybe (Q Exp)
buildBuilder [Rope]
rope
    [e| ( mconcat $(pure $ ListE exps) ) |]

{- | Embed sql template and perform interpolation

@
let name = "name"
    foo = "bar"
    query = $(sqlExpEmbed "sql/foo/bar.sql") -- using 'foo' and 'bar' inside
@
-}

sqlExpEmbed :: String            -- ^ file path
            -> Q Exp             -- ^ Expression of type 'SqlBuilder'
sqlExpEmbed :: String -> Q Exp
sqlExpEmbed String
fpath = do
    String -> Q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile String
fpath
    String
s <- IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fpath
    String -> Q Exp
sqlQExp String
s

{- | Just like 'sqlExpEmbed' but uses pattern instead of file
name. So, code

@
let query = $(sqlExpFile "foo/bar")
@

is just the same as

@
let query = $(sqlExpEmbed "sql/foo/bar.sql")
@

This function inspired by Yesod's 'widgetFile'
-}

sqlExpFile :: String
           -> Q Exp
sqlExpFile :: String -> Q Exp
sqlExpFile String
ptr = String -> Q Exp
sqlExpEmbed (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"sql/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ptr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".sql"