persistent 2.13.3.5 → 2.14.0.0

raw patch · 22 files changed

+660/−234 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +43/−1
• Database/Persist/Class.hs +1/−5
• Database/Persist/Class/DeleteCascade.hs +0/−39
• Database/Persist/Class/PersistEntity.hs +132/−4
• Database/Persist/Class/PersistField.hs +0/−6
• Database/Persist/Class/PersistStore.hs +25/−11
• Database/Persist/Class/PersistUnique.hs +16/−7
• Database/Persist/EntityDef.hs +26/−12
• Database/Persist/Quasi.hs +2/−0
• Database/Persist/Quasi/Internal.hs +98/−25
• Database/Persist/Sql/Internal.hs +1/−1
• Database/Persist/SqlBackend/Internal.hs +0/−1
• Database/Persist/TH.hs +123/−103
• Database/Persist/Types.hs +0/−1
• Database/Persist/Types/Base.hs +6/−1
• persistent.cabal +9/−8
• test/Database/Persist/ClassSpec.hs +0/−1
• test/Database/Persist/QuasiSpec.hs +20/−7
• test/Database/Persist/TH/MigrationOnlySpec.hs +1/−1
• test/Database/Persist/TH/SumSpec.hs +43/−0
• test/Database/Persist/TH/TypeLitFieldDefsSpec.hs +59/−0
• test/Database/Persist/THSpec.hs +55/−0

@@ -1,12 +1,54 @@ # Changelog for persistent +## 2.14.0.0 (unreleased)++* [#1343](https://github.com/yesodweb/persistent/pull/1343)+    * Implement Type Literal based field definitions+* [#1387](https://github.com/yesodweb/persistent/pull/1387)+    * Better UX with `insert`. We now report a type error when you try to+      `insert` an `Entity` or a function, and we also forbid `insert`ing if the+      database would throw an error missing a primary key.+* [#1383](https://github.com/yesodweb/persistent/pull/1383)+    * Primary keys have a `NonEmpty` of fields, not a `[]` of fields.+    * A `Primary` key on an entity now creates a `Unique` constructror for that+      record, with the name `#{entityName}PrimaryKey`. This also affects the+      generation of `AtLeastOneUniqueKey` and `OnlyOneUniqueKey` instances, so+      you may need to change behavior on these classes.+* [#1381](https://github.com/yesodweb/persistent/pull/1381)+    * `Entity` is given a `HasField` instance that uses the database field+      names. This is primarily done to support `OverloadedRecordDot` in GHC 9.2+      and above.+    * A consequence of this is that the `Entity` constructor has been renamed to+      `Entity'`. A pattern synonym is provided that should work in almost all+      cases. You may incur a `MonadFail m` constraint if you are pattern+      matching directly on the constructor in a `do` result.+* [#1364](https://github.com/yesodweb/persistent/pull/1346)+    * The type `SomePersistField` was removed in favor of using `PersistValue`+      directly.+* [#1386](https://github.com/yesodweb/persistent/pull/1386)+    * The module `Database.Persist.Class.DeleteCascade` was deleted since you+      can put cascade behavior directly on your database models.+    * Removed `mkSave` from `Database.Persist.TH`. Use `mkEntityDefList`+      instead.+    * Remove the `CompositeDef` constructor from `ReferenceDef` which was not+      used internally anymore.+* [#1385](https://github.com/yesodweb/persistent/pull/1385)+    * The support for entity-level sum types is deprecated. It adds a+      considerable amount of complexity to the code, and the pattern is not+      particularly good for actually supporting sum types in most databases.+* [#1384](https://github.com/yesodweb/persistent/pull/1384)+    * Add `tabulateEntityA` to the `PersistEntity` class, allowing you to+      construct an `Entity a` by providing a function `EntityField a t -> f t`.+      Note that this doesn't make sense for sum entities, and the implementation+      `error`s.+    * Add `tabulateEntity` as a pure version of that.+ ## 2.13.3.5  * [#1374](https://github.com/yesodweb/persistent/pull/1374)     * Increasing test coverage for errors thrown when parsing entity definitions  ## 2.13.3.4- * [#1379](https://github.com/yesodweb/persistent/pull/1379)     * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed * [#1376](https://github.com/yesodweb/persistent/pull/1376)

@@ -129,12 +129,9 @@     , selectSource     , selectKeysList -    -- * DeleteCascade-    , DeleteCascade (..)-    , deleteCascadeWhere-     -- * PersistEntity     , PersistEntity (..)+    , tabulateEntity     , SymbolToField (..)     -- * PersistField     , PersistField (..)@@ -163,7 +160,6 @@     , toPersistValueJSON, fromPersistValueJSON     ) where -import Database.Persist.Class.DeleteCascade import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField

@@ -1,39 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}---module Database.Persist.Class.DeleteCascade {-# DEPRECATED "The DeleteCascade module is deprecated. You can now set cascade behavior directly on entities in the quasiquoter." #-}-    ( DeleteCascade (..)-    , deleteCascadeWhere-    ) where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (ReaderT, ask, runReaderT)-import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.Acquire (with)--import Database.Persist.Class.PersistStore-import Database.Persist.Class.PersistQuery-import Database.Persist.Class.PersistEntity--{-# DEPRECATED DeleteCascade "The DeleteCascade class is deprecated since you can now define cascade behavior directly on an entity." #-}---- | For combinations of backends and entities that support--- cascade-deletion. “Cascade-deletion” means that entries that depend on--- other entries to be deleted will be deleted as well.-class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ PersistEntityBackend record)-  => DeleteCascade record backend where--    -- | Perform cascade-deletion of single database-    -- entry.-    deleteCascade :: MonadIO m => Key record -> ReaderT backend m ()--{-# DEPRECATED deleteCascadeWhere "This function is deprecated since you can set cascading delete behavior directly on the entity." #-}---- | Cascade-deletion of entries satisfying given filters.-deleteCascadeWhere :: forall record backend m. (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend)-                   => [Filter record] -> ReaderT backend m ()-deleteCascadeWhere filts = do-    srcRes <- selectKeysRes filts []-    conn <- ask-    liftIO $ with srcRes (\src -> runConduit $ src .| CL.mapM_ (flip runReaderT conn . deleteCascade))

@@ -1,6 +1,8 @@+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# language PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}@@ -14,13 +16,14 @@  module Database.Persist.Class.PersistEntity     ( PersistEntity (..)+    , tabulateEntity     , Update (..)     , BackendSpecificUpdate     , SelectOpt (..)     , Filter (..)     , FilterValue (..)     , BackendSpecificFilter-    , Entity (..)+    , Entity (.., Entity, entityKey, entityVal)      , recordName     , entityValues@@ -31,8 +34,13 @@     , toPersistValueEnum, fromPersistValueEnum       -- * Support for @OverloadedLabels@ with 'EntityField'     , SymbolToField (..)+    , -- * Safety check for inserts+      SafeToInsert+    , SafeToInsertErrorMessage     ) where +import Data.Functor.Constant+ import Data.Aeson        ( FromJSON(..)        , ToJSON(..)@@ -47,6 +55,7 @@ import Data.Aeson.Text (encodeToTextBuilder) import Data.Aeson.Types (Parser, Result(Error, Success)) import Data.Attoparsec.ByteString (parseOnly)+import Data.Functor.Identity  #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM@@ -54,6 +63,7 @@ import qualified Data.HashMap.Strict as AM #endif +import GHC.Records import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isJust) import Data.Text (Text)@@ -113,10 +123,41 @@     -- | Return meta-data for a given 'EntityField'.     persistFieldDef :: EntityField record typ -> FieldDef     -- | A meta-operation to get the database fields of a record.-    toPersistFields :: record -> [SomePersistField]+    toPersistFields :: record -> [PersistValue]     -- | A lower-level operation to convert from database values to a Haskell record.     fromPersistValues :: [PersistValue] -> Either Text record +    -- | This function allows you to build an @'Entity' a@ by specifying an+    -- action that returns a value for the field in the callback function.+    -- Let's look at an example.+    --+    -- @+    -- parseFromEnvironmentVariables :: IO (Entity User)+    -- parseFromEnvironmentVariables =+    --     tabulateEntityA $ \\userField ->+    --         case userField of+    --             UserName ->+    --                 getEnv "USER_NAME"+    --             UserAge -> do+    --                 ageVar <- getEnv "USER_AGE"+    --                 case readMaybe ageVar of+    --                     Just age ->+    --                         pure age+    --                     Nothing ->+    --                         error $ "Failed to parse Age from: " <> ageVar+    --             UserAddressId -> do+    --                 addressVar <- getEnv "USER_ADDRESS_ID"+    --                 pure $ AddressKey addressVar+    -- @+    --+    -- @since 2.14.0.0+    tabulateEntityA+        :: Applicative f+        => (forall a. EntityField record a -> f a)+        -- ^ A function that builds a fragment of a record in an+        -- 'Applicative' context.+        -> f (Entity record)+     -- | Unique keys besides the 'Key'.     data Unique record     -- | A meta operation to retrieve all the 'Unique' keys.@@ -139,6 +180,45 @@     keyFromRecordM :: Maybe (record -> Key record)     keyFromRecordM = Nothing +-- | Construct an @'Entity' record@ by providing a value for each of the+-- record's fields.+--+-- These constructions are equivalent:+--+-- @+-- entityMattConstructor, entityMattTabulate :: Entity User+-- entityMattConstructor =+--     Entity+--         { entityKey = toSqlKey 123+--         , entityVal =+--             User+--                 { userName = "Matt"+--                 , userAge = 33+--                 }+--         }+--+-- entityMattTabulate =+--     tabulateEntity $ \\case+--         UserId ->+--             toSqlKey 123+--         UserName ->+--             "Matt"+--         UserAge ->+--             33+-- @+--+-- This is a specialization of 'tabulateEntityA', which allows you to+-- construct an 'Entity' by providing an 'Applicative' action for each+-- field instead of a regular function.+--+-- @since 2.14.0.0+tabulateEntity+    :: PersistEntity record+    => (forall a. EntityField record a -> a)+    -> Entity record+tabulateEntity fromField =+    runIdentity (tabulateEntityA (Identity . fromField))+ type family BackendSpecificUpdate backend record  -- Moved over from Database.Persist.Class.PersistUnique@@ -231,15 +311,29 @@ -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on. data Entity record =-    Entity { entityKey :: Key record-           , entityVal :: record }+    Entity' (Key record) record +pattern Entity :: Key rec -> rec -> Entity rec+pattern Entity { entityKey,  entityVal } = Entity' entityKey entityVal++{-# COMPLETE Entity #-}+ 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] entityValues (Entity k record) =@@ -456,3 +550,37 @@ -- @since 2.11.0.0 instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where     fromLabel = symbolToField @sym++-- | A type class which is used to witness that a type is safe to insert into+-- the database without providing a primary key.+--+-- The @TemplateHaskell@ function 'mkPersist' will generate instances of this+-- class for any entity that it works on. If the entity has a default primary+-- key, then it provides a regular instance. If the entity has a @Primary@+-- natural key, then this works fine. But if the entity has an @Id@ column with+-- no @default=@, then this does a 'TypeError' and forces the user to use+-- 'insertKey'.+--+-- @since 2.14.0.0+class SafeToInsert a where++type SafeToInsertErrorMessage a+    = 'Text "The PersistEntity " ':<>: ShowType a ':<>: 'Text " does not have a default primary key."+    ':$$: 'Text "This means that 'insert' will fail with a database error."+    ':$$: 'Text "Please  provide a default= clause inthe entity definition,"+    ':$$: 'Text "or use 'insertKey' instead to provide one."++instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b)++type FunctionErrorMessage a b =+    'Text "Uh oh! It looks like you are trying to insert a function into the database."+    ':$$: 'Text "Argument: " ':<>: 'ShowType a+    ':$$: 'Text "Result:   " ':<>: 'ShowType b+    ':$$: 'Text "You probably need to add more arguments to an Entity construction."++type EntityErrorMessage a =+    'Text "It looks like you're trying to `insert` an `Entity " ':<>: 'ShowType a ':<>: 'Text "` directly."+    ':$$: 'Text "You want `insertKey` instead. As an example:"+    ':$$: 'Text "    insertKey (entityKey ent) (entityVal ent)"++instance TypeError (EntityErrorMessage a) => SafeToInsert (Entity a)

@@ -5,7 +5,6 @@ {-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-} module Database.Persist.Class.PersistField     ( PersistField (..)-    , SomePersistField (..)     , getPersistMap     , OverflowNatural(..)     ) where@@ -451,11 +450,6 @@     | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs getPersistMap PersistNull = Right [] getPersistMap x = Left $ fromPersistValueError "[(Text, PersistValue)]" "map, string, bytestring or null" x--data SomePersistField = forall a. (PersistField a) => SomePersistField a-instance PersistField SomePersistField where-    toPersistValue (SomePersistField a) = toPersistValue a-    fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either Text Text)  instance PersistField Checkmark where     toPersistValue Active   = PersistBool True

@@ -30,6 +30,7 @@ import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Text as T+import GHC.Stack  import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField@@ -239,7 +240,7 @@     -- > +-----+------+-----+     -- > |3    |John  |30   |     -- > +-----+------+-----+-    insert :: forall record m. (MonadIO m, PersistRecordBackend record backend)+    insert :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)            => record -> ReaderT backend m (Key record)      -- | Same as 'insert', but doesn't return a @Key@.@@ -262,7 +263,7 @@     -- > +-----+------+-----+     -- > |3    |John  |30   |     -- > +-----+------+-----+-    insert_ :: forall record m. (MonadIO m, PersistRecordBackend record backend)+    insert_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)             => record -> ReaderT backend m ()     insert_ record = insert record >> return () @@ -300,7 +301,7 @@     -- > +-----+------+-----+     -- > |5    |Jane  |20   |     -- > +-----+------+-----+-    insertMany :: forall record m. (MonadIO m, PersistRecordBackend record backend)+    insertMany :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)                => [record] -> ReaderT backend m [Key record]     insertMany = mapM insert @@ -331,7 +332,7 @@     -- > +-----+------+-----+     -- > |5    |Jane  |20   |     -- > +-----+------+-----+-    insertMany_ :: forall record m. (MonadIO m, PersistRecordBackend record backend)+    insertMany_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)                 => [record] -> ReaderT backend m ()     insertMany_ x = insertMany x >> return () @@ -701,11 +702,16 @@ insertEntity :: forall e backend m.     ( PersistStoreWrite backend     , PersistRecordBackend e backend+    , SafeToInsert e     , MonadIO m+    , HasCallStack     ) => e -> ReaderT backend m (Entity e) insertEntity e = do     eid <- insert e-    return $ Entity eid e+    Maybe.fromMaybe (error errorMessage) <$> getEntity eid+  where+    errorMessage =+        "persistent: failed to get record from database despite receiving key from the database"  -- | Like @get@, but returns the complete @Entity@. --@@ -759,11 +765,19 @@ -- > |3    |Dave  |50   | -- > +-----+------+-----+ insertRecord-  :: forall record backend m. (PersistEntityBackend record ~ BaseBackend backend-     ,PersistEntity record-     ,MonadIO m-     ,PersistStoreWrite backend)+  :: forall record backend m.+   ( PersistEntityBackend record ~ BaseBackend backend+   , PersistEntity record+   , MonadIO m+   , PersistStoreWrite backend+   , SafeToInsert record+   , HasCallStack+   )   => record -> ReaderT backend m record insertRecord record = do-  insert_ record-  return $ record+  k <- insert record+  let errorMessage =+          "persistent: failed to retrieve a record despite receiving a key from the database"+  mentity <- get k+  return $ Maybe.fromMaybe (error errorMessage) mentity+

@@ -132,7 +132,7 @@     --     -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>.     insertUnique-        :: forall record m. (MonadIO m, PersistRecordBackend record backend)+        :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)         => record -> ReaderT backend m (Maybe (Key record))     insertUnique datum = do         conflict <- checkUnique datum@@ -190,7 +190,7 @@     -- that this record has multiple unique keys, and suggests that we look for     -- 'upsertBy' to select the unique key we want.     upsert-        :: forall record m. (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record)+        :: forall record m. (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record, SafeToInsert record)         => record         -- ^ new record to insert         -> [Update record]@@ -257,7 +257,7 @@     -- > |3    |X    |999  |     -- > +-----+-----+-----+     upsertBy-        :: forall record m. (MonadIO m, PersistRecordBackend record backend)+        :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)         => Unique record         -- ^ uniqueness constraint to find by         -> record@@ -278,6 +278,7 @@         :: forall record m.         ( MonadIO m         , PersistRecordBackend record backend+        , SafeToInsert record         )         => [record]         -- ^ A list of the records you want to insert or replace.@@ -376,6 +377,7 @@     , PersistUniqueWrite backend     , PersistRecordBackend record backend     , AtLeastOneUniqueKey record+    , SafeToInsert record     )     => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do@@ -422,6 +424,7 @@      . ( MonadIO m        , PersistRecordBackend record backend        , PersistUniqueWrite backend+       , SafeToInsert record        )     => record     -> ReaderT backend m (Maybe (Entity record))@@ -601,7 +604,8 @@        , PersistRecordBackend record backend        , PersistUniqueRead backend)     => Entity record -> ReaderT backend m (Maybe (Unique record))-checkUniqueUpdateable (Entity key record) = checkUniqueKeysUpdateable key (persistUniqueKeys record)+checkUniqueUpdateable (Entity key record) =+    checkUniqueKeysUpdateable key (persistUniqueKeys record)  checkUniqueKeysUpdateable     :: forall record backend m. ( MonadIO m@@ -612,10 +616,13 @@ checkUniqueKeysUpdateable key (x:xs) = do     y <- getBy x     case y of-        Nothing -> checkUniqueKeysUpdateable key xs+        Nothing ->+            checkUniqueKeysUpdateable key xs         Just (Entity k _)-          | key == k -> checkUniqueKeysUpdateable key xs-        Just _ ->  return (Just x)+          | key == k ->+              checkUniqueKeysUpdateable key xs+        Just _ ->+            return (Just x)  -- | The slow but generic 'upsertBy' implementation for any 'PersistUniqueRead'. -- * Lookup corresponding entities (if any) 'getBy'.@@ -628,6 +635,7 @@        , MonadIO m        , PersistStoreWrite backend        , PersistUniqueRead backend+       , SafeToInsert record        )     => Unique record   -- ^ uniqueness constraint to find by     -> record          -- ^ new record to insert@@ -650,6 +658,7 @@       , MonadIO m       , PersistStoreWrite backend       , PersistUniqueRead backend+      , SafeToInsert record       )     => [record]     -> ReaderT backend m ()

@@ -13,6 +13,7 @@     , getEntityFieldsDatabase     , getEntityForeignDefs     , getEntityUniques+    , getEntityUniquesNoPrimaryKey     , getEntityId     , getEntityIdField     , getEntityKeyFields@@ -31,30 +32,43 @@     , EntityIdDef(..)     ) where -import Data.Text (Text)-import Data.Map (Map) import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Text (Text)  import Database.Persist.EntityDef.Internal import Database.Persist.FieldDef -import Database.Persist.Types.Base-    ( UniqueDef-    , ForeignDef-    , entityKeyFields-    ) import Database.Persist.Names+import Database.Persist.Types.Base (ForeignDef, UniqueDef(..), entityKeyFields) --- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This currently does--- not include a @Primary@ key, if one is defined. A future version of--- @persistent@ will include a @Primary@ key among the 'Unique' constructors for--- the 'Entity'.+-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include+-- a @Primary@ key, if one is defined. A future version of @persistent@ will+-- include a @Primary@ key among the 'Unique' constructors for the 'Entity'. --+-- @since 2.14.0.0+getEntityUniquesNoPrimaryKey+    :: EntityDef+    -> [UniqueDef]+getEntityUniquesNoPrimaryKey ed =+    filter isNotPrimaryKey $ entityUniques ed+  where+    isNotPrimaryKey ud =+        let+            constraintName = unConstraintNameHS $ uniqueHaskell ud+         in+            constraintName /= unEntityNameHS (getEntityHaskellName ed) <> "PrimaryKey"++-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'.  As of version 2.14,+-- this will also include the primary key on the entity, if one is defined. If+-- you do not want the primary key, see 'getEntityUniquesNoPrimaryKey'.+-- -- @since 2.13.0.0 getEntityUniques     :: EntityDef     -> [UniqueDef]-getEntityUniques = entityUniques+getEntityUniques =+    entityUniques  -- | Retrieve the Haskell name of the given entity. --

@@ -667,6 +667,8 @@  === Entity-level +NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints).+ The <https://github.com/yesodweb/persistent/blob/master/persistent-test/src/SumTypeTest.hs#L35 tests for this feature> demonstrate their usage. Note the use of the sign @+@ in front of the entity

@@ -47,12 +47,14 @@     , ForeignFieldReference(..)     , mkKeyConType     , isHaskellUnboundField+    , FieldTypeLit(..)     ) where  import Prelude hiding (lines)  import Control.Applicative (Alternative((<|>)))-import Data.Char (isLower, isSpace, isUpper, toLower)+import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)+import Control.Monad import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL@@ -63,8 +65,9 @@ import qualified Data.Text as T import Database.Persist.EntityDef.Internal import Database.Persist.Types+import Database.Persist.Types.Base import Language.Haskell.TH.Syntax (Lift)-import Text.Read (readEither)+import qualified Text.Read as R  data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show @@ -94,26 +97,60 @@           x -> PSFail $ show x      parse1 :: Text -> ParseState FieldType-    parse1 t =+    parse1 t = fromMaybe (PSFail (show t)) $ do         case T.uncons t of-            Nothing -> PSDone-            Just (c, t')-                | isSpace c -> parse1 $ T.dropWhile isSpace t'-                | c == '(' -> parseEnclosed ')' id t'-                | c == '[' -> parseEnclosed ']' FTList t'-                | isUpper c || c == '\'' ->-                    let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t'-                     in PSSuccess (parseFieldTypePiece c a) b-                | otherwise -> PSFail $ show (c, t')+            Nothing -> pure PSDone+            Just (x, xs) ->+                parseSpace x xs+                <|> parseParenEnclosed x xs+                <|> parseList x xs+                <|> parseNumericLit x xs+                <|> parseTextLit x xs+                <|> parseTypeCon x xs +    parseSpace :: Char -> Text -> Maybe (ParseState FieldType)+    parseSpace c t = do+        guard (isSpace c)+        pure $ parse1 (T.dropWhile isSpace t)++    parseParenEnclosed c t = do+        guard (c == '(')+        pure $ parseEnclosed ')' id t++    parseList c t = do+        guard (c == '[')+        pure $ parseEnclosed ']' FTList t++    parseTextLit :: Char -> Text -> Maybe (ParseState FieldType)+    parseTextLit c t = do+        guard (c == '"')+        let (a, b) = T.break (== '"') t+            lit = FTLit (TextTypeLit a)+        pure $ PSSuccess lit (T.drop 1 b)++    parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType)+    parseNumericLit c t = do+        guard (isDigit c && T.all isDigit t)+        let (a, b) = breakAtNextSpace t+        lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a)+        pure $ PSSuccess lit b++    parseTypeCon c t = do+        guard (isUpper c || c == '\'')+        let (a, b) = breakAtNextSpace t+        pure $ PSSuccess (parseFieldTypePiece c a) b+     goMany :: ([FieldType] -> a) -> Text -> ParseState a     goMany front t =         case parse1 t of             PSSuccess x t' -> goMany (front . (x:)) t'             PSFail err -> PSFail err             PSDone -> PSSuccess (front []) t-            -- _ -> +breakAtNextSpace :: Text -> (Text, Text)+breakAtNextSpace =+    T.break isSpace+ parseFieldTypePiece :: Char -> Text -> FieldType parseFieldTypePiece fstChar rest =     case fstChar of@@ -461,7 +498,7 @@ unbindCompositeDef cd =     UnboundCompositeDef         { unboundCompositeCols =-            NEL.toList $ fmap fieldHaskell (compositeFields cd)+            fmap fieldHaskell (compositeFields cd)         , unboundCompositeAttrs =             compositeAttrs cd         }@@ -984,10 +1021,16 @@                     Just $ pure (takeForeign ps entityName rest)                 }         "Primary" ->-            mempty-                { entityConstraintDefsPrimaryComposite =-                    SetOnce (takeComposite (unboundFieldNameHS <$> defs) rest)-                }+            let+                unboundComposite =+                    takeComposite (unboundFieldNameHS <$> defs) rest+            in+                mempty+                    { entityConstraintDefsPrimaryComposite =+                        SetOnce unboundComposite+                    , entityConstraintDefsUniques =+                        Just $ pure $ compositeToUniqueDef entityName defs unboundComposite+                    }         "Id" ->             mempty                 { entityConstraintDefsIdField =@@ -1067,7 +1110,7 @@ -- -- @since.2.13.0.0 data UnboundCompositeDef = UnboundCompositeDef-    { unboundCompositeCols :: [FieldNameHS]+    { unboundCompositeCols :: NonEmpty FieldNameHS     -- ^ The field names for the primary key.     --     -- @since 2.13.0.0@@ -1079,6 +1122,31 @@     }     deriving (Eq, Ord, Show, Lift) +compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef+compositeToUniqueDef entityName fields UnboundCompositeDef {..} =+    UniqueDef+        { uniqueHaskell =+            ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey")+        , uniqueDBName =+            ConstraintNameDB "primary_key"+        , uniqueFields =+            fmap (\hsName -> (hsName, getDbNameFor hsName)) unboundCompositeCols+        , uniqueAttrs =+            unboundCompositeAttrs+        }+  where+    getDbNameFor hsName =+        case mapMaybe (matchHsName hsName) fields of+            [] ->+                error "Unable to find `hsName` in fields"+            (a : _) ->+                a+    matchHsName hsName UnboundFieldDef {..} = do+        guard $ unboundFieldNameHS == hsName+        pure unboundFieldNameDB+++ takeComposite     :: [FieldNameHS]     -> [Text]@@ -1086,11 +1154,17 @@ takeComposite fields pkcols =     UnboundCompositeDef         { unboundCompositeCols =-            map (getDef fields) cols+            fmap (getDef fields) neCols         , unboundCompositeAttrs =             attrs         }   where+    neCols =+        case NEL.nonEmpty cols of+            Nothing ->+                error "No fields provided for primary key"+            Just xs ->+                xs     (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols     getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t     getDef (d:ds) t@@ -1419,11 +1493,7 @@     -> Maybe CascadeAction parseCascadeAction prfx text = do     cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text-    case readEither (T.unpack cascadeStr) of-        Right a ->-            Just a-        Left _ ->-            Nothing+    readMaybe cascadeStr   where     toPrefix cp =         case cp of@@ -1448,3 +1518,6 @@ -- @since 2.13.0.0 getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS getUnboundEntityNameHS = entityHaskell . unboundEntityDef++readMaybe :: Read a => Text -> Maybe a+readMaybe = R.readMaybe . T.unpack

@@ -81,7 +81,7 @@     -> BackendSpecificOverrides     -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t overrides =-    (cols, getEntityUniques t, getEntityForeignDefs t)+    (cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t)   where     cols :: [Column]     cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)

@@ -13,7 +13,6 @@ import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.SqlBackend.Internal.MkSqlBackend import Database.Persist.SqlBackend.Internal.Statement-import Database.Persist.SqlBackend.Internal.StatementCache (StatementCache) import Database.Persist.SqlBackend.StatementCache import Database.Persist.Types.Base 

@@ -49,8 +49,6 @@     , mkMigrate     , migrateModels     , discoverEntities-    , mkSave-    , mkDeleteCascade     , mkEntityDefList     , share     , derivePersistField@@ -121,6 +119,7 @@ import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) +import Database.Persist.Class.PersistEntity import Database.Persist import Database.Persist.Quasi import Database.Persist.Quasi.Internal@@ -374,18 +373,18 @@                             , "\n\nYou can use the References keyword to fix this."                             ]                     | otherwise =-                        zip (fmap (withDbName fieldStore) fieldNames) parentKeyFieldNames+                        zip (fmap (withDbName fieldStore) fieldNames) (toList parentKeyFieldNames)                   where                     parentKeyFieldNames-                        :: [(FieldNameHS, FieldNameDB)]+                        :: NonEmpty (FieldNameHS, FieldNameDB)                     parentKeyFieldNames =                         case unboundPrimarySpec parentDef of                             NaturalKey ucd ->                                 fmap (withDbName parentFieldStore) (unboundCompositeCols ucd)                             SurrogateKey uid ->-                                [(FieldNameHS "Id", unboundIdDBName  uid)]+                                pure (FieldNameHS "Id", unboundIdDBName  uid)                             DefaultKey dbName ->-                                [(FieldNameHS "Id", dbName)]+                                pure (FieldNameHS "Id", dbName)                 withDbName store fieldNameHS =                     ( fieldNameHS                     , findDBName store fieldNameHS@@ -584,7 +583,7 @@ bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp bindCompositeDef ued ucd = do     fieldDefs <--       fmap ListE $ forM (unboundCompositeCols ucd) $ \col ->+       fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col ->            mkLookupEntityField ued col     [|         CompositeDef@@ -798,6 +797,7 @@     entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents     jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents     uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents+    safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents     symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents     return $ mconcat         [ persistFieldDecs@@ -805,8 +805,55 @@         , jsonDecs         , uniqueKeyInstances         , symbolToFieldInstances+        , safeToInsertInstances         ] +mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec]+mkSafeToInsertInstance mps ued =+    case unboundPrimarySpec ued of+        NaturalKey _ ->+            instanceOkay+        SurrogateKey uidDef -> do+            let attrs =+                    unboundIdAttrs uidDef+                isDefaultFieldAttr = \case+                    FieldAttrDefault _ ->+                        True+                    _ ->+                        False+            case List.find isDefaultFieldAttr attrs of+                Nothing ->+                    badInstance+                Just _ ->+                    instanceOkay++        DefaultKey _ ->+            instanceOkay++  where+    typ :: Type+    typ = genericDataType mps (getUnboundEntityNameHS ued) backendT++    mkInstance merr =+        InstanceD Nothing (maybe id (:) merr withPersistStoreWriteCxt) (ConT ''SafeToInsert `AppT` typ) []+    instanceOkay =+        pure+            [ mkInstance Nothing+            ]+    badInstance = do+        err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |]+        pure+            [ mkInstance (Just err)+            ]++    withPersistStoreWriteCxt =+        if mpsGeneric mps+            then+                [ConT ''PersistStoreWrite `AppT` backendT]+            else+                []++ -- we can't just use 'isInstance' because TH throws an error shouldGenerateCode :: UnboundEntityDef -> Q Bool shouldGenerateCode ed = do@@ -1296,7 +1343,7 @@         xs <- sequence $ replicate fieldCount $ newName "x"         let name = mkEntityDefName ed             pat = conp name $ fmap VarP xs-        sp <- [|SomePersistField|]+        sp <- [|toPersistValue|]         let bod = ListE $ fmap (AppE sp . VarE) xs         return $ normalClause [pat] bod @@ -1305,13 +1352,13 @@     goSum :: UnboundFieldDef -> Int -> Q Clause     goSum fieldDef idx = do         let name = sumConstrName mps ed fieldDef-        enull <- [|SomePersistField PersistNull|]+        enull <- [|PersistNull|]         let beforeCount = idx - 1             afterCount = fieldCount - idx             before = replicate beforeCount enull             after = replicate afterCount enull         x <- newName "x"-        sp <- [|SomePersistField|]+        sp <- [|toPersistValue|]         let body = ListE $ mconcat                 [ before                 , [sp `AppE` VarE x]@@ -1523,7 +1570,7 @@   where     keyConE = keyConExp entDef     unKeyE = unKeyExp entDef-    dec = RecC (keyConName entDef) (keyFields mps entDef)+    dec = RecC (keyConName entDef) (toList $ keyFields mps entDef)     k = ''Key     recordType =         genericDataType mps (getUnboundEntityNameHS entDef) backendT@@ -1609,7 +1656,7 @@         _ ->             False -keyFields :: MkPersistSettings -> UnboundEntityDef -> [(Name, Strict, Type)]+keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type) keyFields mps entDef =     case unboundPrimarySpec entDef of         NaturalKey ucd ->@@ -1658,7 +1705,7 @@                     [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|]   where     toValuesPrimary recName ucd =-        ListE <$> mapM (f recName) (unboundCompositeCols ucd)+        ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd)     f recName fieldNameHS =         [|         toPersistValue ($(varE $ keyFieldName mps entDef fieldNameHS) $(varE recName))@@ -1676,7 +1723,7 @@     FunD 'keyFromValues <$>         case unboundPrimarySpec entDef of             NaturalKey ucd ->-                fromValues entDef "keyFromValues" keyConE (unboundCompositeCols ucd)+                fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd)             _ -> do                 e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]                 return [normalClause [] e]@@ -1763,6 +1810,15 @@  mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec] mkEntity embedEntityMap entityMap mps preDef = do+    when (isEntitySum (unboundEntityDef preDef)) $ do+        reportWarning $ unlines+            [ "persistent has deprecated sum type entities as of 2.14.0.0."+            , "We will delete support for these entities in 2.15.0.0."+            , "If you need these, please add a comment on this GitHub issue:"+            , ""+            , "    https://github.com/yesodweb/persistent/issues/987"+            ]+     entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef     let         entDef =@@ -1827,6 +1883,50 @@             entityFieldTHCon <$> efthAllFields fields         allEntDefClauses =             entityFieldTHClause <$> efthAllFields fields++    mkTabulateA <- do+        fromFieldName <- newName "fromField"+        let names'types =+                filter (\(n, _) -> n /= mkName "Id") $ map (getConNameAndType . entityFieldTHCon) $ entityFieldsTHFields fields+            getConNameAndType = \case+                ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name []) ->+                    (name, fieldTy)+                other ->+                    error $ mconcat+                        [ "persistent internal error: field constructor did not have xpected shape. \n"+                        , "Expected: \n"+                        , "    ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n"+                        , "Got: \n"+                        , "    " <> show other+                        ]+            mkEntityVal =+                List.foldl'+                    (\acc (n, _) ->+                        InfixE+                            (Just acc)+                            (VarE '(<*>))+                            (Just (VarE fromFieldName `AppE` ConE n))+                    )+                    (VarE 'pure `AppE` ConE (mkEntityNameHSName entName))+                    names'types+            primaryKeyField =+                fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields+        body <-+            if isEntitySum $ unboundEntityDef entDef+            then [| error "tabulateEntityA does not make sense for sum type" |]+            else+                [|+                    Entity+                        <$> $(varE fromFieldName) $(conE primaryKeyField)+                        <*> $(pure mkEntityVal)+                |]+++        pure $+          FunD 'tabulateEntityA+            [ Clause [VarP fromFieldName] (NormalB body) []+            ]+     return $ addSyn $        dtd : mconcat fkc `mappend`       ( [ TySynD (keyIdName entDef) [] $@@ -1837,6 +1937,7 @@         , keyToValues'         , keyFromValues'         , keyFromRecordM'+        , mkTabulateA         , FunD 'entityDef [normalClause [WildP] entityDefExp]         , tpf         , FunD 'fromPersistValues fpv@@ -2257,98 +2358,10 @@ -- -- This function is useful for cases such as: ----- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]+-- >>> share [mkEntityDefList "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] share fs x = mconcat <$> mapM ($ x) fs --- | Save the @EntityDef@s passed in under the given name.------ This function was deprecated in @persistent-2.13.0.0@. It doesn't properly--- fix foreign keys. Please refer to 'mkEntityDefList' for a replacement.-mkSave :: String -> [EntityDef] -> Q [Dec]-mkSave name' defs' = do-    let name = mkName name'-    defs <- lift defs'-    return [ SigD name $ ListT `AppT` ConT ''EntityDef-           , FunD name [normalClause [] defs]-           ]--{-# DEPRECATED mkSave "This function is broken. mkEntityDefList is a drop-in replacement that will properly handle foreign keys correctly." #-}--data Dep = Dep-    { depTarget :: EntityNameHS-    , depSourceTable :: EntityNameHS-    , depSourceField :: FieldNameHS-    , depSourceNull  :: IsNullable-    }--{-# DEPRECATED mkDeleteCascade "You can now set update and delete cascade behavior directly on the entity in the quasiquoter. This function and class are deprecated and will be removed in the next major ersion." #-}---- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.------ This function is deprecated as of 2.13.0.0. You can now set cascade--- behavior directly in the quasiquoter.-mkDeleteCascade :: MkPersistSettings -> [UnboundEntityDef] -> Q [Dec]-mkDeleteCascade mps defs = do-    let deps = concatMap getDeps defs-    mapM (go deps) defs-  where-    getDeps :: UnboundEntityDef -> [Dep]-    getDeps def =-        concatMap getDeps' $ getUnboundFieldDefs $ fixEntityDef def-      where-        getDeps' :: UnboundFieldDef -> [Dep]-        getDeps' field =-            case guessFieldReference field of-                Just name ->-                    return Dep-                        { depTarget = name-                        , depSourceTable = entityHaskell (unboundEntityDef def)-                        , depSourceField = unboundFieldNameHS field-                        , depSourceNull  = isUnboundFieldNullable field-                        }-                Nothing ->-                    []-    go :: [Dep] -> UnboundEntityDef -> Q Dec-    go allDeps ued = do-        let name = entityHaskell (unboundEntityDef ued)-        let deps = filter (\x -> depTarget x == name) allDeps-        key <- newName "key"-        let del = VarE 'delete-        let dcw = VarE 'deleteCascadeWhere-        just <- [|Just|]-        filt <- [|Filter|]-        eq <- [|Eq|]-        value <- [|FilterValue|]-        let mkStmt :: Dep -> Stmt-            mkStmt dep = NoBindS-                $ dcw `AppE`-                  ListE-                    [ filt `AppE` ConE filtName-                           `AppE` (value `AppE` val (depSourceNull dep))-                           `AppE` eq-                    ]-              where-                filtName = filterConName' mps (depSourceTable dep) (depSourceField dep)-                val (Nullable ByMaybeAttr) = just `AppE` VarE key-                val _                      =             VarE key--        let stmts :: [Stmt]-            stmts = fmap mkStmt deps `mappend`-                    [NoBindS $ del `AppE` VarE key]--        let entityT = genericDataType mps name backendT--        return $-            instanceD-            [ mkClassP ''PersistQuery [backendT]-            , mkEqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''BaseBackend `AppT` backendT)-            ]-            (ConT ''DeleteCascade `AppT` entityT `AppT` backendT)-            [ FunD 'deleteCascade-                [normalClause [VarP key] (mkDoE stmts)]-            ]- -- | Creates a declaration for the @['EntityDef']@ from the @persistent@ -- schema. This is necessary because the Persistent QuasiQuoter is unable -- to know the correct type of ID fields, and assumes that they are all@@ -2651,12 +2664,19 @@         ConT ''Int64     FTTypeCon (Just m) t ->         ConT $ mkName $ unpack $ concat [m, ".", t]+    FTLit l ->+        LitT (typeLitToTyLit l)     FTTypePromoted t ->         PromotedT $ mkName $ T.unpack t     FTApp x y ->         ftToType x `AppT` ftToType y     FTList x ->         ListT `AppT` ftToType x++typeLitToTyLit :: FieldTypeLit -> TyLit+typeLitToTyLit = \case+    IntTypeLit n -> NumTyLit n+    TextTypeLit t -> StrTyLit (T.unpack t)  infixr 5 ++ (++) :: Monoid m => m -> m -> m

@@ -24,7 +24,6 @@     -- database and Haskell types.     , module Database.Persist.PersistValue     -- * Other Useful Stuff-    , SomePersistField (..)     , Update (..)     , BackendSpecificUpdate     , SelectOpt (..)

@@ -411,11 +411,17 @@ data FieldType     = FTTypeCon (Maybe Text) Text     -- ^ Optional module and name.+    | FTLit FieldTypeLit     | FTTypePromoted Text     | FTApp FieldType FieldType     | FTList FieldType     deriving (Show, Eq, Read, Ord, Lift) +data FieldTypeLit+    = IntTypeLit Integer+    | TextTypeLit Text+    deriving (Show, Eq, Read, Ord, Lift)+ isFieldNotGenerated :: FieldDef -> Bool isFieldNotGenerated = isNothing . fieldGenerated @@ -429,7 +435,6 @@     -- ^ A ForeignRef has a late binding to the EntityDef it references via name     -- and has the Haskell type of the foreign key in the form of FieldType     | EmbedRef EntityNameHS-    | CompositeRef CompositeDef     | SelfReference     -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311).     deriving (Show, Eq, Read, Ord, Lift)

@@ -1,5 +1,5 @@ name:            persistent-version:         2.13.3.5+version:         2.14.0.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -84,7 +84,6 @@         Database.Persist.SqlBackend.Internal.MkSqlBackend          Database.Persist.Class-        Database.Persist.Class.DeleteCascade         Database.Persist.Class.PersistEntity         Database.Persist.Class.PersistQuery         Database.Persist.Class.PersistUnique@@ -166,30 +165,32 @@         Database.Persist.ClassSpec         Database.Persist.PersistValueSpec         Database.Persist.QuasiSpec+        Database.Persist.TH.CommentSpec         Database.Persist.TH.DiscoverEntitiesSpec         Database.Persist.TH.EmbedSpec         Database.Persist.TH.ForeignRefSpec-        Database.Persist.TH.PersistWith.Model-        Database.Persist.TH.PersistWith.Model2-        Database.Persist.TH.PersistWithSpec-        Database.Persist.TH.CommentSpec         Database.Persist.TH.ImplicitIdColSpec         Database.Persist.TH.JsonEncodingSpec         Database.Persist.TH.KindEntitiesSpec         Database.Persist.TH.KindEntitiesSpecImports-        Database.Persist.TH.MigrationOnlySpec         Database.Persist.TH.MaybeFieldDefsSpec+        Database.Persist.TH.MigrationOnlySpec         Database.Persist.TH.MultiBlockSpec         Database.Persist.TH.MultiBlockSpec.Model         Database.Persist.TH.NestedSymbolsInTypeSpec         Database.Persist.TH.NestedSymbolsInTypeSpecImports         Database.Persist.TH.NoFieldSelectorsSpec         Database.Persist.TH.OverloadedLabelSpec+        Database.Persist.TH.PersistWith.Model+        Database.Persist.TH.PersistWith.Model2+        Database.Persist.TH.PersistWithSpec         Database.Persist.TH.RequireOnlyPersistImportSpec         Database.Persist.TH.SharedPrimaryKeyImportedSpec         Database.Persist.TH.SharedPrimaryKeySpec-        Database.Persist.THSpec+        Database.Persist.TH.SumSpec         Database.Persist.TH.ToFromPersistValuesSpec+        Database.Persist.TH.TypeLitFieldDefsSpec+        Database.Persist.THSpec         TemplateTestImports     default-language: Haskell2010 

@@ -13,4 +13,3 @@                 fromPersistValue (PersistText "2018-02-27 10:49:42.123")                     `shouldBe`                         Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))-

@@ -7,6 +7,7 @@  import Prelude hiding (lines) +import Control.Monad import Control.Exception import Data.List hiding (lines) import Data.List.NonEmpty (NonEmpty(..), (<|))@@ -83,9 +84,9 @@                 `shouldBe`                     Nothing         it "errors on invalid input" $ do-            evaluate (subject ["name", "int"])-                `shouldThrow`-                    errorCall "Invalid field type \"int\" PSFail ('i',\"nt\")"+            void (evaluate (subject ["name", "int"]))+                `catch` \(ErrorCall msg) ->+                    msg `shouldBe` "Invalid field type \"int\" PSFail \"int\""         it "works if it has a name and a type" $ do             subject ["asdf", "Int"]                 `shouldBe`@@ -434,6 +435,18 @@                     , FieldNameHS "name"                     , FieldNameHS "age"                     ]+                entityUniques (unboundEntityDef user) `shouldBe`+                    [ UniqueDef+                        { uniqueHaskell =+                            ConstraintNameHS "UserPrimaryKey"+                        , uniqueDBName =+                            ConstraintNameDB "primary_key"+                        , uniqueFields =+                            pure (FieldNameHS "ref", FieldNameDB "ref")+                        , uniqueAttrs =+                            []+                        }+                    ]              it "errors on duplicate custom Primary declaration" $ do                 let definitions = [st|@@ -445,9 +458,9 @@     Primary name |]                 let [user] = parse lowerCaseSettings definitions-                    errMsg = [st|expected only one Primary declaration per entity|]+                    errMsg = "expected only one Primary declaration per entity"                 evaluate (unboundEntityDef user) `shouldThrow`-                    errorCall (T.unpack errMsg)+                    errorCall errMsg              it "errors on conflicting Primary/Id declarations" $ do                 let definitions = [st|@@ -472,7 +485,7 @@                 let [user] = parse lowerCaseSettings definitions                 case unboundPrimarySpec user of                     NaturalKey ucd -> do-                        evaluate (head $ unboundCompositeCols ucd) `shouldThrow`+                        evaluate (NEL.head $ unboundCompositeCols ucd) `shouldThrow`                             errorCall "Unknown column in primary key constraint: \"ref\""                     _ ->                         error "Expected NaturalKey, failing"@@ -703,7 +716,7 @@             parseFieldType "[Maybe (Maybe Int)]" `shouldBe` Right                 (FTList (maybeCon `FTApp` (maybeCon `FTApp` int)))         it "fails on lowercase starts" $ do-            parseFieldType "nothanks" `shouldBe` Left "PSFail ('n',\"othanks\")"+            parseFieldType "nothanks" `shouldBe` Left "PSFail \"nothanks\""      describe "#1175 empty entity" $ do         let subject =

@@ -55,7 +55,7 @@             it "should have one field" $ do                 map toPersistValue (toPersistFields (HasMigrationOnly "asdf"))                     `shouldBe`-                        map toPersistValue [SomePersistField ("asdf" :: Text)]+                        [PersistText ("asdf" :: Text)]         describe "fromPersistValues" $ do             it "should work with only item in list" $ do                 fromPersistValues [PersistText "Hello"]

@@ -0,0 +1,43 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Persist.TH.SumSpec where++import TemplateTestImports+++import Database.Persist.TH.MultiBlockSpec.Model++share+    [ mkPersistWith sqlSettings importDefList+    ]+    [persistLowerCase|++What+    name Text++Lamp+    name Text+++Please+    what WhatId+    lamp LampId+|]++spec :: Spec+spec = do+    it "should warn" True+

@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-local-binds #-}++module Database.Persist.TH.TypeLitFieldDefsSpec where++import GHC.TypeLits+import TemplateTestImports++newtype Finite (n :: Nat) = Finite Int++instance PersistField (Finite n) where+    toPersistValue (Finite n) = toPersistValue n+    fromPersistValue = fmap Finite . fromPersistValue++instance PersistFieldSql (Finite n) where+    sqlType _ = sqlType (Proxy :: Proxy Int)++newtype Labelled (t :: Symbol) = Labelled Int++instance PersistField (Labelled n) where+    toPersistValue (Labelled n) = toPersistValue n+    fromPersistValue = fmap Labelled . fromPersistValue++instance PersistFieldSql (Labelled n) where+    sqlType _ = sqlType (Proxy :: Proxy Int)++mkPersist sqlSettings [persistLowerCase|+WithFinite+    one    (Finite 1)+    twenty (Finite 20)++WithLabelled+    one    (Labelled "one")+    twenty (Labelled "twenty")+|]++spec :: Spec+spec = describe "TypeLitFieldDefs" $ do+    it "should support numeric type literal fields in entity definition" $ do+        let mkFinite :: Finite 1 -> Finite 20 -> WithFinite+            mkFinite = WithFinite+        compiles++    it "should support string based type literal fields in entity definition" $ do+        let mkLabelled :: Labelled "one" -> Labelled "twenty" -> WithLabelled+            mkLabelled = WithLabelled+        compiles++compiles :: Expectation+compiles = True `shouldBe` True

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}@@ -23,6 +24,8 @@  module Database.Persist.THSpec where +import System.Environment+import Data.Time import Control.Applicative (Const(..)) import Data.Aeson (decode, encode) import Data.ByteString.Lazy.Char8 ()@@ -64,6 +67,8 @@ import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec+import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec+import qualified Database.Persist.TH.SumSpec as SumSpec  -- test to ensure we can have types ending in Id that don't trash the TH -- machinery@@ -174,6 +179,7 @@  spec :: Spec spec = describe "THSpec" $ do+    describe "SumSpec" $ SumSpec.spec     PersistWithSpec.spec     KindEntitiesSpec.spec     NestedSymbolsInTypeSpec.spec@@ -182,6 +188,7 @@     SharedPrimaryKeyImportedSpec.spec     ImplicitIdColSpec.spec     MaybeFieldDefsSpec.spec+    TypeLitFieldDefsSpec.spec     MigrationOnlySpec.spec     NoFieldSelectorsSpec.spec     EmbedSpec.spec@@ -426,6 +433,54 @@              show (CustomPrimaryKeyKey 0) `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}"             read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0++    describe "tabulateEntityA" $ do+        it "works" $ do+            person <-+                tabulateEntityA $ \case+                    PersonName ->+                        pure "Matt"+                    PersonAge -> do+                        (year, _, _) <- toGregorian . utctDay <$> getCurrentTime+                        pure $ Just (fromInteger year - 1988)+                    PersonFoo -> do+                        _ <- lookupEnv "PERSON_FOO" :: IO (Maybe String)+                        pure Bar+                    PersonAddress ->+                        pure $ Address  "lol no" "Denver" Nothing+                    PersonId ->+                        pure $ toSqlKey 123+            expectedAge <- fromInteger . subtract 1988 . (\(a, _, _) -> a) . toGregorian . utctDay <$> getCurrentTime+            person `shouldBe` Entity (toSqlKey 123) Person+                { personName =+                    "Matt"+                , personAge =+                    Just expectedAge+                , personFoo =+                    Bar+                , personAddress =+                    Address  "lol no" "Denver" Nothing+                }++    describe "tabulateEntity" $ do+        it "works" $ do+            let+                addressTabulate =+                    tabulateEntity $ \case+                        AddressId ->+                            toSqlKey 123+                        AddressStreet ->+                            "nope"+                        AddressCity ->+                            "Denver"+                        AddressZip ->+                            Nothing+            addressTabulate `shouldBe`+                Entity (toSqlKey 123) Address+                    { addressStreet = "nope"+                    , addressCity = "Denver"+                    , addressZip = Nothing+                    }  (&) :: a -> (a -> b) -> b x & f = f x