{-# LANGUAGE TemplateHaskell #-}

-- | Interpolated SQL queries
module Database.SQLite.Simple.QQ.Interpolated
  ( isql
  , quoteInterpolatedSql
  , iquery
  , iexecute
  , ifold
  ) where

import Language.Haskell.TH (Exp, Q, appE, listE, sigE, tupE, varE, litE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Lit(..), lookupValueName)
import Database.SQLite.Simple.ToField (toField)
import Text.Parsec (ParseError)
import Database.SQLite.Simple
import Data.Foldable (foldrM)
import Data.String (fromString)

import Database.SQLite.Simple.QQ.Interpolated.Parser (StringPart (..), parseInterpolated)

-- | Quote a SQL statement with embedded antiquoted expressions.
--
-- The result of the quasiquoter is a tuple, containing the statement string and a list
-- of parameters. For example:
--
-- @[isql|SELECT field FROM table WHERE name = ${map toLower "ELLIOT"} LIMIT ${10}|]@
--
-- produces
--
-- @("SELECT field FROM table WHERE name = ? LIMIT ?", [toField ((map toLower) "ELLIOT"), toField 10])@
--
-- How the parser works:
--
-- Any expression occurring between @${@ and @}@ will be replaced with a @?@
-- and passed as a query parameter.
--
-- Characters preceded by a backslash are treated literally. This enables the
-- inclusion of the literal substring @${@ within your quoted text by writing
-- it as @\\${@. The literal sequence @\\${@ may be written as @\\\\${@.
--
-- Note: This quasiquoter is a wrapper around 'Database.SQLite.Simple.QQ.sql'.
--
-- This quasiquoter only works in expression contexts and will throw an error
-- at compile time if used in any other context.
isql :: QuasiQuoter
isql :: QuasiQuoter
isql = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteInterpolatedSql
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"isql quasiquoter does not support usage in patterns"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"isql quasiquoter does not support usage in types"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"isql quasiquoter does not support usage in declarations"
  }

combineParts :: [StringPart] -> Q ([Q Exp], [Q Exp])
combineParts :: [StringPart] -> Q ([Q Exp], [Q Exp])
combineParts = (StringPart -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp]))
-> ([Q Exp], [Q Exp]) -> [StringPart] -> Q ([Q Exp], [Q Exp])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM StringPart -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
step ([], [])
  where
    step :: StringPart -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
step StringPart
subExpr ([Q Exp]
s, [Q Exp]
exprs) = case StringPart
subExpr of
      AntiInject String
e -> String -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
injectExpr String
e ([Q Exp]
s, [Q Exp]
exprs)
      Lit String
str -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> Q Exp
litE (String -> Lit
StringL String
str) Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
s, [Q Exp]
exprs)
      Esc Char
c -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> Q Exp
litE (String -> Lit
StringL [Char
c]) Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
s, [Q Exp]
exprs)
      AntiParam Q Exp
e -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lit -> Q Exp
litE (String -> Lit
StringL String
"?") Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
s, Q Exp
e Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
exprs)

injectExpr :: String -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
injectExpr :: String -> ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
injectExpr String
name ([Q Exp]
s, [Q Exp]
exprs) = do
  Maybe Name
valueName <- String -> Q (Maybe Name)
lookupValueName String
name
  case Maybe Name
valueName of
    Maybe Name
Nothing ->
      String -> Q ([Q Exp], [Q Exp])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ([Q Exp], [Q Exp])) -> String -> Q ([Q Exp], [Q Exp])
forall a b. (a -> b) -> a -> b
$ String
"Value `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"` is not in scope"
    Just Name
found -> do
      ([Q Exp], [Q Exp]) -> Q ([Q Exp], [Q Exp])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Q Exp
varE Name
found Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
s, [Q Exp]
exprs)

applySql :: [StringPart] -> Q Exp
applySql :: [StringPart] -> Q Exp
applySql [StringPart]
parts = do
  ([Q Exp]
queryParts, [Q Exp]
exps) <- [StringPart] -> Q ([Q Exp], [Q Exp])
combineParts [StringPart]
parts
  let queryStr :: Q Exp
queryStr = Q Exp -> Q Exp -> Q Exp
appE [| fromString :: String -> Query |] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE [| concat |] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
listE [Q Exp]
queryParts
  [Q Exp] -> Q Exp
tupE [Q Exp
queryStr, Q Exp -> Q Type -> Q Exp
sigE ([Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'toField)) [Q Exp]
exps) [t| [SQLData] |]]

-- | The internal parser used by 'isql'.
quoteInterpolatedSql :: String -> Q Exp
quoteInterpolatedSql :: String -> Q Exp
quoteInterpolatedSql String
s = (ParseError -> Q Exp)
-> ([StringPart] -> Q Exp)
-> Either ParseError [StringPart]
-> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ParseError -> Q Exp
handleError String
s) [StringPart] -> Q Exp
applySql (String -> Either ParseError [StringPart]
parseInterpolated String
s)

handleError :: String -> ParseError -> Q Exp
handleError :: String -> ParseError -> Q Exp
handleError String
expStr ParseError
parseError = String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
  [ String
"Failed to parse interpolated expression in string: "
  , String
expStr
  , String
"\n"
  , ParseError -> String
forall a. Show a => a -> String
show ParseError
parseError
  ]

-- | Invokes 'query' with arguments provided by 'isql'.
-- The result is of type '(Connection -> IO [r])'.
iquery :: QuasiQuoter
iquery :: QuasiQuoter
iquery = QuasiQuoter
isql { quoteExp :: String -> Q Exp
quoteExp = Q Exp -> Q Exp -> Q Exp
appE [| \(q, qs) c -> query c q qs |] (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
quoteInterpolatedSql }

-- | Invokes 'execute' with arguments provided by 'isql'
-- The result is of type '(Connection -> IO ())'.
iexecute :: QuasiQuoter
iexecute :: QuasiQuoter
iexecute = QuasiQuoter
isql { quoteExp :: String -> Q Exp
quoteExp = Q Exp -> Q Exp -> Q Exp
appE [| \(q, qs) c -> execute c q qs |] (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
quoteInterpolatedSql }

-- | Invokes 'fold' with arguments provided by 'isql'.
-- The result is of type 'a -> (a -> row -> IO a) -> Connection -> IO a'.
ifold :: QuasiQuoter
ifold :: QuasiQuoter
ifold = QuasiQuoter
isql { quoteExp :: String -> Q Exp
quoteExp = Q Exp -> Q Exp -> Q Exp
appE [| \(q, qs) acc f c -> fold c q qs acc f |] (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
quoteInterpolatedSql }