{-# 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) = toPersistValue a :| []
instance (PersistField a, PersistField b) => ToRow (a, b) where
toRow (a, b) = toPersistValue a <| toRow (Single b)
instance (PersistField a, PersistField b, PersistField c) => ToRow (a, b, c) where
toRow (a, b, c) = toPersistValue a <| toRow (b, c)
instance (PersistField a, PersistField b, PersistField c, PersistField d) => ToRow (a, b, c, d) where
toRow (a, b, c, d) = toPersistValue a <| toRow (b, c, 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) = toPersistValue a <| toRow (b, c, d, e)
data Token
= Literal String
| Value String
| Values String
| Rows String
| TableName String
| ColumnName String
deriving Show
parseHaskell :: (String -> Token) -> String -> String -> [Token]
parseHaskell cons = go
where
go a [] = [Literal (reverse a)]
go a ('\\':x:xs) = go (x:a) xs
go a ['\\'] = go ('\\':a) []
go a ('}':xs) = cons (reverse a) : parseStr [] xs
go a (x:xs) = go (x:a) xs
parseStr :: String -> String -> [Token]
parseStr a [] = [Literal (reverse a)]
parseStr a ('\\':x:xs) = parseStr (x:a) xs
parseStr a ['\\'] = parseStr ('\\':a) []
parseStr a ('#':'{':xs) = Literal (reverse a) : parseHaskell Value [] xs
parseStr a ('%':'{':xs) = Literal (reverse a) : parseHaskell Values [] xs
parseStr a ('*':'{':xs) = Literal (reverse a) : parseHaskell Rows [] xs
parseStr a ('^':'{':xs) = Literal (reverse a) : parseHaskell TableName [] xs
parseStr a ('@':'{':xs) = Literal (reverse a) : parseHaskell ColumnName [] xs
parseStr a (x:xs) = parseStr (x:a) xs
interpolateValues :: PersistField a => NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateValues xs =
first (mkPlaceholders values <>) .
second (NonEmpty.toList values :)
where
values = NonEmpty.map toPersistValue xs
interpolateRows :: ToRow a => NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])
interpolateRows xs =
first (placeholders <>)
. second (values :)
where
rows :: NonEmpty (NonEmpty PersistValue)
rows = NonEmpty.map toRow xs
n = NonEmpty.length rows
placeholders = n `timesCommaSeparated` mkPlaceholders (NonEmpty.head rows)
values = List.concatMap NonEmpty.toList $ NonEmpty.toList rows
mkPlaceholders :: NonEmpty a -> Text
mkPlaceholders values = "(" <> n `timesCommaSeparated` "?" <> ")"
where
n = NonEmpty.length values
timesCommaSeparated :: Int -> Text -> Text
timesCommaSeparated n = intercalate "," . replicate n
makeExpr :: TH.ExpQ -> [Token] -> TH.ExpQ
makeExpr fun toks = do
TH.infixE
(Just [| uncurry $(fun) . second concat |])
([| (=<<) |])
(Just $ go toks)
where
go :: [Token] -> TH.ExpQ
go [] = [| return (mempty, []) |]
go (Literal a:xs) =
TH.appE
[| fmap $ first (pack a <>) |]
(go xs)
go (Value a:xs) =
TH.appE
[| fmap $ first ("?" <>) . second ([toPersistValue $(reifyExp a)] :) |]
(go xs)
go (Values a:xs) =
TH.appE
[| fmap $ interpolateValues $(reifyExp a) |]
(go xs)
go (Rows a:xs) =
TH.appE
[| fmap $ interpolateRows $(reifyExp a) |]
(go xs)
go (ColumnName a:xs) = do
colN <- TH.newName "field"
TH.infixE
(Just [| getFieldName $(reifyExp a) |])
[| (>>=) |]
(Just $ TH.lamE [ TH.varP colN ] $
TH.appE
[| fmap $ first ($(TH.varE colN) <>) |]
(go xs))
go (TableName a:xs) = do
typeN <- TH.lookupTypeName a >>= \case
Just t -> return t
Nothing -> fail $ "Type not in scope: " ++ show a
tableN <- TH.newName "table"
TH.infixE
(Just $
TH.appE
[| getTableName |]
(TH.sigE
[| error "record" |] $
(TH.conT typeN)))
[| (>>=) |]
(Just $ TH.lamE [ TH.varP tableN ] $
TH.appE
[| fmap $ first ($(TH.varE tableN) <>) |]
(go xs))
reifyExp :: String -> TH.Q TH.Exp
reifyExp s =
case parseExp s of
Left e -> TH.reportError e >> [| mempty |]
Right v -> return v
makeQQ :: TH.Q TH.Exp -> QuasiQuoter
makeQQ x = QuasiQuoter
(makeExpr x . parseStr [])
(error "Cannot use qc as a pattern")
(error "Cannot use qc as a type")
(error "Cannot use qc as a dec")
sqlQQ :: QuasiQuoter
sqlQQ = makeQQ [| rawSql |]
executeQQ :: QuasiQuoter
executeQQ = makeQQ [| rawExecute |]
executeCountQQ :: QuasiQuoter
executeCountQQ = makeQQ [| rawExecuteCount |]
queryQQ :: QuasiQuoter
queryQQ = makeQQ [| rawQuery |]
queryResQQ :: QuasiQuoter
queryResQQ = makeQQ [| rawQueryRes |]