{-# 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)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Database.SQLite.Simple.ToField (toField)
import Database.SQLite.Simple.QQ (sql)
import Text.Parsec (ParseError)
import Database.SQLite.Simple

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] -> (String, [Q Exp])
combineParts :: [StringPart] -> (String, [Q Exp])
combineParts = (StringPart -> (String, [Q Exp]) -> (String, [Q Exp]))
-> (String, [Q Exp]) -> [StringPart] -> (String, [Q Exp])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StringPart -> (String, [Q Exp]) -> (String, [Q Exp])
step (String
"", [])
  where
    step :: StringPart -> (String, [Q Exp]) -> (String, [Q Exp])
step StringPart
subExpr (String
s, [Q Exp]
exprs) = case StringPart
subExpr of
      Lit String
str -> (String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s, [Q Exp]
exprs)
      Esc Char
c -> (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
s, [Q Exp]
exprs)
      Anti Q Exp
e -> (Char
'?' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s, Q Exp
e Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
exprs)

applySql :: [StringPart] -> Q Exp
applySql :: [StringPart] -> Q Exp
applySql [StringPart]
parts =
  let
    (String
s', [Q Exp]
exps) = [StringPart] -> (String, [Q Exp])
combineParts [StringPart]
parts
  in
  [Q Exp] -> Q Exp
tupE [QuasiQuoter -> String -> Q Exp
quoteExp QuasiQuoter
sql String
s', 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 }