persistent-qq 2.12.0.3 → 2.12.0.4
raw patch · 5 files changed
+76/−53 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +6/−0
- persistent-qq.cabal +2/−1
- src/Database/Persist/Sql/Raw/QQ.hs +26/−52
- test/CodeGenTest.hs +40/−0
- test/Spec.hs +2/−0
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for persistent-qq +## 2.12.0.4++* Improve compile-time performance of generated code, especially when building with -O2.+ Previously, the test suite took 1:16 to build with -O2, and after this patch,+ it only takes 5s. [#1434](https://github.com/yesodweb/persistent/pull/1434)+ ## 2.12.0.3 * Require `persistent-2.14` in tests
persistent-qq.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: persistent-qq-version: 2.12.0.3+version: 2.12.0.4 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@@ -43,6 +43,7 @@ PersistentTestModels PersistTestPetCollarType PersistTestPetType+ CodeGenTest hs-source-dirs: test ghc-options: -Wall
src/Database/Persist/Sql/Raw/QQ.hs view
@@ -34,7 +34,9 @@ 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.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@@ -90,19 +92,20 @@ 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 (' ':' ': xs)= parseStr a (' ' : xs)+parseStr a ('\n' : xs) = parseStr a xs parseStr a (x:xs) = parseStr (x:a) xs -interpolateValues :: PersistField a => NonEmpty a -> (Text, [[PersistValue]]) -> (Text, [[PersistValue]])+interpolateValues :: PersistField a => NonEmpty a -> (String, [[PersistValue]]) -> (String, [[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 :)+interpolateRows :: ToRow a => NonEmpty a -> (String, [[PersistValue]]) -> (String, [[PersistValue]])+interpolateRows xs (sql, vals) =+ (placeholders <> sql, values : vals) where rows :: NonEmpty (NonEmpty PersistValue) rows = NonEmpty.map toRow xs@@ -111,66 +114,37 @@ placeholders = n `timesCommaSeparated` mkPlaceholders (NonEmpty.head rows) values = List.concatMap NonEmpty.toList $ NonEmpty.toList rows -mkPlaceholders :: NonEmpty a -> Text+mkPlaceholders :: NonEmpty a -> String mkPlaceholders values = "(" <> n `timesCommaSeparated` "?" <> ")" where n = NonEmpty.length values -timesCommaSeparated :: Int -> Text -> Text+timesCommaSeparated :: Int -> String -> String 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)-+ [| do+ (sql, vals) <- $(go toks)+ $(fun) (Text.pack sql) (concat vals) |] where go :: [Token] -> TH.ExpQ- go [] = [| return (mempty, []) |]+ go [] =+ [| return (mempty :: String, []) |] 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)+ [| first (a <>) <$> $(go xs) |]+ go (Value a:xs) = do+ [| (\(str, vals) -> ("?" <> str, [toPersistValue $(reifyExp a)] : vals)) <$> ($(go xs)) |] go (Values a:xs) =- TH.appE- [| fmap $ interpolateValues $(reifyExp a) |]- (go xs)+ [| 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))+ [| interpolateRows $(reifyExp a) <$> $(go xs) |]+ go (ColumnName a:xs) =+ [| getFieldName $(reifyExp a) >>= \field ->+ first (Text.unpack field <>) <$> $(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))+ [| getTableName (error "record" :: $(TH.conT (TH.mkName a))) >>= \table ->+ first (Text.unpack table <>) <$> $(go xs) |] reifyExp :: String -> TH.Q TH.Exp reifyExp s =
+ test/CodeGenTest.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++module CodeGenTest (query0, spec) where++import Database.Persist.Sql+import Test.Hspec+import Database.Persist.Sql.Raw.QQ+import PersistentTestModels+import Control.Monad.Logger (LoggingT)+import Control.Monad.Trans.Resource+import Data.Text (Text)+import Control.Monad.Reader++spec :: (forall a. SqlPersistT (LoggingT (ResourceT IO)) a -> IO a) -> Spec+spec db = describe "CodeGenTest" $ do+ it "works" $ do+ _ <- db $ mapReaderT liftIO query0+ pure ()++query0 :: SqlPersistT IO [(Single Text, Single Int, Single (Maybe Text))]+query0 = --+ [sqlQQ|+ select+ ^{Person}.@{PersonName}, ^{Person}.@{PersonAge}, ^{Person}.@{PersonColor}+ from ^{Person}+ where @{PersonAge} =+ #{int} ++ #{int} ++ #{int} ++ #{int} ++ #{int} ++ #{int} ++ 0+ |]+ where+ int = 1 :: Int
test/Spec.hs view
@@ -19,6 +19,7 @@ import Database.Persist.Sqlite import PersistTestPetType import PersistentTestModels+import qualified CodeGenTest main :: IO () main = hspec spec@@ -40,6 +41,7 @@ spec :: Spec spec = describe "persistent-qq" $ do+ CodeGenTest.spec db it "sqlQQ/?-?" $ db $ do ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |] liftIO $ ret @?= [Single (4::Int)]