diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-qq +## 2.9.2 + +* Add interpolation support for multirow VALUES syntax (`*{rows}`) [#1111](https://github.com/yesodweb/persistent/pull/1111) + ## 2.9.1.1 * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) diff --git a/persistent-qq.cabal b/persistent-qq.cabal --- a/persistent-qq.cabal +++ b/persistent-qq.cabal @@ -7,7 +7,7 @@ -- hash: bef2b585278826bc60fe813d4918833dc06cec43f2a8e4567190448ccfdee163 name: persistent-qq -version: 2.9.1.1 +version: 2.9.2 synopsis: Provides a quasi-quoter for raw SQL for persistent description: Please see README and API docs at . category: Database, Yesod @@ -70,4 +70,5 @@ , template-haskell , text , unliftio + , bytestring default-language: Haskell2010 diff --git a/src/Database/Persist/Sql/Raw/QQ.hs b/src/Database/Persist/Sql/Raw/QQ.hs --- a/src/Database/Persist/Sql/Raw/QQ.hs +++ b/src/Database/Persist/Sql/Raw/QQ.hs @@ -25,13 +25,16 @@ , sqlQQ , executeQQ , executeCountQQ + , ToRow(..) ) where import Prelude import Control.Arrow (first, second) import Control.Monad.Reader (ask) -import qualified Data.List.NonEmpty (toList) -import Data.Text (pack, unpack, intercalate) +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 @@ -42,17 +45,36 @@ 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 + where go a [] = [Literal (reverse a)] go a ('\\':x:xs) = go (x:a) xs go a ['\\'] = go ('\\':a) [] @@ -65,10 +87,38 @@ 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 @@ -76,7 +126,7 @@ ([| (=<<) |]) (Just $ go toks) - where + where go :: [Token] -> TH.ExpQ go [] = [| return (mempty, []) |] go (Literal a:xs) = @@ -89,12 +139,12 @@ (go xs) go (Values a:xs) = TH.appE - [| let a' = Data.List.NonEmpty.toList $(reifyExp a) in - fmap $ - first (("(" <> intercalate ", " (replicate (length a') "?") <> ")") <>) . - second (map toPersistValue a' :) - |] + [| 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 @@ -154,33 +204,34 @@ -- -- @ -- Category --- rgt Int --- lft Int +-- 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"] +-- 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}; +-- 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 and @%{values}@ --- inserts comma separated values (of a 'Data.List.NonEmpty.NonEmpty' list). +-- - @^{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 --- @%{values}@ was added with 2.9.1 sqlQQ :: QuasiQuoter sqlQQ = makeQQ [| rawSql |] diff --git a/test/PersistentTestModels.hs b/test/PersistentTestModels.hs --- a/test/PersistentTestModels.hs +++ b/test/PersistentTestModels.hs @@ -102,6 +102,7 @@ !yes Int ~no Int def Int + |] deriving instance Show (BackendKey backend) => Show (PetGeneric backend) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,15 +2,16 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} -import Control.Monad.Logger +import Control.Monad.Logger (LoggingT, runLoggingT) import Control.Monad.Trans.Resource import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (sort) import Data.Text (Text) -import System.Log.FastLogger +import System.Log.FastLogger (fromLogStr) import Test.Hspec import Test.HUnit ((@?=)) -import UnliftIO import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ @@ -19,33 +20,25 @@ import PersistentTestModels main :: IO () -main = hspec specs +main = hspec spec _debugOn :: Bool _debugOn = False -sqlite_database_file :: Text -sqlite_database_file = "testdb.sqlite3" -sqlite_database :: SqliteConnectionInfo -sqlite_database = mkSqliteConnectionInfo sqlite_database_file - -runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () +runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) a -> m a runConn f = do - let debugPrint = _debugOn - let printDebug = if debugPrint then print . fromLogStr else void . return + let printDebug = when _debugOn . B.putStrLn . fromLogStr flip runLoggingT (\_ _ _ s -> printDebug s) $ do - _ <- withSqlitePoolInfo sqlite_database 1 $ runSqlPool f - return () + withSqliteConn ":memory:" $ runSqlConn f -db :: SqlPersistT (LoggingT (ResourceT IO)) () -> IO () +db :: SqlPersistT (LoggingT (ResourceT IO)) a -> IO a db actions = do runResourceT $ runConn $ do - runMigration testMigrate - actions - transactionUndo + _ <- runMigrationSilent testMigrate + actions <* transactionUndo -specs :: Spec -specs = describe "persistent-qq" $ do +spec :: Spec +spec = describe "persistent-qq" $ do it "sqlQQ/?-?" $ db $ do ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |] liftIO $ ret @?= [Single (4::Int)] @@ -153,3 +146,11 @@ |] liftIO $ ret @?= [ (Entity p1k p1) , (Entity p3k p3) ] + + it "sqlQQ/rows syntax" $ do + let rows :: NonEmpty (Text, Int) + rows = ("Mathias", 23) :| ("Norbert", 44) : ("Cassandra", 19) : [] + db $ do + [executeQQ|INSERT INTO ^{Person} (@{PersonName}, @{PersonAge}) VALUES *{rows}|] + map unSingle <$> [sqlQQ|SELECT @{PersonName} FROM ^{Person} ORDER BY @{PersonName}|] + `shouldReturn` sort ["Mathias", "Norbert", "Cassandra" :: Text]