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
         { quoteExp :: [Char] -> Q Exp
quoteExp  = [Char] -> Q Exp
sqlQExp
         , quotePat :: [Char] -> Q Pat
quotePat  = [Char] -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> a
error [Char]
"sqlInt used in pattern"
         , quoteType :: [Char] -> Q Type
quoteType = [Char] -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error [Char]
"sqlInt used in type"
         , quoteDec :: [Char] -> Q [Dec]
quoteDec  = [Char] -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"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
$ccompare :: Rope -> Rope -> Ordering
compare :: Rope -> Rope -> Ordering
$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
>= :: Rope -> Rope -> Bool
$cmax :: Rope -> Rope -> Rope
max :: Rope -> Rope -> Rope
$cmin :: Rope -> Rope -> Rope
min :: Rope -> Rope -> Rope
Ord, Rope -> Rope -> Bool
(Rope -> Rope -> Bool) -> (Rope -> Rope -> Bool) -> Eq Rope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Rope -> Rope -> Bool
== :: Rope -> Rope -> Bool
$c/= :: Rope -> Rope -> Bool
/= :: Rope -> Rope -> Bool
Eq, Int -> Rope -> ShowS
[Rope] -> ShowS
Rope -> [Char]
(Int -> Rope -> ShowS)
-> (Rope -> [Char]) -> ([Rope] -> ShowS) -> Show Rope
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Rope -> ShowS
showsPrec :: Int -> Rope -> ShowS
$cshow :: Rope -> [Char]
show :: Rope -> [Char]
$cshowList :: [Rope] -> ShowS
showList :: [Rope] -> ShowS
Show)

parseRope :: String -> [Rope]
parseRope :: [Char] -> [Rope]
parseRope [Char]
s = ([Char] -> [Rope])
-> ([Rope] -> [Rope]) -> Either [Char] [Rope] -> [Rope]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> [Rope]
forall a. HasCallStack => [Char] -> a
error [Rope] -> [Rope]
forall a. a -> a
id
              (Either [Char] [Rope] -> [Rope]) -> Either [Char] [Rope] -> [Rope]
forall a b. (a -> b) -> a -> b
$ Parser [Rope] -> Text -> Either [Char] [Rope]
forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser [Rope]
ropeParser
              (Text -> Either [Char] [Rope]) -> Text -> Either [Char] [Rope]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
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 :: [Char] -> Parser t a -> Parser t a
eofErf [Char]
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 a b. Parser t a -> Parser t b -> Parser t b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Char] -> Parser t a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Parser t a) -> [Char] -> Parser t a
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected end of input: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
e)
        , Parser t a
p
        ]

    unquoteBraces :: Text -> Text
unquoteBraces = HasCallStack => Text -> Text -> Text -> Text
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
'}'
             ]
        [Char] -> Parser Text Text -> Parser Text Text
forall {t} {a}. Chunk t => [Char] -> Parser t a -> Parser t a
eofErf ([Char]
"block " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
prefix [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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 a. a -> Parser Text a
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 -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'\r', Char
'\n'])
        Parser ()
endOfLine Parser () -> Parser () -> Parser ()
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
forall t. Chunk t => Parser t ()
endOfInput
        Rope -> Parser Text Rope
forall a. a -> Parser Text a
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
'*'
                 ]
            [Char] -> Parser Text Text -> Parser Text Text
forall {t} {a}. Chunk t => [Char] -> Parser t a -> Parser t a
eofErf [Char]
"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 a. a -> Parser Text a
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 a b. Parser Text a -> (a -> Parser Text b) -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                (Just Char
'/') -> [Char] -> Parser Text Text
forall a. [Char] -> Parser Text a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"no way"
                Maybe Char
_ -> Text -> Parser Text Text
forall a. a -> Parser Text a
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
'\''
               ]
        [Char] -> Parser Text Rope -> Parser Text Rope
forall {t} {a}. Chunk t => [Char] -> Parser t a -> Parser t a
eofErf [Char]
"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 a. a -> Parser Text a
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
'"'
               ]
        [Char] -> Parser Text Rope -> Parser Text Rope
forall {t} {a}. Chunk t => [Char] -> Parser t a -> Parser t a
eofErf [Char]
"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 a. a -> Parser Text a
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 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
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
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"empty interpolation string found"
    let ex :: Exp
ex = ([Char] -> Exp) -> (Exp -> Exp) -> Either [Char] Exp -> Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error Exp -> Exp
forall a. a -> a
id (Either [Char] Exp -> Exp) -> Either [Char] Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Exp
parseExp ([Char] -> Either [Char] Exp) -> [Char] -> Either [Char] Exp
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
    [e| sqlBuilderFromField $(FieldOption -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => FieldOption -> m Exp
lift FieldOption
fo) $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
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
$ [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"empty paste string found"
    let ex :: Exp
ex = ([Char] -> Exp) -> (Exp -> Exp) -> Either [Char] Exp -> Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error Exp -> Exp
forall a. a -> a
id (Either [Char] Exp -> Exp) -> Either [Char] Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Exp
parseExp ([Char] -> Either [Char] Exp) -> [Char] -> Either [Char] Exp
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
    [e| toSqlBuilder $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
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 :: [Char] -> Q Exp
sqlQExp [Char]
s = do
    let rope :: [Rope]
rope = [Rope] -> [Rope]
squashRope ([Rope] -> [Rope]) -> [Rope] -> [Rope]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Rope]
parseRope [Char]
s
    [Exp]
exps <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
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 :: [Char] -> Q Exp
sqlExpEmbed [Char]
fpath = do
    [Char] -> Q ()
forall (m :: * -> *). Quasi m => [Char] -> m ()
qAddDependentFile [Char]
fpath
    [Char]
s <- IO [Char] -> Q [Char]
forall a. IO a -> Q a
runIO (IO [Char] -> Q [Char]) -> IO [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> (ByteString -> Text) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> [Char]) -> IO ByteString -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
B.readFile [Char]
fpath
    [Char] -> Q Exp
sqlQExp [Char]
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 :: [Char] -> Q Exp
sqlExpFile [Char]
ptr = [Char] -> Q Exp
sqlExpEmbed ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"sql/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ptr [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".sql"