diff --git a/persistent-mongoDB/persistent-mongoDB.cabal b/persistent-mongoDB/persistent-mongoDB.cabal index 4cf47732e..dcefd7d78 100644 --- a/persistent-mongoDB/persistent-mongoDB.cabal +++ b/persistent-mongoDB/persistent-mongoDB.cabal @@ -26,7 +26,7 @@ library , bytestring , cereal >= 0.5 , conduit >= 1.2 - , http-api-data >= 0.3.7 && < 0.6 + , http-api-data >= 0.3.7 && < 0.7 , mongoDB >= 2.3 && < 2.8 , network >= 2.6 , path-pieces >= 0.2 diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 780d4559a..086b12fae 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,19 @@ # Changelog for persistent-postgresql +## 2.13.6.1 + +* [#1518](https://github.com/yesodweb/persistent/pull/1518) + * Normalize postgres type aliases to prevent noop migrations + +## 2.13.6 + +* [#1511](https://github.com/yesodweb/persistent/pull/1511) + * Add the `createPostgresqlPoolTailored` function to support creating + connection pools with a custom connection creation function. + * Expose `getServerVersion` and `createBackend` for user's convenience. +* [#1516](https://github.com/yesodweb/persistent/pull/1516) + * Support postgresql-simple 0.7 and postgresql-libpq 0.10 + ## 2.13.5.2 * [#1471](https://github.com/yesodweb/persistent/pull/1471) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 4dd2dcad5..dc97abdbc 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -37,6 +37,7 @@ module Database.Persist.Postgresql , createPostgresqlPool , createPostgresqlPoolModified , createPostgresqlPoolModifiedWithVersion + , createPostgresqlPoolTailored , createPostgresqlPoolWithConf , module Database.Persist.Sql , ConnectionString @@ -52,6 +53,7 @@ module Database.Persist.Postgresql , upsertManyWhere , openSimpleConn , openSimpleConnWithVersion + , getServerVersion , getSimpleConn , tableName , fieldName @@ -65,6 +67,7 @@ module Database.Persist.Postgresql , createRawPostgresqlPoolModified , createRawPostgresqlPoolModifiedWithVersion , createRawPostgresqlPoolWithConf + , createBackend ) where import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -82,8 +85,8 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) #if !MIN_VERSION_base(4,12,0) import Control.Monad.Trans.Reader (withReaderT) #endif @@ -102,8 +105,8 @@ import qualified Data.Conduit.List as CL import Data.Data (Data) import Data.Either (partitionEithers) import Data.Function (on) -import Data.IORef import Data.Int (Int64) +import Data.IORef import Data.List (find, foldl', groupBy, sort) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) @@ -122,12 +125,13 @@ import System.Environment (getEnvironment) #if MIN_VERSION_base(4,12,0) import Database.Persist.Compatible #endif +import qualified Data.Vault.Strict as Vault import Database.Persist.Postgresql.Internal import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util import Database.Persist.SqlBackend -import Database.Persist.SqlBackend.StatementCache (StatementCache, mkSimpleStatementCache, mkStatementCache) -import qualified Data.Vault.Strict as Vault +import Database.Persist.SqlBackend.StatementCache + (StatementCache, mkSimpleStatementCache, mkStatementCache) import System.IO.Unsafe (unsafePerformIO) -- | A @libpq@ connection string. A simple example of connection @@ -270,9 +274,31 @@ createPostgresqlPoolModifiedWithVersion -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool. -> m (Pool SqlBackend) -createPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do +createPostgresqlPoolModifiedWithVersion = createPostgresqlPoolTailored open' + +-- | Same as 'createPostgresqlPoolModifiedWithVersion', but takes a custom connection-creation +-- function. +-- +-- The only time you should reach for this function is if you need to write custom logic for creating +-- a connection to the database. +-- +-- @since 2.13.6 +createPostgresqlPoolTailored + :: (MonadUnliftIO m, MonadLoggerIO m) + => + ( (PG.Connection -> IO ()) + -> (PG.Connection -> IO (NonEmpty Word)) + -> ((PG.Connection -> SqlBackend) -> PG.Connection -> SqlBackend) + -> ConnectionString -> LogFunc -> IO SqlBackend + ) -- ^ Action that creates a postgresql connection (please see documentation on the un-exported @open'@ function in this same module. + -> (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. + -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. + -> ConnectionString -- ^ Connection string to the database. + -> Int -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) +createPostgresqlPoolTailored createConnection getVerDouble modConn ci = do let getVer = oldGetVersionToNew getVerDouble - createSqlPool $ open' modConn getVer id ci + createSqlPool $ createConnection modConn getVer id ci -- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. -- @@ -333,6 +359,8 @@ open' modConn getVer constructor cstr logFunc = do return $ constructor (createBackend logFunc ver smap) conn -- | Gets the PostgreSQL server version +-- +-- @since 2.13.6 getServerVersion :: PG.Connection -> IO (Maybe Double) getServerVersion conn = do [PG.Only version] <- PG.query_ conn "show server_version"; @@ -415,6 +443,8 @@ getSimpleConn = Vault.lookup underlyingConnectionKey <$> getConnVault -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection. +-- +-- @since 2.13.6 createBackend :: LogFunc -> NonEmpty Word -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = @@ -1073,7 +1103,15 @@ getColumn _ _ columnName _ = -- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer sqlTypeEq :: SqlType -> SqlType -> Bool sqlTypeEq x y = - T.toCaseFold (showSqlType x) == T.toCaseFold (showSqlType y) + let + -- Non exhaustive helper to map postgres aliases to the same name. Based on + -- https://www.postgresql.org/docs/9.5/datatype.html. + -- This prevents needless `ALTER TYPE`s when the type is the same. + normalize "int8" = "bigint" + normalize "serial8" = "bigserial" + normalize v = v + in + normalize (T.toCaseFold (showSqlType x)) == normalize (T.toCaseFold (showSqlType y)) findAlters :: [EntityDef] @@ -1339,7 +1377,7 @@ showAlter table (DropReference cname) = T.concat , escapeC cname ] --- | Get the SQL string for the table that a PeristEntity represents. +-- | Get the SQL string for the table that a PersistEntity represents. -- Useful for raw SQL queries. tableName :: (PersistEntity record) => record -> Text tableName = escapeE . tableDBName diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 05d4dbb4c..b3f957801 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.5.2 +version: 2.13.6.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -25,8 +25,8 @@ library , containers >= 0.5 , monad-logger >= 0.3.25 , mtl - , postgresql-simple >= 0.6.1 && < 0.7 - , postgresql-libpq >= 0.9.4.2 && < 0.10 + , postgresql-simple >= 0.6.1 && < 0.8 + , postgresql-libpq >= 0.9.4.2 && < 0.11 , resourcet >= 1.1.9 , resource-pool , string-conversions diff --git a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs index 51b21930c..b23c3606a 100644 --- a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs +++ b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs @@ -21,7 +21,7 @@ import PgInit share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| EquivalentType sql=equivalent_types - field1 Int + field1 Int sqltype=bigint field2 T.Text sqltype=text field3 T.Text sqltype=us_postal_code deriving Eq Show @@ -29,7 +29,7 @@ EquivalentType sql=equivalent_types share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| EquivalentType2 sql=equivalent_types - field1 Int + field1 Int sqltype=int8 field2 T.Text field3 T.Text sqltype=us_postal_code deriving Eq Show diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index fcfbcf3b7..feb1edf49 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-sqlite +## 2.13.2 + +* [#1488](https://github.com/yesodweb/persistent/pull/1488) + * Add `openRawSqliteConn` for creating `RawSqlite SqlBackend` connections + that aren't automatically cleaned-up. + ## 2.13.1.1 * [#1459](https://github.com/yesodweb/persistent/pull/1459) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index ccfecd605..e5b1a3701 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -48,6 +48,7 @@ module Database.Persist.Sqlite , ForeignKeyViolation(..) , checkForeignKeys , RawSqlite + , openRawSqliteConn , persistentBackend , rawSqliteConnection , withRawSqliteConnInfo @@ -94,8 +95,8 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as CL import Data.Foldable (toList) import qualified Data.HashMap.Lazy as HashMap -import Data.Int (Int64) import Data.IORef (newIORef) +import Data.Int (Int64) import Data.Maybe import Data.Pool (Pool) import Data.Text (Text) @@ -938,6 +939,22 @@ data RawSqlite backend = RawSqlite , _rawSqliteConnection :: Sqlite.Connection -- ^ The underlying `Sqlite.Connection` } +-- | Open a @'RawSqlite' 'SqlBackend'@ connection from a 'SqliteConnectionInfo'. +-- +-- When using this function, the caller has to accept the responsibility of +-- cleaning up the resulting connection. To do this, use 'close' with the +-- 'rawSqliteConnection' - it's enough to simply drop the 'persistBackend' +-- afterwards. +-- +-- @since 2.13.2 +openRawSqliteConn + :: (MonadUnliftIO m, MonadLoggerIO m) + => SqliteConnectionInfo + -> m (RawSqlite SqlBackend) +openRawSqliteConn connInfo = do + logFunc <- askLoggerIO + liftIO $ openWith RawSqlite connInfo logFunc + instance BackendCompatible b (RawSqlite b) where projectBackend = _persistentBackend diff --git a/persistent-sqlite/cbits/sqlite3.c b/persistent-sqlite/cbits/sqlite3.c index a82744931..50b5acdd9 100644 --- a/persistent-sqlite/cbits/sqlite3.c +++ b/persistent-sqlite/cbits/sqlite3.c @@ -53429,7 +53429,7 @@ static int writeSuperJournal(Pager *pPager, const char *zSuper){ } pPager->journalOff += (nSuper+20); - /* If the pager is in peristent-journal mode, then the physical + /* If the pager is in persistent-journal mode, then the physical ** journal-file may extend past the end of the super-journal name ** and 8 bytes of magic data just written to the file. This is ** dangerous because the code to rollback a hot-journal file diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index 8b36b1e18..4ec7f20b5 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.13.1.1 +version: 2.13.2.0 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 4766b7284..47c2d78b0 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,9 +1,20 @@ # Changelog for persistent -## 2.14.6.0 - +## 2.14.6.0 (unreleased) + +* [#1503](https://github.com/yesodweb/persistent/pull/1503) + * Create Haddocks from entity documentation comments +* [1497](https://github.com/yesodweb/persistent/pull/1497) + * Always generates `SymbolToField "id"` instance +* [#1509](https://github.com/yesodweb/persistent/pull/1509) + * Provide `ViaPersistEntity` for defining `PathMultiPiece` for entity keys. * [#1480](https://github.com/yesodweb/persistent/pull/1480) * Add `mpsAvoidHsKeyword` in `MkPersistSettings` + * +## 2.14.5.2 + +* [#1513](https://github.com/yesodweb/persistent/pull/1513) + * Support GHC 9.8 and `aeson-2.2` ## 2.14.5.1 diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 7e32f5007..81d019339 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -24,6 +24,7 @@ module Database.Persist.Class.PersistEntity , FilterValue (..) , BackendSpecificFilter , Entity (.., Entity, entityKey, entityVal) + , ViaPersistEntity (..) , recordName , entityValues @@ -56,6 +57,7 @@ import Data.Aeson.Text (encodeToTextBuilder) import Data.Aeson.Types (Parser, Result(Error, Success)) import Data.Attoparsec.ByteString (parseOnly) import Data.Functor.Identity +import Web.PathPieces (PathMultiPiece(..), PathPiece(..)) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM @@ -180,6 +182,18 @@ class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) keyFromRecordM :: Maybe (record -> Key record) keyFromRecordM = Nothing +-- | Newtype wrapper for optionally deriving typeclass instances on +-- 'PersistEntity' keys. +-- +-- @since 2.14.6.0 +newtype ViaPersistEntity record = ViaPersistEntity (Key record) + +instance PersistEntity record => PathMultiPiece (ViaPersistEntity record) where + fromPathMultiPiece pieces = do + Right key <- keyFromValues <$> mapM fromPathPiece pieces + pure $ ViaPersistEntity key + toPathMultiPiece (ViaPersistEntity key) = map toPathPiece $ keyToValues key + -- | Construct an @'Entity' record@ by providing a value for each of the -- record's fields. -- diff --git a/persistent/Database/Persist/Class/PersistStore.hs b/persistent/Database/Persist/Class/PersistStore.hs index 6ef8d626c..85b9eab40 100644 --- a/persistent/Database/Persist/Class/PersistStore.hs +++ b/persistent/Database/Persist/Class/PersistStore.hs @@ -79,7 +79,7 @@ class (HasPersistBackend backend) => IsPersistBackend backend where -- @ -- foo :: -- ( 'PersistEntity' record --- , 'PeristEntityBackend' record ~ 'BaseBackend' backend +-- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index e020401ae..a245b8ff6 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -612,8 +612,8 @@ Likewise, the field documentation is present in the @fieldComments@ field on the "A user can be old, or young, and we care about\nthis for some reason." @ -Unfortunately, we can't use this to create Haddocks for you, because . -@persistent@ backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. +Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). +@persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. = Sum types diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index f0334efb1..ce89b8f2c 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -80,7 +80,7 @@ whereStmtForKey conn k = whereStmtForKeys :: PersistEntity record => SqlBackend -> [Key record] -> Text whereStmtForKeys conn ks = T.intercalate " OR " $ whereStmtForKey conn `fmap` ks --- | get the SQL string for the table that a PeristEntity represents +-- | get the SQL string for the table that a PersistEntity represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient tableName function diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 6d02b370b..dfc25ef25 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -46,6 +46,7 @@ module Database.Persist.TH , mpsFieldLabelModifier , mpsAvoidHsKeyword , mpsConstraintLabelModifier + , mpsEntityHaddocks , mpsEntityJSON , mpsGenerateLenses , mpsDeriveInstances @@ -122,6 +123,9 @@ import Data.Foldable (asum, toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) +#if MIN_VERSION_template_haskell(2,21,0) +import Language.Haskell.TH.Lib (defaultBndrFlag) +#endif import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) @@ -1074,6 +1078,10 @@ data MkPersistSettings = MkPersistSettings -- Note: this setting is ignored if mpsPrefixFields is set to False. -- -- @since 2.11.0.0 + , mpsEntityHaddocks :: Bool + -- ^ Generate Haddocks from entity documentation comments. Default: False. + -- + -- @since 2.14.6.0 , mpsEntityJSON :: Maybe EntityJSON -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's -- @Nothing@, no instances will be generated. Default: @@ -1166,6 +1174,7 @@ mkPersistSettings backend = MkPersistSettings , mpsFieldLabelModifier = (++) , mpsAvoidHsKeyword = (++ "_") , mpsConstraintLabelModifier = (++) + , mpsEntityHaddocks = False , mpsEntityJSON = Just EntityJSON { entityToJSON = 'entityIdToJSON , entityFromJSON = 'entityIdFromJSON @@ -1208,10 +1217,24 @@ dataTypeDec mps entityMap entDef = do pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) unless (null anyclassDerives) $ do requireExtensions [[DeriveAnyClass]] - pure $ DataD [] nameFinal paramsFinal + let dec = DataD [] nameFinal paramsFinal Nothing constrs (stockDerives <> anyclassDerives) +#if MIN_VERSION_template_haskell(2,18,0) + when (mpsEntityHaddocks mps) $ do + forM_ cols $ \((name, _, _), maybeComments) -> do + case maybeComments of + Just comment -> addModFinalizer $ + putDoc (DeclDoc name) (unpack comment) + Nothing -> pure () + case entityComments (unboundEntityDef entDef) of + Just doc -> do + addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc) + _ -> pure () +#endif + pure dec + where stratFor n = if n `elem` stockClasses then @@ -1236,7 +1259,7 @@ dataTypeDec mps entityMap entDef = do | otherwise = (mkEntityDefName entDef, []) - cols :: [VarBangType] + cols :: [(VarBangType, Maybe Text)] cols = do fieldDef <- getUnboundFieldDefs entDef let @@ -1248,11 +1271,13 @@ dataTypeDec mps entityMap entDef = do else notStrict fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing - pure (recordNameE, strictness, fieldIdType) + fieldComments = + unboundFieldComments fieldDef + pure ((recordNameE, strictness, fieldIdType), fieldComments) constrs | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef - | otherwise = [RecC (mkEntityDefName entDef) cols] + | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)] sumCon fieldDef = NormalC (sumConstrName mps entDef fieldDef) @@ -2333,7 +2358,15 @@ mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` where fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent -#if MIN_VERSION_template_haskell(2,17,0) +#if MIN_VERSION_template_haskell(2,21,0) +mkPlainTV + :: Name + -> TyVarBndr BndrVis +mkPlainTV n = PlainTV n defaultBndrFlag + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#elif MIN_VERSION_template_haskell(2,17,0) mkPlainTV :: Name -> TyVarBndr () @@ -2988,11 +3021,7 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do mkEntityFieldConstr fieldHaskellName mkInstance fieldNameT fieldTypeT entityFieldConstr - mkey <- - case unboundPrimarySpec ed of - NaturalKey _ -> - pure [] - _ -> do + mkey <- do let fieldHaskellName = FieldNameHS "Id" diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index b17def38b..cd45d8b3c 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -201,7 +201,28 @@ entityKeyFields = -- columns for an 'EntityDef'. keyAndEntityFields :: EntityDef -> NonEmpty FieldDef keyAndEntityFields ent = - case entityId ent of + keyWithFields (entityId ent) fields + where + fields = filter isHaskellField $ entityFields ent + +-- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key +-- columns for an 'EntityDef' including those fields that are marked as +-- 'MigrationOnly' (and therefore only present in the database) or +-- 'SafeToRemove' (and a migration will drop the column if it exists in the +-- database). +-- +-- For fields on the Haskell type use 'keyAndEntityFieldsDatabase' +-- +-- @since 2.14.6.0 +keyAndEntityFieldsDatabase :: EntityDef -> NonEmpty FieldDef +keyAndEntityFieldsDatabase ent = + keyWithFields (entityId ent) fields + where + fields = entityFields ent + +keyWithFields :: EntityIdDef -> [FieldDef] -> NonEmpty FieldDef +keyWithFields entId fields = + case entId of EntityIdField fd -> fd :| fields EntityIdNaturalKey _ -> @@ -214,8 +235,6 @@ keyAndEntityFields ent = ] Just xs -> xs - where - fields = filter isHaskellField $ entityFields ent type ExtraLine = [Text] diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 845eb530c..605401cb9 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -15,10 +15,11 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md library - build-depends: + build-depends: base >= 4.11.1.0 && < 5 - , aeson >= 1.0 && < 2.2 + , aeson >= 1.0 && < 2.3 , attoparsec + , attoparsec-aeson >= 2.1.0.0 && < 2.3 , base64-bytestring , blaze-html >= 0.9 , bytestring >= 0.10 @@ -29,13 +30,13 @@ library , http-api-data >= 0.3 , lift-type >= 0.1.0.0 && < 0.2.0.0 , monad-logger >= 0.3.28 - , mtl + , mtl , path-pieces >= 0.2 , resource-pool >= 0.2.3 , resourcet >= 1.1.10 , scientific , silently - , template-haskell >= 2.13 && < 2.20 + , template-haskell >= 2.13 && < 2.22 , text >= 1.2 , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6 @@ -46,13 +47,13 @@ library , vault , vector - default-extensions: + default-extensions: FlexibleContexts , MultiParamTypeClasses , OverloadedStrings , TypeFamilies - exposed-modules: + exposed-modules: Database.Persist Database.Persist.Types Database.Persist.Names @@ -92,7 +93,7 @@ library Database.Persist.Class.PersistField Database.Persist.Class.PersistStore - other-modules: + other-modules: Database.Persist.Types.Base Database.Persist.Sql.Internal @@ -106,9 +107,9 @@ library -- These modules only make sense for compilers with access to DerivingVia if impl(ghc >= 8.6.1) - exposed-modules: + exposed-modules: Database.Persist.Compatible - other-modules: + other-modules: Database.Persist.Compatible.Types Database.Persist.Compatible.TH @@ -119,7 +120,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs - build-depends: + build-depends: base >= 4.9 && < 5 , aeson , attoparsec @@ -164,7 +165,7 @@ test-suite test , TypeFamilies , TypeOperators - other-modules: + other-modules: Database.Persist.ClassSpec Database.Persist.PersistValueSpec Database.Persist.QuasiSpec @@ -172,6 +173,7 @@ test-suite test Database.Persist.TH.CompositeKeyStyleSpec Database.Persist.TH.DiscoverEntitiesSpec Database.Persist.TH.EmbedSpec + Database.Persist.TH.EntityHaddockSpec Database.Persist.TH.ForeignRefSpec Database.Persist.TH.ImplicitIdColSpec Database.Persist.TH.JsonEncodingSpec diff --git a/persistent/test/Database/Persist/TH/CommentSpec.hs b/persistent/test/Database/Persist/TH/CommentSpec.hs index ea98c8474..9663ac956 100644 --- a/persistent/test/Database/Persist/TH/CommentSpec.hs +++ b/persistent/test/Database/Persist/TH/CommentSpec.hs @@ -12,14 +12,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Database.Persist.TH.CommentSpec where +{-# OPTIONS_GHC -haddock #-} + +module Database.Persist.TH.CommentSpec + ( CommentModel (..) + , spec + ) where import TemplateTestImports import Database.Persist.EntityDef.Internal (EntityDef(..)) import Database.Persist.FieldDef.Internal (FieldDef(..)) -mkPersist sqlSettings [persistLowerCase| +mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| -- | Doc comments work. -- | Has multiple lines. diff --git a/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs new file mode 100644 index 000000000..c7088c7a4 --- /dev/null +++ b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.Persist.TH.EntityHaddockSpec (spec) where + +import TemplateTestImports + +#if MIN_VERSION_template_haskell(2,18,0) +import Database.Persist.TH.CommentSpec (CommentModel (..)) +import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) +import Language.Haskell.TH.Syntax (lift) + +[d| + commentModelDoc :: Maybe String + commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel)) + + commentFieldDoc :: Maybe String + commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName)) + |] + +spec :: Spec +spec = describe "EntityHaddockSpec" $ do + it "generates entity Haddock" $ do + let expected = unlines [ "Doc comments work." + , "Has multiple lines." + ] + commentModelDoc `shouldBe` Just expected + it "generates field Haddock" $ do + let expected = unlines [ "First line of comment on column." + , "Second line of comment on column." + ] + commentFieldDoc `shouldBe` Just expected +#else +spec :: Spec +spec = pure () +#endif diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs index b81453160..363375ef5 100644 --- a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs +++ b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# 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 TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.OverloadedLabelSpec where -import TemplateTestImports +import TemplateTestImports mkPersist sqlSettings [persistUpperCase| @@ -33,6 +33,10 @@ Dog Organization name String +Student + userId UserId + departmentName String + Primary userId |] spec :: Spec @@ -60,5 +64,11 @@ spec = describe "OverloadedLabels" $ do compiles + it "works for Primary labels" $ do + let StudentId = #id + studentId = #id :: EntityField Student StudentId + + compiles + compiles :: IO () compiles = pure () diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 0ea783206..2d84727b1 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -53,6 +53,7 @@ import qualified Database.Persist.TH.CommentSpec as CommentSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec @@ -204,6 +205,7 @@ spec = describe "THSpec" $ do ToFromPersistValuesSpec.spec JsonEncodingSpec.spec CommentSpec.spec + EntityHaddockSpec.spec CompositeKeyStyleSpec.spec describe "TestDefaultKeyCol" $ do let EntityIdField FieldDef{..} =