{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Database.Persist.Sql.Raw.QQ (
queryQQ
, queryResQQ
, sqlQQ
, executeQQ
, executeCountQQ
, ToRow(..)
) where
import Prelude
import Control.Arrow (first, second)
import Control.Monad.Reader (ask)
import Data.List.NonEmpty (NonEmpty(..), (<|))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import Data.List (replicate, intercalate)
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Monoid (mempty, (<>))
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Language.Haskell.Meta.Parse
import Database.Persist.Class (toPersistValue)
import Database.Persist
import Database.Persist.Sql
class ToRow a where
toRow :: a -> NonEmpty PersistValue
instance PersistField a => ToRow (Single a) where
toRow :: Single a -> NonEmpty PersistValue
toRow (Single a
a) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a forall a. a -> [a] -> NonEmpty a
:| []
instance (PersistField a, PersistField b) => ToRow (a, b) where
toRow :: (a, b) -> NonEmpty PersistValue
toRow (a
a, b
b) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a forall a. a -> NonEmpty a -> NonEmpty a
<| forall a. ToRow a => a -> NonEmpty PersistValue
toRow (forall a. a -> Single a
Single b
b)
instance (PersistField a, PersistField b, PersistField c) => ToRow (a, b, c) where
toRow :: (a, b, c) -> NonEmpty PersistValue
toRow (a
a, b
b, c
c) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a forall a. a -> NonEmpty a -> NonEmpty a
<| forall a. ToRow a => a -> NonEmpty PersistValue
toRow (b
b, c
c)
instance (PersistField a, PersistField b, PersistField c, PersistField d) => ToRow (a, b, c, d) where
toRow :: (a, b, c, d) -> NonEmpty PersistValue
toRow (a
a, b
b, c
c, d
d) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a forall a. a -> NonEmpty a -> NonEmpty a
<| forall a. ToRow a => a -> NonEmpty PersistValue
toRow (b
b, c
c, d
d)
instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => ToRow (a, b, c, d, e) where
toRow :: (a, b, c, d, e) -> NonEmpty PersistValue
toRow (a
a, b
b, c
c, d
d, e
e) = forall a. PersistField a => a -> PersistValue
toPersistValue a
a forall a. a -> NonEmpty a -> NonEmpty a
<| forall a. ToRow a => a -> NonEmpty PersistValue
toRow (b
b, c
c, d
d, e
e)
data Token
= Literal String
| Value String
| Values String
| Rows String
| TableName String
| ColumnName String
deriving Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> [Char]
$cshow :: Token -> [Char]
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show
parseHaskell :: (String -> Token) -> String -> String -> [Token]
parseHaskell :: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
cons = [Char] -> [Char] -> [Token]
go
where
go :: [Char] -> [Char] -> [Token]
go [Char]
a [] = [[Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a)]
go [Char]
a (Char
'\\':Char
x:[Char]
xs) = [Char] -> [Char] -> [Token]
go (Char
xforall a. a -> [a] -> [a]
:[Char]
a) [Char]
xs
go [Char]
a [Char
'\\'] = [Char] -> [Char] -> [Token]
go (Char
'\\'forall a. a -> [a] -> [a]
:[Char]
a) []
go [Char]
a (Char
'}':[Char]
xs) = [Char] -> Token
cons (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: [Char] -> [Char] -> [Token]
parseStr [] [Char]
xs
go [Char]
a (Char
x:[Char]
xs) = [Char] -> [Char] -> [Token]
go (Char
xforall a. a -> [a] -> [a]
:[Char]
a) [Char]
xs
parseStr :: String -> String -> [Token]
parseStr :: [Char] -> [Char] -> [Token]
parseStr [Char]
a [] = [[Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a)]
parseStr [Char]
a (Char
'\\':Char
x:[Char]
xs) = [Char] -> [Char] -> [Token]
parseStr (Char
xforall a. a -> [a] -> [a]
:[Char]
a) [Char]
xs
parseStr [Char]
a [Char
'\\'] = [Char] -> [Char] -> [Token]
parseStr (Char
'\\'forall a. a -> [a] -> [a]
:[Char]
a) []
parseStr [Char]
a (Char
'#':Char
'{':[Char]
xs) = [Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
Value [] [Char]
xs
parseStr [Char]
a (Char
'%':Char
'{':[Char]
xs) = [Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
Values [] [Char]
xs
parseStr [Char]
a (Char
'*':Char
'{':[Char]
xs) = [Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
Rows [] [Char]
xs
parseStr [Char]
a (Char
'^':Char
'{':[Char]
xs) = [Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
TableName [] [Char]
xs
parseStr [Char]
a (Char
'@':Char
'{':[Char]
xs) = [Char] -> Token
Literal (forall a. [a] -> [a]
reverse [Char]
a) forall a. a -> [a] -> [a]
: ([Char] -> Token) -> [Char] -> [Char] -> [Token]
parseHaskell [Char] -> Token
ColumnName [] [Char]
xs
parseStr [Char]
a (Char
x:[Char]
xs) = [Char] -> [Char] -> [Token]
parseStr (Char
xforall a. a -> [a] -> [a]
:[Char]
a) [Char]
xs
interpolateValues :: PersistField a => NonEmpty a -> (String, [[PersistValue]]) -> (String, [[PersistValue]])
interpolateValues :: forall a.
PersistField a =>
NonEmpty a
-> ([Char], [[PersistValue]]) -> ([Char], [[PersistValue]])
interpolateValues NonEmpty a
xs =
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a. NonEmpty a -> [Char]
mkPlaceholders NonEmpty PersistValue
values forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty PersistValue
values forall a. a -> [a] -> [a]
:)
where
values :: NonEmpty PersistValue
values = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map forall a. PersistField a => a -> PersistValue
toPersistValue NonEmpty a
xs
interpolateRows :: ToRow a => NonEmpty a -> (String, [[PersistValue]]) -> (String, [[PersistValue]])
interpolateRows :: forall a.
ToRow a =>
NonEmpty a
-> ([Char], [[PersistValue]]) -> ([Char], [[PersistValue]])
interpolateRows NonEmpty a
xs ([Char]
sql, [[PersistValue]]
vals) =
([Char]
placeholders forall a. Semigroup a => a -> a -> a
<> [Char]
sql, [PersistValue]
values forall a. a -> [a] -> [a]
: [[PersistValue]]
vals)
where
rows :: NonEmpty (NonEmpty PersistValue)
rows :: NonEmpty (NonEmpty PersistValue)
rows = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map forall a. ToRow a => a -> NonEmpty PersistValue
toRow NonEmpty a
xs
n :: Int
n = forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty (NonEmpty PersistValue)
rows
placeholders :: [Char]
placeholders = Int
n Int -> ShowS
`timesCommaSeparated` forall a. NonEmpty a -> [Char]
mkPlaceholders (forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (NonEmpty PersistValue)
rows)
values :: [PersistValue]
values = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
List.concatMap forall a. NonEmpty a -> [a]
NonEmpty.toList forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (NonEmpty PersistValue)
rows
mkPlaceholders :: NonEmpty a -> String
mkPlaceholders :: forall a. NonEmpty a -> [Char]
mkPlaceholders NonEmpty a
values = [Char]
"(" forall a. Semigroup a => a -> a -> a
<> Int
n Int -> ShowS
`timesCommaSeparated` [Char]
"?" forall a. Semigroup a => a -> a -> a
<> [Char]
")"
where
n :: Int
n = forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty a
values
timesCommaSeparated :: Int -> String -> String
timesCommaSeparated :: Int -> ShowS
timesCommaSeparated Int
n = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n
makeExpr :: TH.ExpQ -> [Token] -> TH.ExpQ
makeExpr :: ExpQ -> [Token] -> ExpQ
makeExpr ExpQ
fun [Token]
toks = do
[| do
(sql, vals) <- $(go toks)
$(fun) (Text.pack sql) (concat vals) |]
where
go :: [Token] -> TH.ExpQ
go :: [Token] -> ExpQ
go [] =
[| return (mempty :: String, []) |]
go (Literal [Char]
a:[Token]
xs) =
[| first (a <>) <$> $(go xs) |]
go (Value [Char]
a:[Token]
xs) = do
[| (\(str, vals) -> ("?" <> str, [toPersistValue $(reifyExp a)] : vals)) <$> ($(go xs)) |]
go (Values [Char]
a:[Token]
xs) =
[| interpolateValues $(reifyExp a) <$> $(go xs) |]
go (Rows [Char]
a:[Token]
xs) =
[| interpolateRows $(reifyExp a) <$> $(go xs) |]
go (ColumnName [Char]
a:[Token]
xs) =
[| getFieldName $(reifyExp a) >>= \field ->
first (Text.unpack field <>) <$> $(go xs) |]
go (TableName [Char]
a:[Token]
xs) = do
[| getTableName (error "record" :: $(TH.conT (TH.mkName a))) >>= \table ->
first (Text.unpack table <>) <$> $(go xs) |]
reifyExp :: String -> TH.Q TH.Exp
reifyExp :: [Char] -> ExpQ
reifyExp [Char]
s =
case [Char] -> Either [Char] Exp
parseExp [Char]
s of
Left [Char]
e -> [Char] -> Q ()
TH.reportError [Char]
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [| mempty |]
Right Exp
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Exp
v
makeQQ :: TH.Q TH.Exp -> QuasiQuoter
makeQQ :: ExpQ -> QuasiQuoter
makeQQ ExpQ
x = ([Char] -> ExpQ)
-> ([Char] -> Q Pat)
-> ([Char] -> Q Type)
-> ([Char] -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
(ExpQ -> [Token] -> ExpQ
makeExpr ExpQ
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Token]
parseStr [])
(forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use qc as a pattern")
(forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use qc as a type")
(forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use qc as a dec")
sqlQQ :: QuasiQuoter
sqlQQ :: QuasiQuoter
sqlQQ = ExpQ -> QuasiQuoter
makeQQ [| rawSql |]
executeQQ :: QuasiQuoter
executeQQ :: QuasiQuoter
executeQQ = ExpQ -> QuasiQuoter
makeQQ [| rawExecute |]
executeCountQQ :: QuasiQuoter
executeCountQQ :: QuasiQuoter
executeCountQQ = ExpQ -> QuasiQuoter
makeQQ [| rawExecuteCount |]
queryQQ :: QuasiQuoter
queryQQ :: QuasiQuoter
queryQQ = ExpQ -> QuasiQuoter
makeQQ [| rawQuery |]
queryResQQ :: QuasiQuoter
queryResQQ :: QuasiQuoter
queryResQQ = ExpQ -> QuasiQuoter
makeQQ [| rawQueryRes |]