{-|
@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)
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")

-- | 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 |]