{-|
@since 2.9.0

Module: module Database.Persist.Sql.Raw.QQ
Description: QuasiQuoters for performing raw sql queries

This module exports convenient QuasiQuoters to perform raw SQL queries.
All QuasiQuoters follow the same pattern and are analogous to the similar named
functions exported from 'Database.Persist.Sql.Raw'. Neither the quoted
function's behaviour, nor it's return value is altered during the translation
and all documentation provided with it holds.

The QuasiQuoters in this module perform a simple substitution on the query text,
that allows value substitutions, table name substitutions as well as column name
substitutions.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Database.Persist.Sql.Raw.QQ (
      -- * Sql QuasiQuoters
      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")

-- | QuasiQuoter for performing raw sql queries, analoguous to
-- 'Database.Persist.Sql.Raw.rawSql'
--
-- This and the following are convenient QuasiQuoters to perform raw SQL
-- queries.  They each follow the same pattern and are analogous to
-- the similarly named @raw@ functions.  Neither the quoted function's
-- behaviour, nor it's return value is altered during the translation and
-- all documentation provided with it holds.
--
-- These QuasiQuoters perform a simple substitution on the query text, that
-- allows value substitutions, table name substitutions as well as column name
-- substitutions.
--
-- Here is a small example:
--
-- Given the following simple model:
--
-- @
-- Category
--   rgt Int default=0
--   lft Int default=0
--   nam Text
-- @
--
-- We can now execute this raw query:
--
-- @
-- let lft = 10 :: `Int`
--     rgt = 20 :: `Int`
--     width = rgt `-` lft
--     nams = "first" `:|` ["second", "third"]
--  in [sqlQQ|
--       DELETE FROM ^{Category} WHERE \@{CategoryLft} BETWEEN \#{lft} AND \#{rgt};
--       UPDATE category SET \@{CategoryRgt} = \@{CategoryRgt} - \#{width} WHERE \@{CategoryRgt} > \#{rgt};
--       UPDATE category SET \@{CategoryLft} = \@{CategoryLft} - \#{width} WHERE \@{CategoryLft} > \#{rgt};
--       SELECT ?? FROM ^{Category} WHERE ^{Category}.\@{CategoryNam} IN %{nams};
--       INSERT INTO ^{Category}(\@{CategoryNam}) VALUES *{`Single` `<$>` nams};
--     |]
-- @
--
-- - @^{TableName}@ looks up the table's name and escapes it
-- - @\@{ColumnName}@ looks up the column's name and properly escapes it
-- - @#{value}@ inserts the value via the usual parameter substitution mechanism
-- - @%{values}@ inserts comma separated values (of a 'Data.List.NonEmpty.NonEmpty' list) (since 2.9.1)
-- - @*{rows}@ inserts a 'Data.List.NonEmpty.NonEmpty' list of tuples for use with a multirow @INSERT@ statement (since 2.9.2)
--
-- @since 2.9.0
sqlQQ :: QuasiQuoter
sqlQQ :: QuasiQuoter
sqlQQ = ExpQ -> QuasiQuoter
makeQQ [| rawSql |]

-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecute'
--
-- @since 2.9.0
executeQQ :: QuasiQuoter
executeQQ :: QuasiQuoter
executeQQ = ExpQ -> QuasiQuoter
makeQQ [| rawExecute |]

-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecuteCount'
--
-- @since 2.9.0
executeCountQQ :: QuasiQuoter
executeCountQQ :: QuasiQuoter
executeCountQQ = ExpQ -> QuasiQuoter
makeQQ [| rawExecuteCount |]

-- | Analoguous to 'Database.Persist.Sql.Raw.rawQuery'
--
-- @since 2.9.0
queryQQ :: QuasiQuoter
queryQQ :: QuasiQuoter
queryQQ = ExpQ -> QuasiQuoter
makeQQ [| rawQuery |]

-- | Analoguous to 'Database.Persist.Sql.Raw.rawQueryRes'
--
-- @since 2.9.0
queryResQQ :: QuasiQuoter
queryResQQ :: QuasiQuoter
queryResQQ = ExpQ -> QuasiQuoter
makeQQ [| rawQueryRes |]