{-# 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, pack, unpack, 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) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a PersistValue -> [PersistValue] -> NonEmpty PersistValue
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) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a PersistValue -> NonEmpty PersistValue -> NonEmpty PersistValue
forall a. a -> NonEmpty a -> NonEmpty a
<| Single b -> NonEmpty PersistValue
forall a. ToRow a => a -> NonEmpty PersistValue
toRow (b -> Single b
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) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a PersistValue -> NonEmpty PersistValue -> NonEmpty PersistValue
forall a. a -> NonEmpty a -> NonEmpty a
<| (b, c) -> NonEmpty PersistValue
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) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a PersistValue -> NonEmpty PersistValue -> NonEmpty PersistValue
forall a. a -> NonEmpty a -> NonEmpty a
<| (b, c, d) -> NonEmpty PersistValue
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) = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
a PersistValue -> NonEmpty PersistValue -> NonEmpty PersistValue
forall a. a -> NonEmpty a -> NonEmpty a
<| (b, c, d, e) -> NonEmpty PersistValue
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 -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show
parseHaskell :: (String -> Token) -> String -> String -> [Token]
parseHaskell :: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
cons = String -> String -> [Token]
go
where
go :: String -> String -> [Token]
go String
a [] = [String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a)]
go String
a (Char
'\\':Char
x:String
xs) = String -> String -> [Token]
go (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
a) String
xs
go String
a [Char
'\\'] = String -> String -> [Token]
go (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
a) []
go String
a (Char
'}':String
xs) = String -> Token
cons (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> String -> [Token]
parseStr [] String
xs
go String
a (Char
x:String
xs) = String -> String -> [Token]
go (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
a) String
xs
parseStr :: String -> String -> [Token]
parseStr :: String -> String -> [Token]
parseStr String
a [] = [String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a)]
parseStr String
a (Char
'\\':Char
x:String
xs) = String -> String -> [Token]
parseStr (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
a) String
xs
parseStr String
a [Char
'\\'] = String -> String -> [Token]
parseStr (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
a) []
parseStr String
a (Char
'#':Char
'{':String
xs) = String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
Value [] String
xs
parseStr String
a (Char
'%':Char
'{':String
xs) = String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
Values [] String
xs
parseStr String
a (Char
'*':Char
'{':String
xs) = String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
Rows [] String
xs
parseStr String
a (Char
'^':Char
'{':String
xs) = String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
TableName [] String
xs
parseStr String
a (Char
'@':Char
'{':String
xs) = String -> Token
Literal (ShowS
forall a. [a] -> [a]
reverse String
a) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: (String -> Token) -> String -> String -> [Token]
parseHaskell String -> Token
ColumnName [] String
xs
parseStr String
a (Char
x:String
xs) = String -> String -> [Token]
parseStr (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:String
a) String
xs
interpolateValues :: PersistField a => NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateValues :: NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateValues NonEmpty a
xs =
(Text -> Text)
-> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (NonEmpty PersistValue -> Text
forall a. NonEmpty a -> Text
mkPlaceholders NonEmpty PersistValue
values Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ((Text, [[PersistValue]]) -> (Text, [[PersistValue]]))
-> ((Text, [[PersistValue]]) -> (Text, [[PersistValue]]))
-> (Text, [[PersistValue]])
-> (Text, [[PersistValue]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([[PersistValue]] -> [[PersistValue]])
-> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (NonEmpty PersistValue -> [PersistValue]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty PersistValue
values [PersistValue] -> [[PersistValue]] -> [[PersistValue]]
forall a. a -> [a] -> [a]
:)
where
values :: NonEmpty PersistValue
values = (a -> PersistValue) -> NonEmpty a -> NonEmpty PersistValue
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue NonEmpty a
xs
interpolateRows :: ToRow a => NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateRows :: NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateRows NonEmpty a
xs =
(Text -> Text)
-> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Text
placeholders Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
((Text, [[PersistValue]]) -> (Text, [[PersistValue]]))
-> ((Text, [[PersistValue]]) -> (Text, [[PersistValue]]))
-> (Text, [[PersistValue]])
-> (Text, [[PersistValue]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[PersistValue]] -> [[PersistValue]])
-> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([PersistValue]
values [PersistValue] -> [[PersistValue]] -> [[PersistValue]]
forall a. a -> [a] -> [a]
:)
where
rows :: NonEmpty (NonEmpty PersistValue)
rows :: NonEmpty (NonEmpty PersistValue)
rows = (a -> NonEmpty PersistValue)
-> NonEmpty a -> NonEmpty (NonEmpty PersistValue)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map a -> NonEmpty PersistValue
forall a. ToRow a => a -> NonEmpty PersistValue
toRow NonEmpty a
xs
n :: Int
n = NonEmpty (NonEmpty PersistValue) -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty (NonEmpty PersistValue)
rows
placeholders :: Text
placeholders = Int
n Int -> Text -> Text
`timesCommaSeparated` NonEmpty PersistValue -> Text
forall a. NonEmpty a -> Text
mkPlaceholders (NonEmpty (NonEmpty PersistValue) -> NonEmpty PersistValue
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (NonEmpty PersistValue)
rows)
values :: [PersistValue]
values = (NonEmpty PersistValue -> [PersistValue])
-> [NonEmpty PersistValue] -> [PersistValue]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
List.concatMap NonEmpty PersistValue -> [PersistValue]
forall a. NonEmpty a -> [a]
NonEmpty.toList ([NonEmpty PersistValue] -> [PersistValue])
-> [NonEmpty PersistValue] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty PersistValue) -> [NonEmpty PersistValue]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (NonEmpty PersistValue)
rows
mkPlaceholders :: NonEmpty a -> Text
mkPlaceholders :: NonEmpty a -> Text
mkPlaceholders NonEmpty a
values = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int
n Int -> Text -> Text
`timesCommaSeparated` Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
where
n :: Int
n = NonEmpty a -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty a
values
timesCommaSeparated :: Int -> Text -> Text
timesCommaSeparated :: Int -> Text -> Text
timesCommaSeparated Int
n = Text -> [Text] -> Text
intercalate Text
"," ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
n
makeExpr :: TH.ExpQ -> [Token] -> TH.ExpQ
makeExpr :: ExpQ -> [Token] -> ExpQ
makeExpr ExpQ
fun [Token]
toks = do
Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
TH.infixE
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just [| uncurry $(fun) . second concat |])
([| (=<<) |])
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ [Token] -> ExpQ
go [Token]
toks)
where
go :: [Token] -> TH.ExpQ
go :: [Token] -> ExpQ
go [] = [| return (mempty, []) |]
go (Literal String
a:[Token]
xs) =
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ first (pack a <>) |]
([Token] -> ExpQ
go [Token]
xs)
go (Value String
a:[Token]
xs) =
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ first ("?" <>) . second ([toPersistValue $(reifyExp a)] :) |]
([Token] -> ExpQ
go [Token]
xs)
go (Values String
a:[Token]
xs) =
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ interpolateValues $(reifyExp a) |]
([Token] -> ExpQ
go [Token]
xs)
go (Rows String
a:[Token]
xs) =
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ interpolateRows $(reifyExp a) |]
([Token] -> ExpQ
go [Token]
xs)
go (ColumnName String
a:[Token]
xs) = do
Name
colN <- String -> Q Name
TH.newName String
"field"
Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
TH.infixE
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just [| getFieldName $(reifyExp a) |])
[| (>>=) |]
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ [PatQ] -> ExpQ -> ExpQ
TH.lamE [ Name -> PatQ
TH.varP Name
colN ] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ first ($(TH.varE colN) <>) |]
([Token] -> ExpQ
go [Token]
xs))
go (TableName String
a:[Token]
xs) = do
Name
typeN <- String -> Q (Maybe Name)
TH.lookupTypeName String
a Q (Maybe Name) -> (Maybe Name -> Q Name) -> Q Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Name
t -> Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
t
Maybe Name
Nothing -> String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Type not in scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
a
Name
tableN <- String -> Q Name
TH.newName String
"table"
Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
TH.infixE
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$
ExpQ -> ExpQ -> ExpQ
TH.appE
[| getTableName |]
(ExpQ -> TypeQ -> ExpQ
TH.sigE
[| error "record" |] (TypeQ -> ExpQ) -> TypeQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
(Name -> TypeQ
TH.conT Name
typeN)))
[| (>>=) |]
(ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just (ExpQ -> Maybe ExpQ) -> ExpQ -> Maybe ExpQ
forall a b. (a -> b) -> a -> b
$ [PatQ] -> ExpQ -> ExpQ
TH.lamE [ Name -> PatQ
TH.varP Name
tableN ] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
ExpQ -> ExpQ -> ExpQ
TH.appE
[| fmap $ first ($(TH.varE tableN) <>) |]
([Token] -> ExpQ
go [Token]
xs))
reifyExp :: String -> TH.Q TH.Exp
reifyExp :: String -> ExpQ
reifyExp String
s =
case String -> Either String Exp
parseExp String
s of
Left String
e -> String -> Q ()
TH.reportError String
e Q () -> ExpQ -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [| mempty |]
Right Exp
v -> Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
v
makeQQ :: TH.Q TH.Exp -> QuasiQuoter
makeQQ :: ExpQ -> QuasiQuoter
makeQQ ExpQ
x = (String -> ExpQ)
-> (String -> PatQ)
-> (String -> TypeQ)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
(ExpQ -> [Token] -> ExpQ
makeExpr ExpQ
x ([Token] -> ExpQ) -> (String -> [Token]) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [Token]
parseStr [])
(String -> String -> PatQ
forall a. HasCallStack => String -> a
error String
"Cannot use qc as a pattern")
(String -> String -> TypeQ
forall a. HasCallStack => String -> a
error String
"Cannot use qc as a type")
(String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"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 |]