persistent-qq 2.9.1.1 → 2.9.2

raw patch · 5 files changed

+103/−45 lines, 5 filesdep +bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• persistent-qq.cabal +2/−1
• src/Database/Persist/Sql/Raw/QQ.hs +75/−24
• test/PersistentTestModels.hs +1/−0
• test/Spec.hs +21/−20

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

@@ -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 <http://www.stackage.org/package/persistent>. category:       Database, Yesod@@ -70,4 +70,5 @@     , template-haskell     , text     , unliftio+    , bytestring   default-language: Haskell2010

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

@@ -102,6 +102,7 @@     !yes Int     ~no Int     def Int+ |]  deriving instance Show (BackendKey backend) => Show (PetGeneric backend)

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