{-# LANGUAGE TemplateHaskell #-}
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)
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] |]]
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
]
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 }
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 }
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 }