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

import CustomInterpolation
import Data.Maybe (catMaybes)
import Data.String (fromString)
import Database.SQLite.Simple
import Database.SQLite.Simple.ToField (toField)
import GHC.OldList (intercalate)
import Language.Haskell.TH (Exp, Q, appE, listE, sigE, stringE, tupE, varE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))

{- | Quote an 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:

>>> import Data.Char (toLower)
>>> [isql|SELECT field FROM !{map toLower "PEOPLE"} WHERE name = {map toLower "ELLIOT"} AND access IN @{["admin", "employee"]} LIMIT {10 :: Int}|]
("SELECT field FROM people WHERE name = ? AND access IN (?,?) LIMIT ?",[SQLText "elliot",SQLText "admin",SQLText "employee",SQLInteger 10])

The generated code is:

@("SELECT field FROM people WHERE name = ? AND access IN (?,?) LIMIT ?", ['toField' (map toLower "ELLIOT")] ++ 'toRow' ["admin", "employee"] ++ ['toField' (10 :: Int)])@

How the parser works:

* Any expression occurring between @{@ and @}@ will be replaced with a @?@
and passed as a query parameter using 'toField'.
* Any expression occuring between @\@{@ and @}@ will be replaced with the right amount of @?@, separated by commas and surrounded by parentheses (e.g. @(?,?,?)@ for a `ToRow` instance with 3 fields).
The expression gets converted to query parameters using 'toRow'.
* Any expression occurring between @!{@ and @}@ will be replaced with its value, bypassing the anti-injection mechanisms. /Never use this one for user input!/

Characters preceded by a backslash are treated literally. This enables the
inclusion of the literal character @{@ within your quoted text by writing
it as @\\{@. The literal sequence @\\{@ may be written as @\\\\{@.
-}
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
"This quasiquoter does not support usage in patterns",
      quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"This quasiquoter does not support usage in types",
      quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"This quasiquoter does not support usage in declarations"
    }

-- | The Template Haskell function used by 'isql'.
quoteInterpolatedSql :: String -> Q Exp
quoteInterpolatedSql :: String -> Q Exp
quoteInterpolatedSql =
  InterpolationConfig (Maybe (Q Exp)) -> String -> Q Exp
forall a. InterpolationConfig a -> String -> Q Exp
interpolate
    InterpolationConfig Any
forall a. InterpolationConfig a
defaultConfig
      { finalize :: ([Maybe (Q Exp)], Q Exp) -> Q Exp
finalize = ([Maybe (Q Exp)], Q Exp) -> Q Exp
consumeInterpolated,
        handlers :: [Interpolator (Maybe (Q Exp))]
handlers =
          [ Interpolator ()
simpleInterpolator
              { prefix :: String
prefix = String
"",
                handler :: Q Exp -> (Maybe (Q Exp), Q Exp)
handler = \Q Exp
sqlFieldExpr -> (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
$ [Q Exp] -> Q Exp
listE [Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'toField) Q Exp
sqlFieldExpr], [|"?"|])
              },
            Interpolator ()
simpleInterpolator
              { prefix :: String
prefix = String
"!",
                handler :: Q Exp -> (Maybe (Q Exp), Q Exp)
handler = \Q Exp
stringExpr -> (Maybe (Q Exp)
forall a. Maybe a
Nothing, Q Exp
stringExpr)
              },
            Interpolator ()
simpleInterpolator
              { prefix :: String
prefix = String
"@",
                handler :: Q Exp -> (Maybe (Q Exp), Q Exp)
handler = \Q Exp
sqlRowExpr ->
                  let sqlRow :: Q Exp
sqlRow = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'toRow) Q Exp
sqlRowExpr
                      rowLength :: Q Exp
rowLength = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'length) Q Exp
sqlRow
                      intercalateCommas :: Q Exp -> Q Exp
intercalateCommas = Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'intercalate) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Q Exp
stringE String
","
                      questionMarks :: Q Exp
questionMarks = Q Exp -> Q Exp
intercalateCommas (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'replicate) Q Exp
rowLength) [|"?"|]
                      questionMarksWithParens :: Q Exp
questionMarksWithParens = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'concat) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
listE [String -> Q Exp
stringE String
"(", Q Exp
questionMarks, String -> Q Exp
stringE String
")"]
                   in (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
sqlRow, Q Exp
questionMarksWithParens)
              }
          ]
      }

consumeInterpolated :: ([Maybe (Q Exp)], Q Exp) -> Q Exp
consumeInterpolated :: ([Maybe (Q Exp)], Q Exp) -> Q Exp
consumeInterpolated ([Maybe (Q Exp)]
sqlDataExprs, Q Exp
queryStrExpr) = [Q Exp] -> Q Exp
tupE [Q Exp
queryStr, Q Exp
sqlData]
  where
    queryStr :: Q Exp
queryStr = Q Exp -> Q Exp -> Q Exp
appE [|fromString :: String -> Query|] Q Exp
queryStrExpr
    sqlData :: Q Exp
sqlData = Q Exp -> Q Type -> Q Exp
sigE (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'concat) ([Q Exp] -> Q Exp
listE [Q Exp]
sqlDataExprs')) [t|[SQLData]|]
    sqlDataExprs' :: [Q Exp]
sqlDataExprs' = [Maybe (Q Exp)] -> [Q Exp]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Q Exp)]
sqlDataExprs

{- | 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}