From 41bb51c43cb7c2f50854ffcd3638407d633a84c7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 20:35:03 -0600 Subject: [PATCH 1/8] Test suite compiles --- persistent-mongoDB/test/EmbedTestMongo.hs | 1 + .../test/EntityEmbedTestMongo.hs | 1 + persistent-mongoDB/test/MongoInit.hs | 4 +- persistent-mongoDB/test/main.hs | 1 + .../test/InsertDuplicateUpdate.hs | 1 + persistent-mysql/test/main.hs | 1 + .../test/EquivalentTypeTestPostgres.hs | 1 + persistent-postgresql/test/main.hs | 1 + persistent-redis/tests/basic-test.hs | 7 +- persistent-sqlite/test/SqliteInit.hs | 14 +- persistent-sqlite/test/main.hs | 1 + persistent-template/ChangeLog.md | 4 + persistent-template/Database/Persist/TH.hs | 97 ++++++++++++- persistent-template/persistent-template.cabal | 6 +- persistent-template/test/main.hs | 1 + persistent-test/src/CustomPersistFieldTest.hs | 2 +- .../src/CustomPrimaryKeyReferenceTest.hs | 1 + persistent-test/src/DataTypeTest.hs | 1 + persistent-test/src/EmbedOrderTest.hs | 1 + persistent-test/src/EmbedTest.hs | 1 + persistent-test/src/EmptyEntityTest.hs | 1 + persistent-test/src/EntityEmbedTest.hs | 1 + persistent-test/src/EquivalentTypeTest.hs | 1 + persistent-test/src/HtmlTest.hs | 1 + persistent-test/src/LargeNumberTest.hs | 1 + persistent-test/src/MaxLenTest.hs | 1 + .../src/MigrationColumnLengthTest.hs | 1 + .../src/MigrationIdempotencyTest.hs | 1 + persistent-test/src/MigrationOnlyTest.hs | 1 + persistent-test/src/MigrationTest.hs | 1 + persistent-test/src/PersistUniqueTest.hs | 1 + persistent-test/src/PrimaryTest.hs | 2 + persistent-test/src/Recursive.hs | 1 + persistent-test/src/RenameTest.hs | 4 +- persistent-test/src/TransactionLevelTest.hs | 3 +- persistent-test/src/UniqueTest.hs | 1 + persistent/ChangeLog.md | 4 + persistent/Database/Persist/Class.hs | 4 + .../Database/Persist/Class/PersistEntity.hs | 4 + .../Database/Persist/Class/PersistUnique.hs | 136 ++++++++++++++---- persistent/persistent.cabal | 2 +- 41 files changed, 260 insertions(+), 59 deletions(-) diff --git a/persistent-mongoDB/test/EmbedTestMongo.hs b/persistent-mongoDB/test/EmbedTestMongo.hs index 4b5fff1bd..f141931c4 100644 --- a/persistent-mongoDB/test/EmbedTestMongo.hs +++ b/persistent-mongoDB/test/EmbedTestMongo.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-mongoDB/test/EntityEmbedTestMongo.hs b/persistent-mongoDB/test/EntityEmbedTestMongo.hs index 7066440a8..e2d1cb9e8 100644 --- a/persistent-mongoDB/test/EntityEmbedTestMongo.hs +++ b/persistent-mongoDB/test/EntityEmbedTestMongo.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} diff --git a/persistent-mongoDB/test/MongoInit.hs b/persistent-mongoDB/test/MongoInit.hs index a5ce8dee8..20e711274 100644 --- a/persistent-mongoDB/test/MongoInit.hs +++ b/persistent-mongoDB/test/MongoInit.hs @@ -14,8 +14,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module MongoInit ( - isTravis - , BackendMonad + BackendMonad , runConn , MonadIO , persistSettings @@ -71,7 +70,6 @@ import qualified Data.ByteString as BS import Data.Text (Text) import Database.Persist import Database.Persist.TH () -import System.Environment (getEnvironment) import Database.Persist.Sql (PersistFieldSql(..)) import Database.Persist.TH (mkPersistSettings) diff --git a/persistent-mongoDB/test/main.hs b/persistent-mongoDB/test/main.hs index c317f3e32..d8c2ec6c7 100644 --- a/persistent-mongoDB/test/main.hs +++ b/persistent-mongoDB/test/main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# language RankNTypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index bf02618e4..641eea101 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} diff --git a/persistent-mysql/test/main.hs b/persistent-mysql/test/main.hs index bbc19a102..d7f7a6bf3 100644 --- a/persistent-mysql/test/main.hs +++ b/persistent-mysql/test/main.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} diff --git a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs index 9a72948ef..776957612 100644 --- a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs +++ b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 9f9203f87..257e52880 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} diff --git a/persistent-redis/tests/basic-test.hs b/persistent-redis/tests/basic-test.hs index 4b28a5bb2..d749de211 100644 --- a/persistent-redis/tests/basic-test.hs +++ b/persistent-redis/tests/basic-test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-} {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Main where import qualified Database.Redis as R @@ -12,7 +13,7 @@ import Control.Monad.IO.Class (liftIO) import Data.Text (Text, pack, unpack) let redisSettings = mkPersistSettings (ConT ''RedisBackend) - in share [mkPersist redisSettings] [persistLowerCase| + in share [mkPersist redisSettings] [persistLowerCase| Person name String age Int @@ -34,7 +35,7 @@ mkKey s = case keyFromValues [PersistText s] of Left a -> fail (unpack a) main :: IO () -main = +main = withRedisConn redisConf $ runRedisPool $ do _ <- liftIO $ print "Inserting..." s <- insert $ Person "Test" 12 @@ -45,4 +46,4 @@ main = g <- get key :: RedisT IO (Maybe Person) liftIO $ print g delete s - return () \ No newline at end of file + return () diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 8769e3ea2..10152ff35 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -46,6 +46,7 @@ module SqliteInit ( , truncateUTCTime , arbText , liftA2 + , MonadFail ) where import Init @@ -57,12 +58,9 @@ import Init ) -- re-exports -import Control.Applicative (liftA2) import Test.QuickCheck.Instances () -import Data.Char (generalCategory, GeneralCategory(..)) -import qualified Data.Text as T -import Data.Fixed (Pico,Micro) -import Data.Time +-- import Data.Fixed (Pico,Micro) +-- import Data.Time import Control.Applicative as A ((<$>), (<*>)) import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) @@ -72,13 +70,11 @@ import Test.Hspec -- testing import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) -import Test.QuickCheck import qualified Data.ByteString as BS -import Data.Text (Text, unpack) +import Data.Text (Text) import Database.Persist import Database.Persist.TH () -import System.Environment (getEnvironment) import Control.Monad.Logger import Control.Monad.Trans.Resource (ResourceT, runResourceT) @@ -86,8 +82,6 @@ import Database.Persist.Sql import System.Log.FastLogger (fromLogStr) import Database.Persist.Sqlite -import Data.IORef (newIORef, IORef, writeIORef, readIORef) -import System.IO.Unsafe (unsafePerformIO) import Control.Monad (unless, (>=>)) import Control.Monad.IO.Unlift (MonadUnliftIO) diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs index 313e5e87d..202b6a8ab 100644 --- a/persistent-sqlite/test/main.hs +++ b/persistent-sqlite/test/main.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} diff --git a/persistent-template/ChangeLog.md b/persistent-template/ChangeLog.md index e9969ec87..bb2bef3fd 100644 --- a/persistent-template/ChangeLog.md +++ b/persistent-template/ChangeLog.md @@ -1,3 +1,7 @@ +## 2.7.0 + +* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [TODO: add issue number]() + ## 2.6.0 * [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails * [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change `Unique` derive `Show` diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 5dfdcb0b4..a53529f9a 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -47,11 +47,16 @@ module Database.Persist.TH , packPTH , lensPTH , parseReferences + , AtLeastOneUniqueKey(..) + , OnlyOneUniqueKey(..) ) where import Prelude hiding ((++), take, concat, splitAt, exp) + +import qualified Data.List.NonEmpty as NEL import Database.Persist import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql) +-- import Database.Persist.Class import Database.Persist.Quasi import Language.Haskell.TH.Lib ( #if MIN_VERSION_template_haskell(2,11,0) @@ -61,7 +66,7 @@ import Language.Haskell.TH.Lib ( import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char (toLower, toUpper) -import Control.Monad (forM, (<=<), mzero) +import Control.Monad (forM, unless, (<=<), mzero) import qualified System.IO as SIO import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix) import qualified Data.Text as T @@ -87,6 +92,8 @@ import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) import GHC.Generics (Generic) import qualified Data.Text.Encoding as TE +import GHC.TypeLits + -- | This special-cases "type_" and strips out its underscore. When -- used for JSON serialization and deserialization, it works around -- @@ -116,14 +123,14 @@ persistFileWith :: PersistSettings -> FilePath -> Q Exp persistFileWith ps fp = persistManyFileWith ps [fp] -- | Same as 'persistFileWith', but uses several external files instead of --- one. Splitting your Persistent definitions into multiple modules can +-- one. Splitting your Persistent definitions into multiple modules can -- potentially dramatically speed up compile times. -- -- The recommended file extension is @.persistentmodels@. -- -- ==== __Examples__ -- --- Split your Persistent definitions into multiple files (@models1@, @models2@), +-- Split your Persistent definitions into multiple files (@models1@, @models2@), -- then create a new module for each new file and run 'mkPersist' there: -- -- @ @@ -145,13 +152,13 @@ persistFileWith ps fp = persistManyFileWith ps [fp] -- -- Migrate.hs -- 'share' -- ['mkMigrate' "migrateAll"] --- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) +-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) -- @ -- -- Tip: To get the same import behavior as if you were declaring all your models in -- one file, import your new files @as Name@ into another file, then export @module Name@. -- --- This approach may be used in the future to reduce memory usage during compilation, +-- This approach may be used in the future to reduce memory usage during compilation, -- but so far we've only seen mild reductions. -- -- See and @@ -367,7 +374,8 @@ mkPersist mps ents' = do x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents y <- fmap mconcat $ mapM (mkEntity entMap mps) ents z <- fmap mconcat $ mapM (mkJSON mps) ents - return $ mconcat [x, y, z] + uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents + return $ mconcat [x, y, z, uniqueKeyInstances] where ents = map fixEntityDef ents' entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) ents @@ -1106,6 +1114,83 @@ mkEntity entMap mps t = do genDataType = genericDataType mps entName backendT entName = entityHaskell t +mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] +mkUniqueKeyInstances mps t = do + undecidableInstancesEnabled <- isExtEnabled UndecidableInstances + unless undecidableInstancesEnabled . fail + $ "Generating Persistent entities now requires the 'UndecidableInstances' " + <> "language extension. Please enable it in your file by copy/pasting " + <> "this line into the top of your file: \n\n" + <> "{-# LANGUAGE UndecidableInstances #-}" + case entityUniques t of + [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne + [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey + (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey + where + requireUniquesPName = mkName "requireUniquesP" + onlyUniquePName = mkName "onlyUniqueP" + typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx + typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx + + withPersistStoreWriteCxt = + if mpsGeneric mps + then do + write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |] + pure [write] + else do + pure [] + + typeErrorNoneCtx = do + tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + typeErrorMultipleCtx = do + tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + mkOnlyUniqueError :: Q Cxt -> Q [Dec] + mkOnlyUniqueError mkCtx = do + ctx <- mkCtx + let impl = mkImpossible onlyUniquePName + pure [instanceD ctx onlyOneUniqueKeyClass impl] + + mkImpossible name = + [ FunD name + [ Clause + [ WildP ] + (NormalB + (VarE (mkName "error") `AppE` LitE (StringL "impossible")) + ) + [] + ] + ] + + typeErrorAtLeastOne :: Q [Dec] + typeErrorAtLeastOne = do + let impl = mkImpossible requireUniquesPName + cxt <- typeErrorMultipleCtx + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + singleUniqueKey :: Q [Dec] + singleUniqueKey = do + expr <- [e|\p -> head (persistUniqueKeysP p)|] + let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt onlyOneUniqueKeyClass impl] + + atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType + onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType + + atLeastOneKey :: Q [Dec] + atLeastOneKey = do + expr <- [e|\p -> NEL.fromList (persistUniqueKeysP p)|] + let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + genDataType = genericDataType mps (entityHaskell t) backendT + + entityText :: EntityDef -> Text entityText = unHaskellName . entityHaskell diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal index 54199de10..5b139edd2 100644 --- a/persistent-template/persistent-template.cabal +++ b/persistent-template/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 2.6.0 +version: 2.7.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -15,9 +15,9 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: test/main.hs ChangeLog.md README.md library - build-depends: base >= 4.6 && < 5 + build-depends: base >= 4.6 && < 5 , template-haskell - , persistent >= 2.5 && < 3 + , persistent >= 2.10 && < 3 , monad-control >= 0.2 && < 1.1 , bytestring >= 0.9 , text >= 0.5 diff --git a/persistent-template/test/main.hs b/persistent-template/test/main.hs index 7558c24b6..365add26a 100644 --- a/persistent-template/test/main.hs +++ b/persistent-template/test/main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/persistent-test/src/CustomPersistFieldTest.hs b/persistent-test/src/CustomPersistFieldTest.hs index 5a266dd56..de957d214 100644 --- a/persistent-test/src/CustomPersistFieldTest.hs +++ b/persistent-test/src/CustomPersistFieldTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# language RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,7 +16,6 @@ module CustomPersistFieldTest (specsWith, customFieldMigrate) where import Init import CustomPersistField -import Control.Monad.Fail share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "customFieldMigrate"] [persistLowerCase| BlogPost diff --git a/persistent-test/src/CustomPrimaryKeyReferenceTest.hs b/persistent-test/src/CustomPrimaryKeyReferenceTest.hs index 2cee312e9..97baa0768 100644 --- a/persistent-test/src/CustomPrimaryKeyReferenceTest.hs +++ b/persistent-test/src/CustomPrimaryKeyReferenceTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-test/src/DataTypeTest.hs b/persistent-test/src/DataTypeTest.hs index cadcf1069..a9be518fc 100644 --- a/persistent-test/src/DataTypeTest.hs +++ b/persistent-test/src/DataTypeTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE RankNTypes #-} diff --git a/persistent-test/src/EmbedOrderTest.hs b/persistent-test/src/EmbedOrderTest.hs index 02822cd18..f9b6923bd 100644 --- a/persistent-test/src/EmbedOrderTest.hs +++ b/persistent-test/src/EmbedOrderTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-} diff --git a/persistent-test/src/EmbedTest.hs b/persistent-test/src/EmbedTest.hs index b7f35c142..51bc596bb 100644 --- a/persistent-test/src/EmbedTest.hs +++ b/persistent-test/src/EmbedTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/persistent-test/src/EmptyEntityTest.hs b/persistent-test/src/EmptyEntityTest.hs index 11360e522..ac0afa430 100644 --- a/persistent-test/src/EmptyEntityTest.hs +++ b/persistent-test/src/EmptyEntityTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/persistent-test/src/EntityEmbedTest.hs b/persistent-test/src/EntityEmbedTest.hs index 229d5d980..1b7a03dc7 100644 --- a/persistent-test/src/EntityEmbedTest.hs +++ b/persistent-test/src/EntityEmbedTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} diff --git a/persistent-test/src/EquivalentTypeTest.hs b/persistent-test/src/EquivalentTypeTest.hs index c4e43991c..ffc644a86 100644 --- a/persistent-test/src/EquivalentTypeTest.hs +++ b/persistent-test/src/EquivalentTypeTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/persistent-test/src/HtmlTest.hs b/persistent-test/src/HtmlTest.hs index e3bf7c572..76121adda 100644 --- a/persistent-test/src/HtmlTest.hs +++ b/persistent-test/src/HtmlTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} module HtmlTest (specsWith, cleanDB, htmlMigrate) where diff --git a/persistent-test/src/LargeNumberTest.hs b/persistent-test/src/LargeNumberTest.hs index 05cdc7399..006cee552 100644 --- a/persistent-test/src/LargeNumberTest.hs +++ b/persistent-test/src/LargeNumberTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} diff --git a/persistent-test/src/MaxLenTest.hs b/persistent-test/src/MaxLenTest.hs index 89849ef59..61bd5672e 100644 --- a/persistent-test/src/MaxLenTest.hs +++ b/persistent-test/src/MaxLenTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-} module MaxLenTest (specsWith, maxlenMigrate) where diff --git a/persistent-test/src/MigrationColumnLengthTest.hs b/persistent-test/src/MigrationColumnLengthTest.hs index c441fe4dc..f007df1c5 100644 --- a/persistent-test/src/MigrationColumnLengthTest.hs +++ b/persistent-test/src/MigrationColumnLengthTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} diff --git a/persistent-test/src/MigrationIdempotencyTest.hs b/persistent-test/src/MigrationIdempotencyTest.hs index 7d511b264..519f3266f 100644 --- a/persistent-test/src/MigrationIdempotencyTest.hs +++ b/persistent-test/src/MigrationIdempotencyTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-test/src/MigrationOnlyTest.hs b/persistent-test/src/MigrationOnlyTest.hs index 74e65d728..2ebe390e2 100644 --- a/persistent-test/src/MigrationOnlyTest.hs +++ b/persistent-test/src/MigrationOnlyTest.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-test/src/MigrationTest.hs b/persistent-test/src/MigrationTest.hs index b06d54a2d..4005118dd 100644 --- a/persistent-test/src/MigrationTest.hs +++ b/persistent-test/src/MigrationTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-test/src/PersistUniqueTest.hs b/persistent-test/src/PersistUniqueTest.hs index 480457130..43240877c 100644 --- a/persistent-test/src/PersistUniqueTest.hs +++ b/persistent-test/src/PersistUniqueTest.hs @@ -1,5 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/persistent-test/src/PrimaryTest.hs b/persistent-test/src/PrimaryTest.hs index 1c60ba6c3..1d5b2a08b 100644 --- a/persistent-test/src/PrimaryTest.hs +++ b/persistent-test/src/PrimaryTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -8,6 +9,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} + module PrimaryTest where import Init diff --git a/persistent-test/src/Recursive.hs b/persistent-test/src/Recursive.hs index 652ea9661..01c89188c 100644 --- a/persistent-test/src/Recursive.hs +++ b/persistent-test/src/Recursive.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent-test/src/RenameTest.hs b/persistent-test/src/RenameTest.hs index a66a59c06..97935111c 100644 --- a/persistent-test/src/RenameTest.hs +++ b/persistent-test/src/RenameTest.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,10 +13,11 @@ {-# LANGUAGE TypeFamilies #-} module RenameTest where +import Init + import Data.Time (getCurrentTime, Day, UTCTime(..)) import qualified Data.Map as Map import qualified Data.Text as T -import Init -- persistent used to not allow types with an "Id" suffix -- this verifies that the issue is fixed diff --git a/persistent-test/src/TransactionLevelTest.hs b/persistent-test/src/TransactionLevelTest.hs index 1d853752b..66f4b6f6e 100644 --- a/persistent-test/src/TransactionLevelTest.hs +++ b/persistent-test/src/TransactionLevelTest.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/persistent-test/src/UniqueTest.hs b/persistent-test/src/UniqueTest.hs index ec5f24279..e142da4ed 100644 --- a/persistent-test/src/UniqueTest.hs +++ b/persistent-test/src/UniqueTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 89d3a2634..8595134b2 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent +## 2.10.0 + +* Added two type classes `OnlyOneUniqueKey` and `AtLeastOneUniqueKey`. These classes are used as constraints on functions that expect a certain amount of unique keys. They are defined automatically as part of the `persistent-template`'s generation. [TODO: add issue number]() + ## 2.9.2 * Add documentation for the `Migration` type and some helpers. [#860](https://github.com/yesodweb/persistent/pull/860) diff --git a/persistent/Database/Persist/Class.hs b/persistent/Database/Persist/Class.hs index 2c61c7df3..2c407dc61 100644 --- a/persistent/Database/Persist/Class.hs +++ b/persistent/Database/Persist/Class.hs @@ -91,6 +91,10 @@ module Database.Persist.Class , PersistUnique , PersistUniqueRead (..) , PersistUniqueWrite (..) + , OnlyOneUniqueKey (..) + , AtLeastOneUniqueKey (..) + , NoUniqueKeysError + , MultipleUniqueKeysError , getByValue , insertBy , insertUniqueEntity diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index cabe6ccae..6cfcaaf8c 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -21,6 +21,7 @@ module Database.Persist.Class.PersistEntity -- * PersistField based on other typeclasses , toPersistValueJSON, fromPersistValueJSON , toPersistValueEnum, fromPersistValueEnum + , persistUniqueKeysP ) where import Database.Persist.Types.Base @@ -102,6 +103,9 @@ class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) fieldLens :: EntityField record field -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) + persistUniqueKeysP :: proxy record -> [Unique record] + persistUniqueKeysP _ = persistUniqueKeys (undefined :: record) + type family BackendSpecificUpdate backend record -- | Updating a database entity. diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index 474ba8b58..ca788d2b1 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -1,20 +1,26 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, ConstraintKinds #-} +{-# LANGUAGE TypeOperators, DataKinds #-} module Database.Persist.Class.PersistUnique - (PersistUniqueRead(..) - ,PersistUniqueWrite(..) - ,getByValue - ,insertBy - ,insertUniqueEntity - ,replaceUnique - ,checkUnique - ,onlyUnique - ,defaultPutMany - ,persistUniqueKeyValues + ( PersistUniqueRead(..) + , PersistUniqueWrite(..) + , OnlyOneUniqueKey(..) + , AtLeastOneUniqueKey(..) + , NoUniqueKeysError + , MultipleUniqueKeysError + , getByValue + , insertBy + , insertUniqueEntity + , replaceUnique + , checkUnique + , onlyUnique + , defaultPutMany + , persistUniqueKeyValues ) where +import Data.List.NonEmpty (NonEmpty) import Database.Persist.Types import Control.Exception (throwIO) import Control.Monad (liftM) @@ -27,6 +33,7 @@ import Database.Persist.Class.PersistEntity import Data.Monoid (mappend) import Data.Text (unpack, Text) import Data.Maybe (catMaybes) +import GHC.TypeLits -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -64,7 +71,10 @@ class (PersistCore backend, PersistStoreRead backend) => -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getBy - :: (MonadIO m, PersistRecordBackend record backend) + :: + ( MonadIO m + , PersistRecordBackend record backend + ) => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Some functions in this module ('insertUnique', 'insertBy', and @@ -177,7 +187,7 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- -- Then, it throws an error message something like "Expected only one unique key, got" upsert - :: (MonadIO m, PersistRecordBackend record backend) + :: (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record) => record -- ^ new record to insert -> [Update record] -- ^ updates to perform if the record already exists -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation @@ -258,11 +268,51 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- * replace existing records (matching any unique constraint) -- @since 2.8.1 putMany - :: (MonadIO m, PersistRecordBackend record backend) - => [record] -- ^ A list of the records you want to insert or replace. + :: + ( MonadIO m + , PersistRecordBackend record backend + ) + => [record] + -- ^ A list of the records you want to insert or replace. -> ReaderT backend m () putMany = defaultPutMany +-- | This class is used to ensure that 'upsert' is only called on records +-- that have a single 'Unique' key. The quasiquoter automatically generates +-- working instances for appropriate records, and generates 'TypeError' +-- instances for records that have 0 or multiple unique keys. +-- +-- @since 2.10.0 +class OnlyOneUniqueKey record where + onlyUniqueP :: proxy record -> Unique record + +type NoUniqueKeysError ty = + 'Text "The entity " + ':<>: 'ShowType ty + ':<>: 'Text " does not have any unique keys." + ':$$: 'Text "The function you are trying to call requires a unique key " + ':<>: 'Text "to be defined on the entity." + +type MultipleUniqueKeysError ty = + 'Text "The entity " + ':<>: 'ShowType ty + ':<>: 'Text " has multiple unique keys." + ':$$: 'Text "The function you are trying to call requires only a single " + ':<>: 'Text "unique key." + ':$$: 'Text "There is probably a variant of the function with 'By' " + ':<>: 'Text "appended that will allow you to select a unique key " + ':<>: 'Text "for the operation." + +-- | This class is used to ensure that functions requring at least one +-- unique key are not called with records that have 0 unique keys. The +-- quasiquoter automatically writes working instances for appropriate +-- entities, and generates 'TypeError' instances for records that have +-- 0 unique keys. +-- +-- @since 2.10.0 +class AtLeastOneUniqueKey record where + requireUniquesP :: proxy record -> NonEmpty (Unique record) + -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'. @@ -278,9 +328,12 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- -- First three lines return 'Left' because there're duplicates in given record's uniqueness constraints. While the last line returns a new key as 'Right'. insertBy - :: (MonadIO m - ,PersistUniqueWrite backend - ,PersistRecordBackend record backend) + :: + ( MonadIO m + , PersistUniqueWrite backend + , PersistRecordBackend record backend + , AtLeastOneUniqueKey record + ) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val @@ -291,8 +344,14 @@ insertBy val = do -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is left untouched. The key of the -- existing or new entry is returned -_insertOrGet :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Key record) +_insertOrGet + :: + ( MonadIO m + , PersistUniqueWrite backend + , PersistRecordBackend record backend + , AtLeastOneUniqueKey record + ) + => record -> ReaderT backend m (Key record) _insertOrGet val = do res <- getByValue val case res of @@ -394,12 +453,31 @@ onlyUniqueEither record = -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getByValue - :: (MonadIO m - ,PersistUniqueRead backend - ,PersistRecordBackend record backend) + :: forall record m backend. + ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + , AtLeastOneUniqueKey record + ) => record -> ReaderT backend m (Maybe (Entity record)) -getByValue record = - checkUniques =<< requireUniques record (persistUniqueKeys record) +getByValue record = do + uniqs <- requireUniques record (persistUniqueKeys record) + getByValueUniques uniqs record + +-- | Retrieve a record from the database using the given unique keys. +-- +-- @since 2.10.0 +getByValueUniques + :: + ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + ) + => [Unique record] + -> record + -> ReaderT backend m (Maybe (Entity record)) +getByValueUniques uniqs _ = + checkUniques uniqs where checkUniques [] = return Nothing checkUniques (x:xs) = do @@ -505,13 +583,13 @@ defaultPutMany rsD = do let uKeys = persistUniqueKeys . head $ rsD case uKeys of [] -> insertMany_ rsD - _ -> go + uniqs -> go uniqs where - go = do + go uniqs = do let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) -- lookup record(s) by their unique key - mEsOld <- mapM getByValue rs + mEsOld <- mapM (getByValueUniques uniqs) rs -- find pre-existing entities and corresponding (incoming) records let merge (Just x) y = Just (x, y) @@ -537,4 +615,4 @@ defaultPutMany rsD = do -- | The _essence_ of a unique record. -- useful for comaparing records in haskell land for uniqueness equality. persistUniqueKeyValues :: PersistEntity record => record -> [PersistValue] -persistUniqueKeyValues r = concat $ map persistUniqueToValues $ persistUniqueKeys r \ No newline at end of file +persistUniqueKeyValues r = concat $ map persistUniqueToValues $ persistUniqueKeys r diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 758bf1bbe..86042dc63 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.9.2 +version: 2.10.0 license: MIT license-file: LICENSE author: Michael Snoyman From dcc89b52f3b384129be0d6efd399e2992f8bd4c7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 20:48:10 -0600 Subject: [PATCH 2/8] Move putMany into upsert specs --- persistent-test/src/PersistentTest.hs | 44 -------------------------- persistent-test/src/UpsertTest.hs | 45 +++++++++++++++++++++++++++ 2 files changed, 45 insertions(+), 44 deletions(-) diff --git a/persistent-test/src/PersistentTest.hs b/persistent-test/src/PersistentTest.hs index 5825f4063..cf6d8e274 100644 --- a/persistent-test/src/PersistentTest.hs +++ b/persistent-test/src/PersistentTest.hs @@ -386,50 +386,6 @@ specsWith runDb = describe "persistent" $ do pBlue30 <- updateGet key25 [PersonAge +=. 2] pBlue30 @== Person "Updated" 30 Nothing - describe "putMany" $ do - it "adds new rows when entity has no unique constraints" $ runDb $ do - let mkPerson name = Person1 name 25 - let names = ["putMany bob", "putMany bob", "putMany smith"] - let records = map mkPerson names - _ <- putMany records - entitiesDb <- selectList [Person1Name <-. names] [] - let recordsDb = fmap entityVal entitiesDb - recordsDb @== records - deleteWhere [Person1Name <-. names] - it "adds new rows when no conflicts" $ runDb $ do - let mkUpsert e = Upsert e "new" "" 1 - let keys = ["putMany1","putMany2","putMany3"] - let vals = map mkUpsert keys - _ <- putMany vals - Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1" - Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2" - Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3" - [v1,v2,v3] @== vals - deleteBy $ UniqueUpsert "putMany1" - deleteBy $ UniqueUpsert "putMany2" - deleteBy $ UniqueUpsert "putMany3" - it "handles conflicts by replacing old keys with new records" $ runDb $ do - let mkUpsert1 e = Upsert e "new" "" 1 - let mkUpsert2 e = Upsert e "new" "" 2 - let vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"] - Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4" - Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5" - _ <- putMany $ mkUpsert1 "putMany4" : vals - Just e1 <- getBy $ UniqueUpsert "putMany4" - Just e2 <- getBy $ UniqueUpsert "putMany5" - Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6" - Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7" - - [e1,e2,e3,e4] @== [ Entity k1 (mkUpsert2 "putMany4") - , Entity k2 (mkUpsert2 "putMany5") - , Entity k3 (mkUpsert2 "putMany6") - , Entity k4 (mkUpsert2 "putMany7") - ] - deleteBy $ UniqueUpsert "putMany4" - deleteBy $ UniqueUpsert "putMany5" - deleteBy $ UniqueUpsert "putMany6" - deleteBy $ UniqueUpsert "putMany7" - describe "repsertMany" $ do it "adds new rows when no conflicts" $ runDb $ do ids@[johnId, janeId, aliceId, eveId] <- replicateM 4 $ liftIO (Person1Key `fmap` generateKey) diff --git a/persistent-test/src/UpsertTest.hs b/persistent-test/src/UpsertTest.hs index 2b8b22005..46b4e78bf 100644 --- a/persistent-test/src/UpsertTest.hs +++ b/persistent-test/src/UpsertTest.hs @@ -165,3 +165,48 @@ specsWith runDb handleNull handleKey = describe "UpsertTests" $ do Just 2 Don'tUpdateNull -> Nothing + + describe "putMany" $ do + it "adds new rows when entity has no unique constraints" $ runDb $ do + let mkPerson name = Person1 name 25 + let names = ["putMany bob", "putMany bob", "putMany smith"] + let records = map mkPerson names + _ <- putMany records + entitiesDb <- selectList [Person1Name <-. names] [] + let recordsDb = fmap entityVal entitiesDb + recordsDb @== records + deleteWhere [Person1Name <-. names] + it "adds new rows when no conflicts" $ runDb $ do + let mkUpsert e = Upsert e "new" "" 1 + let keys = ["putMany1","putMany2","putMany3"] + let vals = map mkUpsert keys + _ <- putMany vals + Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1" + Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2" + Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3" + [v1,v2,v3] @== vals + deleteBy $ UniqueUpsert "putMany1" + deleteBy $ UniqueUpsert "putMany2" + deleteBy $ UniqueUpsert "putMany3" + it "handles conflicts by replacing old keys with new records" $ runDb $ do + let mkUpsert1 e = Upsert e "new" "" 1 + let mkUpsert2 e = Upsert e "new" "" 2 + let vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"] + Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4" + Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5" + _ <- putMany $ mkUpsert1 "putMany4" : vals + Just e1 <- getBy $ UniqueUpsert "putMany4" + Just e2 <- getBy $ UniqueUpsert "putMany5" + Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6" + Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7" + + [e1,e2,e3,e4] @== [ Entity k1 (mkUpsert2 "putMany4") + , Entity k2 (mkUpsert2 "putMany5") + , Entity k3 (mkUpsert2 "putMany6") + , Entity k4 (mkUpsert2 "putMany7") + ] + deleteBy $ UniqueUpsert "putMany4" + deleteBy $ UniqueUpsert "putMany5" + deleteBy $ UniqueUpsert "putMany6" + deleteBy $ UniqueUpsert "putMany7" + From 1da41503936ed082811a1f349578993ed1ff1566 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 21:48:29 -0600 Subject: [PATCH 3/8] Actually undefined is wrong --- persistent-template/Database/Persist/TH.hs | 4 ++-- .../Database/Persist/Class/PersistEntity.hs | 4 ---- .../Database/Persist/Class/PersistUnique.hs | 16 +++++++--------- 3 files changed, 9 insertions(+), 15 deletions(-) diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index a53529f9a..0845ff6cf 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1173,7 +1173,7 @@ mkUniqueKeyInstances mps t = do singleUniqueKey :: Q [Dec] singleUniqueKey = do - expr <- [e|\p -> head (persistUniqueKeysP p)|] + expr <- [e|\p -> head (persistUniqueKeys p)|] let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] cxt <- withPersistStoreWriteCxt pure [instanceD cxt onlyOneUniqueKeyClass impl] @@ -1183,7 +1183,7 @@ mkUniqueKeyInstances mps t = do atLeastOneKey :: Q [Dec] atLeastOneKey = do - expr <- [e|\p -> NEL.fromList (persistUniqueKeysP p)|] + expr <- [e|\p -> NEL.fromList (persistUniqueKeys p)|] let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] cxt <- withPersistStoreWriteCxt pure [instanceD cxt atLeastOneUniqueKeyClass impl] diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 6cfcaaf8c..cabe6ccae 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -21,7 +21,6 @@ module Database.Persist.Class.PersistEntity -- * PersistField based on other typeclasses , toPersistValueJSON, fromPersistValueJSON , toPersistValueEnum, fromPersistValueEnum - , persistUniqueKeysP ) where import Database.Persist.Types.Base @@ -103,9 +102,6 @@ class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) fieldLens :: EntityField record field -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) - persistUniqueKeysP :: proxy record -> [Unique record] - persistUniqueKeysP _ = persistUniqueKeys (undefined :: record) - type family BackendSpecificUpdate backend record -- | Updating a database entity. diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index ca788d2b1..590fa87bf 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -21,6 +21,7 @@ module Database.Persist.Class.PersistUnique where import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL import Database.Persist.Types import Control.Exception (throwIO) import Control.Monad (liftM) @@ -33,7 +34,7 @@ import Database.Persist.Class.PersistEntity import Data.Monoid (mappend) import Data.Text (unpack, Text) import Data.Maybe (catMaybes) -import GHC.TypeLits +import GHC.TypeLits (TypeError(..), ErrorMessage(..)) -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -71,10 +72,7 @@ class (PersistCore backend, PersistStoreRead backend) => -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getBy - :: - ( MonadIO m - , PersistRecordBackend record backend - ) + :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Some functions in this module ('insertUnique', 'insertBy', and @@ -283,8 +281,8 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- instances for records that have 0 or multiple unique keys. -- -- @since 2.10.0 -class OnlyOneUniqueKey record where - onlyUniqueP :: proxy record -> Unique record +class PersistEntity record => OnlyOneUniqueKey record where + onlyUniqueP :: record -> Unique record type NoUniqueKeysError ty = 'Text "The entity " @@ -310,8 +308,8 @@ type MultipleUniqueKeysError ty = -- 0 unique keys. -- -- @since 2.10.0 -class AtLeastOneUniqueKey record where - requireUniquesP :: proxy record -> NonEmpty (Unique record) +class PersistEntity record => AtLeastOneUniqueKey record where + requireUniquesP :: record -> NonEmpty (Unique record) -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the From 456c0f1f44180bb7a543522e63dd251a4ac14a30 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 22:21:22 -0600 Subject: [PATCH 4/8] Update documentation --- .../Database/Persist/Class/PersistUnique.hs | 122 +++++++++--------- .../Persist/Sql/Orphan/PersistUnique.hs | 11 +- 2 files changed, 71 insertions(+), 62 deletions(-) diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index 590fa87bf..90565f3f7 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -10,6 +10,7 @@ module Database.Persist.Class.PersistUnique , NoUniqueKeysError , MultipleUniqueKeysError , getByValue + , getByValueUniques , insertBy , insertUniqueEntity , replaceUnique @@ -22,6 +23,7 @@ module Database.Persist.Class.PersistUnique import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map import Database.Persist.Types import Control.Exception (throwIO) import Control.Monad (liftM) @@ -135,13 +137,12 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => case conflict of Nothing -> Just `liftM` insert datum Just _ -> return Nothing + -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. -- - -- Throws an exception if there is more than 1 uniqueness constraint. - -- -- === __Example usage__ -- -- First, we try to explain 'upsert' using <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>. @@ -162,7 +163,7 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- > +-----+-----+--------+ -- -- > upsertX :: MonadIO m => [Update User] -> ReaderT SqlBackend m (Maybe (Entity User)) - -- > upsertX updates = upsert (User "X" 999) upadtes + -- > upsertX updates = upsert (User "X" 999) updates -- -- > mXEnt <- upsertX [UserAge +=. 15] -- @@ -183,15 +184,21 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- -- > mSpjEnt <- upsertSpj [UserAge +=. 15] -- - -- Then, it throws an error message something like "Expected only one unique key, got" + -- This fails with a compile-time type error alerting us to the fact + -- that this record has multiple unique keys, and suggests that we look or + -- 'upsertBy' to select the unique key we want. upsert :: (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record) - => record -- ^ new record to insert - -> [Update record] -- ^ updates to perform if the record already exists - -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation + => record + -- ^ new record to insert + -> [Update record] + -- ^ updates to perform if the record already exists + -> ReaderT backend m (Entity record) + -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates + -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist; @@ -249,10 +256,14 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- > +-----+-----+-----+ upsertBy :: (MonadIO m, PersistRecordBackend record backend) - => Unique record -- ^ uniqueness constraint to find by - -> record -- ^ new record to insert - -> [Update record] -- ^ updates to perform if the record already exists - -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> [Update record] + -- ^ updates to perform if the record already exists + -> ReaderT backend m (Entity record) + -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do mrecord <- getBy uniqueKey maybe (insertEntity record) (`updateGetEntity` updates) mrecord @@ -264,6 +275,7 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- -- * insert new records that do not exist (or violate any unique constraints) -- * replace existing records (matching any unique constraint) + -- -- @since 2.8.1 putMany :: @@ -284,6 +296,10 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => class PersistEntity record => OnlyOneUniqueKey record where onlyUniqueP :: record -> Unique record +-- | This is an error message. It is used when writing instances of +-- 'OnlyOneUniqueKey' for an entity that has no unique keys. +-- +-- @since 2.10.0 type NoUniqueKeysError ty = 'Text "The entity " ':<>: 'ShowType ty @@ -291,6 +307,10 @@ type NoUniqueKeysError ty = ':$$: 'Text "The function you are trying to call requires a unique key " ':<>: 'Text "to be defined on the entity." +-- | This is an error message. It is used when an entity has multiple +-- unique keys, and the function expects a single unique key. +-- +-- @since 2.10.0 type MultipleUniqueKeysError ty = 'Text "The entity " ':<>: 'ShowType ty @@ -339,23 +359,6 @@ insertBy val = do Nothing -> Right `liftM` insert val Just z -> return $ Left z --- | Insert a value, checking for conflicts with any unique constraints. If a --- duplicate exists in the database, it is left untouched. The key of the --- existing or new entry is returned -_insertOrGet - :: - ( MonadIO m - , PersistUniqueWrite backend - , PersistRecordBackend record backend - , AtLeastOneUniqueKey record - ) - => record -> ReaderT backend m (Key record) -_insertOrGet val = do - res <- getByValue val - case res of - Nothing -> insert val - Just (Entity key _) -> return key - -- | Like 'insertEntity', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. -- @@ -408,18 +411,18 @@ insertUniqueEntity datum = -- -- > mSimonConst <- onlySimonConst -- --- @mSimonConst@ would be Simon's uniqueness constraint. Note that @onlyUnique@ doesn't work if there're more than two constraints. +-- @mSimonConst@ would be Simon's uniqueness constraint. Note that +-- @onlyUnique@ doesn't work if there're more than two constraints. It will +-- fail with a type error instead. onlyUnique - :: (MonadIO m - ,PersistUniqueWrite backend - ,PersistRecordBackend record backend) + :: + ( MonadIO m + , PersistUniqueWrite backend + , PersistRecordBackend record backend + , OnlyOneUniqueKey record + ) => record -> ReaderT backend m (Unique record) -onlyUnique record = - case onlyUniqueEither record of - Right u -> return u - Left us -> - requireUniques record us >>= - liftIO . throwIO . OnlyUniqueException . show . length +onlyUnique = pure . onlyUniqueP onlyUniqueEither :: (PersistEntity record) @@ -459,10 +462,15 @@ getByValue ) => record -> ReaderT backend m (Maybe (Entity record)) getByValue record = do - uniqs <- requireUniques record (persistUniqueKeys record) - getByValueUniques uniqs record + let uniqs = requireUniquesP record + getByValueUniques (NEL.toList uniqs) --- | Retrieve a record from the database using the given unique keys. +-- | Retrieve a record from the database using the given unique keys. It +-- will attempt to find a matching record for each 'Unique' in the list, +-- and returns the first one that has a match. +-- +-- Returns 'Nothing' if you provide an empty list ('[]') or if no value +-- matches in the database. -- -- @since 2.10.0 getByValueUniques @@ -472,9 +480,8 @@ getByValueUniques , PersistRecordBackend record backend ) => [Unique record] - -> record -> ReaderT backend m (Maybe (Entity record)) -getByValueUniques uniqs _ = +getByValueUniques uniqs = checkUniques uniqs where checkUniques [] = return Nothing @@ -484,15 +491,6 @@ getByValueUniques uniqs _ = Nothing -> checkUniques xs Just z -> return $ Just z -requireUniques - :: (MonadIO m, PersistEntity record) - => record -> [Unique record] -> m [Unique record] -requireUniques record [] = liftIO $ throwIO $ userError errorMsg - where - errorMsg = "getByValue: " `Data.Monoid.mappend` unpack (recordName record) `mappend` " does not have any Unique" - -requireUniques _ xs = return xs - -- TODO: expose this to users recordName :: (PersistEntity record) @@ -577,17 +575,24 @@ defaultPutMany => [record] -> ReaderT backend m () defaultPutMany [] = return () -defaultPutMany rsD = do +defaultPutMany rsD@(e:es) = do let uKeys = persistUniqueKeys . head $ rsD case uKeys of [] -> insertMany_ rsD uniqs -> go uniqs where go uniqs = do - let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) + -- deduplicate the list of records in Haskell by unique key. The + -- previous implementation used Data.List.nubBy which is O(n^2) + -- complexity. + let rs = map snd + . Map.toList + . Map.fromList + . map (\r -> (persistUniqueKeyValues r, r)) + $ rsD -- lookup record(s) by their unique key - mEsOld <- mapM (getByValueUniques uniqs) rs + mEsOld <- mapM (getByValueUniques . persistUniqueKeys) rs -- find pre-existing entities and corresponding (incoming) records let merge (Just x) y = Just (x, y) @@ -610,7 +615,8 @@ defaultPutMany rsD = do -- replace existing records mapM_ (uncurry replace) krs --- | The _essence_ of a unique record. --- useful for comaparing records in haskell land for uniqueness equality. +-- | This function returns a list of 'PersistValue' that correspond to the +-- 'Unique' keys on that record. This is useful for comparing two @record@s +-- for equality only on the basis of their 'Unique' keys. persistUniqueKeyValues :: PersistEntity record => record -> [PersistValue] -persistUniqueKeyValues r = concat $ map persistUniqueToValues $ persistUniqueKeys r +persistUniqueKeyValues = concatMap persistUniqueToValues . persistUniqueKeys diff --git a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs index 88ad91b0b..e23f37506 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -24,10 +24,13 @@ import Data.List (nubBy) import Data.Function (on) defaultUpsert - :: (MonadIO m - ,PersistEntity record - ,PersistUniqueWrite backend - ,PersistEntityBackend record ~ BaseBackend backend) + :: + ( MonadIO m + , PersistEntity record + , PersistUniqueWrite backend + , PersistEntityBackend record ~ BaseBackend backend + , OnlyOneUniqueKey record + ) => record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsert record updates = do uniqueKey <- onlyUnique record From dd13ba66195fc65fd1d5cbd2958c7308f8c9331f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 22:26:55 -0600 Subject: [PATCH 5/8] update changelogs --- persistent-template/ChangeLog.md | 2 +- persistent/ChangeLog.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent-template/ChangeLog.md b/persistent-template/ChangeLog.md index bb2bef3fd..acba953bb 100644 --- a/persistent-template/ChangeLog.md +++ b/persistent-template/ChangeLog.md @@ -1,6 +1,6 @@ ## 2.7.0 -* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [TODO: add issue number]() +* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [#885](https://github.com/yesodweb/persistent/pull/885) ## 2.6.0 * [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 8595134b2..8a999578e 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,7 +2,7 @@ ## 2.10.0 -* Added two type classes `OnlyOneUniqueKey` and `AtLeastOneUniqueKey`. These classes are used as constraints on functions that expect a certain amount of unique keys. They are defined automatically as part of the `persistent-template`'s generation. [TODO: add issue number]() +* Added two type classes `OnlyOneUniqueKey` and `AtLeastOneUniqueKey`. These classes are used as constraints on functions that expect a certain amount of unique keys. They are defined automatically as part of the `persistent-template`'s generation. [#885](https://github.com/yesodweb/persistent/pull/885) ## 2.9.2 From 11464fe0ef0ee4f3d31c03a1697d197d961eed08 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 22:33:50 -0600 Subject: [PATCH 6/8] tidy up --- persistent-sqlite/test/SqliteInit.hs | 2 -- persistent/Database/Persist/Class/PersistUnique.hs | 11 +++++------ 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/persistent-sqlite/test/SqliteInit.hs b/persistent-sqlite/test/SqliteInit.hs index 10152ff35..ae156ca47 100644 --- a/persistent-sqlite/test/SqliteInit.hs +++ b/persistent-sqlite/test/SqliteInit.hs @@ -59,8 +59,6 @@ import Init -- re-exports import Test.QuickCheck.Instances () --- import Data.Fixed (Pico,Micro) --- import Data.Time import Control.Applicative as A ((<$>), (<*>)) import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index 90565f3f7..b2280de5f 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -185,7 +185,7 @@ class (PersistUniqueRead backend, PersistStoreWrite backend) => -- > mSpjEnt <- upsertSpj [UserAge +=. 15] -- -- This fails with a compile-time type error alerting us to the fact - -- that this record has multiple unique keys, and suggests that we look or + -- that this record has multiple unique keys, and suggests that we look for -- 'upsertBy' to select the unique key we want. upsert :: (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record) @@ -575,13 +575,12 @@ defaultPutMany => [record] -> ReaderT backend m () defaultPutMany [] = return () -defaultPutMany rsD@(e:es) = do - let uKeys = persistUniqueKeys . head $ rsD - case uKeys of +defaultPutMany rsD@(e:_) = do + case persistUniqueKeys e of [] -> insertMany_ rsD - uniqs -> go uniqs + _ -> go where - go uniqs = do + go = do -- deduplicate the list of records in Haskell by unique key. The -- previous implementation used Data.List.nubBy which is O(n^2) -- complexity. From 9b033dc567c19028a0a15682ca1ccbd255e48fa1 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 22:57:40 -0600 Subject: [PATCH 7/8] Drop 7.10.3 support --- .travis.yml | 1 - persistent-template/Database/Persist/TH.hs | 6 +++--- persistent/Database/Persist/Class/PersistUnique.hs | 1 - persistent/persistent.cabal | 2 +- 4 files changed, 4 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index c9c6cf4a2..80cbe2fca 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,7 +14,6 @@ services: matrix: include: - - env: ARGS="--resolver lts-6 --stack-yaml stack_lts-10.yaml" - env: ARGS="--resolver lts-9 --stack-yaml stack_lts-10.yaml" - env: ARGS="--resolver lts-11" - env: ARGS="--resolver lts-12" diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs index 0845ff6cf..9f090d75e 100644 --- a/persistent-template/Database/Persist/TH.hs +++ b/persistent-template/Database/Persist/TH.hs @@ -1119,9 +1119,9 @@ mkUniqueKeyInstances mps t = do undecidableInstancesEnabled <- isExtEnabled UndecidableInstances unless undecidableInstancesEnabled . fail $ "Generating Persistent entities now requires the 'UndecidableInstances' " - <> "language extension. Please enable it in your file by copy/pasting " - <> "this line into the top of your file: \n\n" - <> "{-# LANGUAGE UndecidableInstances #-}" + `mappend` "language extension. Please enable it in your file by copy/pasting " + `mappend` "this line into the top of your file: \n\n" + `mappend` "{-# LANGUAGE UndecidableInstances #-}" case entityUniques t of [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index b2280de5f..14f00f35e 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE TypeOperators, DataKinds #-} diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 86042dc63..d032c7641 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -22,7 +22,7 @@ library if flag(nooverlap) cpp-options: -DNO_OVERLAP - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.9 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 , time >= 1.1.4 From 1cd45cea3a54f76ccdf8f5f7be53923a95903a0e Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 10 Apr 2019 23:26:49 -0600 Subject: [PATCH 8/8] clean up postgres test warnings --- persistent-postgresql/test/ArrayAggTest.hs | 8 ++----- persistent-postgresql/test/PgInit.hs | 26 +++------------------- 2 files changed, 5 insertions(+), 29 deletions(-) diff --git a/persistent-postgresql/test/ArrayAggTest.hs b/persistent-postgresql/test/ArrayAggTest.hs index 1a57826f7..3a0adc3c6 100644 --- a/persistent-postgresql/test/ArrayAggTest.hs +++ b/persistent-postgresql/test/ArrayAggTest.hs @@ -18,20 +18,16 @@ module ArrayAggTest where +import PgInit + import qualified Data.Text as T import Data.List (sort) import Control.Monad.IO.Class (MonadIO) import Data.Aeson -import qualified Data.Vector as V (fromList) import Test.Hspec.Expectations () import PersistentTestModels -import Database.Persist -import Database.Persist.Postgresql.JSON - -import PgInit - share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| TestValue json Value diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index 85e91deda..b02d46277 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -7,8 +7,7 @@ {-# LANGUAGE TemplateHaskell #-} module PgInit ( - BackendMonad - , runConn + runConn , MonadIO , persistSettings @@ -17,7 +16,6 @@ module PgInit ( , BackendKey(..) , GenerateKey(..) - , RunDb -- re-exports , (A.<$>), (A.<*>) , module Database.Persist @@ -33,13 +31,7 @@ module PgInit ( , module Database.Persist.Sql , BS.ByteString , SomeException - , MonadFail , TestFn(..) - , truncateTimeOfDay - , truncateToMicro - , truncateUTCTime - , arbText - , liftA2 , module Init ) where @@ -52,12 +44,7 @@ import Init ) -- re-exports -import Control.Applicative (liftA2) import Test.QuickCheck.Instances () -import Data.Char (generalCategory, GeneralCategory(..)) -import qualified Data.Text as T -import Data.Fixed (Pico,Micro) -import Data.Time import Control.Applicative as A ((<$>), (<*>)) import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) @@ -66,7 +53,7 @@ import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLow import Database.Persist.Sql.Raw.QQ import Test.Hspec import Data.Aeson (Value(..)) -import Database.Persist.Postgresql.JSON +import Database.Persist.Postgresql.JSON () import qualified Data.HashMap.Strict as HM -- testing @@ -74,7 +61,7 @@ import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) import Test.QuickCheck import qualified Data.ByteString as BS -import Data.Text (Text, unpack) +import Data.Text (Text) import Database.Persist import Database.Persist.TH () import System.Environment (getEnvironment) @@ -87,8 +74,6 @@ import System.Log.FastLogger (fromLogStr) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Database.Persist.Postgresql -import Data.IORef (newIORef, IORef, writeIORef, readIORef) -import System.IO.Unsafe (unsafePerformIO) import Control.Monad (unless, (>=>)) import Control.Monad.IO.Unlift (MonadUnliftIO) @@ -111,7 +96,6 @@ dockerPg = do persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } -type BackendMonad = SqlBackend runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () runConn f = do @@ -130,10 +114,6 @@ db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion db actions = do runResourceT $ runConn $ actions >> transactionUndo -keyCounter :: IORef Int64 -keyCounter = unsafePerformIO $ newIORef 1 -{-# NOINLINE keyCounter #-} - instance Arbitrary Value where arbitrary = frequency [ (1, pure Null) , (1, Bool <$> arbitrary)