diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,23 @@ # Changelog for persistent -## 2.14.0.0 (unreleased) +## 2.14.0.1 + +* [#1392](https://github.com/yesodweb/persistent/pull/1392) + * Enhance `selectList` documentation with TypeApplications examples. + * Clarify `selectSource` documentation wording. +* [#1391](https://github.com/yesodweb/persistent/pull/1391) + * Increasing quasi module test coverage, improve error assertions +* [#1401](https://github.com/yesodweb/persistent/pull/1401) + * Change `Entity` back into a regular record and drop the `HasField` + instance. This is technically a breaking change, but [the bug in GHC's + `COMPLETE` annotations](https://gitlab.haskell.org/ghc/ghc/-/issues/15681) + rendered a super common pattern a much more invasive breaking change than + anticipated. As a result, upgrading to `persistent-2.14` was untenable. + + If you *did* upgrade and this broke your codebase *again*, please let me + know and I can release another patch to shim it. + +## 2.14.0.0 * [#1343](https://github.com/yesodweb/persistent/pull/1343) * Implement Type Literal based field definitions diff --git a/Database/Persist/Class/PersistEntity.hs b/Database/Persist/Class/PersistEntity.hs --- a/Database/Persist/Class/PersistEntity.hs +++ b/Database/Persist/Class/PersistEntity.hs @@ -311,28 +311,16 @@ -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on. data Entity record = - Entity' (Key record) record - -pattern Entity :: Key rec -> rec -> Entity rec -pattern Entity { entityKey, entityVal } = Entity' entityKey entityVal - -{-# COMPLETE Entity #-} + Entity + { entityKey :: Key record + , entityVal :: record + } deriving instance (Generic (Key record), Generic record) => Generic (Entity record) deriving instance (Eq (Key record), Eq record) => Eq (Entity record) deriving instance (Ord (Key record), Ord record) => Ord (Entity record) deriving instance (Show (Key record), Show record) => Show (Entity record) deriving instance (Read (Key record), Read record) => Read (Entity record) - -instance - ( SymbolToField sym ent typ - , PersistEntity ent - ) - => - HasField sym (Entity ent) typ - where - getField ent = - getConstant ((fieldLens (symbolToField @sym @ent @typ)) Constant ent) -- | Get list of values corresponding to given entity. entityValues :: PersistEntity record => Entity record -> [PersistValue] diff --git a/Database/Persist/Class/PersistQuery.hs b/Database/Persist/Class/PersistQuery.hs --- a/Database/Persist/Class/PersistQuery.hs +++ b/Database/Persist/Class/PersistQuery.hs @@ -73,7 +73,7 @@ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. -- --- WARNING: This function returns a 'ConduitM', which implies that it streams +-- WARNING: This function returns a 'ConduitM', which suggests that it streams -- the results. It does not stream results on most backends. If you need -- streaming, see @persistent-pagination@ for a means of chunking results based -- on indexed ranges. @@ -142,6 +142,23 @@ -- @ -- -- +-- +-- The type of record can usually be infered from the types of the provided filters +-- and select options. In the previous two examples, though, you'll notice that the +-- select options are polymorphic, applying to any record type. In order to help +-- type inference in such situations, or simply as an enhancement to readability, +-- you might find type application useful, illustrated below. +-- +-- @ +-- {-# LANGUAGE TypeApplications #-} +-- ... +-- +-- firstTenUsers = +-- 'selectList' @User [] ['LimitTo' 10] +-- +-- secondTenUsers = +-- 'selectList' @User [] ['LimitTo' 10, 'OffsetBy' 10] +-- @ -- -- With 'Asc' and 'Desc', we can provide the field we want to sort on. We can -- provide multiple sort orders - later ones are used to sort records that are diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.0.0 +version: 2.14.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -28,7 +28,7 @@ , http-api-data >= 0.3 , lift-type >= 0.1.0.0 && < 0.2.0.0 , monad-logger >= 0.3.28 - , mtl + , mtl < 2.3 , path-pieces >= 0.2 , resource-pool >= 0.2.3 , resourcet >= 1.1.10 diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs --- a/test/Database/Persist/QuasiSpec.hs +++ b/test/Database/Persist/QuasiSpec.hs @@ -7,8 +7,8 @@ import Prelude hiding (lines) -import Control.Monad import Control.Exception +import Control.Monad import Data.List hiding (lines) import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL @@ -84,9 +84,8 @@ `shouldBe` Nothing it "errors on invalid input" $ do - void (evaluate (subject ["name", "int"])) - `catch` \(ErrorCall msg) -> - msg `shouldBe` "Invalid field type \"int\" PSFail \"int\"" + evaluate (subject ["name", "int"]) + `shouldErrorWithMessage` "Invalid field type \"int\" PSFail \"int\"" it "works if it has a name and a type" $ do subject ["asdf", "Int"] `shouldBe` @@ -141,6 +140,15 @@ ] ) + it "handles numbers" $ + parseLine " one (Finite 1)" `shouldBe` + Just + ( Line 2 + [ Token "one" + , Token "Finite 1" + ] + ) + it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just @@ -152,8 +160,8 @@ it "should error if quotes are unterminated" $ do evaluate (parseLine " \"foo bar") - `shouldThrow` - errorCall "Unterminated quoted string starting with foo bar" + `shouldErrorWithMessage` + "Unterminated quoted string starting with foo bar" it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` @@ -358,8 +366,8 @@ |] let [user] = parse lowerCaseSettings definitions evaluate (unboundEntityDef user) - `shouldThrow` - errorCall "Unterminated parens string starting with Maybe Int" + `shouldErrorWithMessage` + "Unterminated parens string starting with Maybe Int" it "errors on duplicate cascade update declarations" $ do let definitions = [st| @@ -368,8 +376,8 @@ |] let [user] = parse lowerCaseSettings definitions mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) - `shouldThrow` - errorCall "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]" + `shouldErrorWithMessage` + "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]" it "errors on duplicate cascade delete declarations" $ do let definitions = [st| @@ -378,8 +386,8 @@ |] let [user] = parse lowerCaseSettings definitions mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) - `shouldThrow` - errorCall "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]" + `shouldErrorWithMessage` + "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]" describe "custom Id column" $ do it "parses custom Id column" $ do @@ -411,8 +419,8 @@ |] let [user] = parse lowerCaseSettings definitions errMsg = [st|expected only one Id declaration per entity|] - evaluate (unboundEntityDef user) `shouldThrow` - errorCall (T.unpack errMsg) + evaluate (unboundEntityDef user) `shouldErrorWithMessage` + (T.unpack errMsg) describe "primary declaration" $ do it "parses Primary declaration" $ do @@ -459,8 +467,8 @@ |] let [user] = parse lowerCaseSettings definitions errMsg = "expected only one Primary declaration per entity" - evaluate (unboundEntityDef user) `shouldThrow` - errorCall errMsg + evaluate (unboundEntityDef user) `shouldErrorWithMessage` + errMsg it "errors on conflicting Primary/Id declarations" $ do let definitions = [st| @@ -473,8 +481,8 @@ |] let [user] = parse lowerCaseSettings definitions errMsg = [st|Specified both an ID field and a Primary field|] - evaluate (unboundEntityDef user) `shouldThrow` - errorCall (T.unpack errMsg) + evaluate (unboundEntityDef user) `shouldErrorWithMessage` + (T.unpack errMsg) it "triggers error on invalid declaration" $ do let definitions = [st| @@ -485,8 +493,8 @@ let [user] = parse lowerCaseSettings definitions case unboundPrimarySpec user of NaturalKey ucd -> do - evaluate (NEL.head $ unboundCompositeCols ucd) `shouldThrow` - errorCall "Unknown column in primary key constraint: \"ref\"" + evaluate (NEL.head $ unboundCompositeCols ucd) `shouldErrorWithMessage` + "Unknown column in primary key constraint: \"ref\"" _ -> error "Expected NaturalKey, failing" @@ -506,8 +514,8 @@ [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\"" , "possible fields: [\"name\",\"emailFirst\"]" ] - evaluate (head (NEL.tail dbNames)) `shouldThrow` - errorCall errMsg + evaluate (head (NEL.tail dbNames)) `shouldErrorWithMessage` + errMsg it "triggers error if no valid constraint name provided" $ do let definitions = [st| @@ -516,8 +524,8 @@ Unique some |] let [user] = parse lowerCaseSettings definitions - evaluate (unboundPrimarySpec user) `shouldThrow` - errorCall "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" + evaluate (unboundPrimarySpec user) `shouldErrorWithMessage` + "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" describe "foreign keys" $ do let validDefinitions = [st| @@ -565,8 +573,8 @@ |] let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) - `shouldThrow` - errorCall "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" + `shouldErrorWithMessage` + "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" it "should error when foreign fields not provided" $ do let definitions = [st| @@ -585,8 +593,8 @@ |] let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) - `shouldThrow` - errorCall "No fields on foreign reference." + `shouldErrorWithMessage` + "No fields on foreign reference." it "should error when number of parent and foreign fields differ" $ do let definitions = [st| @@ -605,8 +613,8 @@ |] let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) - `shouldThrow` - errorCall "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" + `shouldErrorWithMessage` + "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" it "should throw error when there is more than one delete cascade on the declaration" $ do let definitions = [st| @@ -625,8 +633,8 @@ |] let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) - `shouldThrow` - errorCall "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" + `shouldErrorWithMessage` + "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" it "should throw error when there is more than one update cascade on the declaration" $ do let definitions = [st| @@ -645,8 +653,8 @@ |] let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) - `shouldThrow` - errorCall "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" + `shouldErrorWithMessage` + "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do let [_user, notification] = @@ -679,6 +687,22 @@ , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid") ] + describe "type literals" $ do + it "should be able to parse type literals" $ do + let simplifyField field = + (unboundFieldNameHS field, unboundFieldType field) + let tickedDefinition = [st| +WithFinite + one (Finite 1) + twenty (Labelled "twenty") +|] + let [withFinite] = parse lowerCaseSettings tickedDefinition + + (simplifyField <$> unboundEntityFields withFinite) `shouldBe` + [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))) + , (FieldNameHS "twenty", FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty"))) + ] + describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") @@ -705,6 +729,12 @@ baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz) + it "numeric type literals" $ do + let expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)) + parseFieldType "Finite 1" `shouldBe` Right expected + it "string type literals" $ do + let expected = FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty")) + parseFieldType "Labelled \"twenty\"" `shouldBe` Right expected it "nested list / parens (list inside parens)" $ do let maybeCon = FTTypeCon Nothing "Maybe" int = FTTypeCon Nothing "Int" @@ -1188,3 +1218,12 @@ arbitraryWhiteSpaceChar :: Gen Char arbitraryWhiteSpaceChar = oneof $ pure <$> [' ', '\t', '\n', '\r'] + +shouldErrorWithMessage :: IO a -> String -> Expectation +shouldErrorWithMessage action expectedMsg = do + res <- try action + case res of + Left (ErrorCall msg) -> + msg `shouldBe` expectedMsg + _ -> + expectationFailure "Expected `error` to have been called"