diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Changelog for persistent +## 2.14.6.0 + +* [#1477](https://github.com/yesodweb/persistent/pull/1477) + * Qualified references to other tables will work +* [#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) 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 @@ -24,6 +24,7 @@ , FilterValue (..) , BackendSpecificFilter , Entity (.., Entity, entityKey, entityVal) + , ViaPersistEntity (..) , recordName , entityValues @@ -56,6 +57,7 @@ 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 @@ -179,6 +181,18 @@ -- @since 2.11.0.0 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/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -79,7 +79,7 @@ -- @ -- foo :: -- ( 'PersistEntity' record --- , 'PeristEntityBackend' record ~ 'BaseBackend' backend +-- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -612,8 +612,8 @@ "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/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -80,7 +80,7 @@ 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/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -44,7 +44,9 @@ , mpsGeneric , mpsPrefixFields , mpsFieldLabelModifier + , mpsAvoidHsKeyword , mpsConstraintLabelModifier + , mpsEntityHaddocks , mpsEntityJSON , mpsGenerateLenses , mpsDeriveInstances @@ -462,7 +464,9 @@ (fieldRef', sqlTyp') = case extractForeignRef entityMap ufd of Just targetTable -> - (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTable)) + let targetTableQualified = + fromMaybe targetTable (guessFieldReferenceQualified ufd) + in (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTableQualified)) Nothing -> (lift NoReference, liftSqlTypeExp sqlTypeExp) @@ -535,6 +539,30 @@ guessReferenceText (Just next) ] +guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType + +guessReferenceQualified :: FieldType -> Maybe EntityNameHS +guessReferenceQualified ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + mkDefaultKey :: MkPersistSettings -> FieldNameDB @@ -1061,6 +1089,12 @@ -- Note: this setting is ignored if mpsPrefixFields is set to False. -- -- @since 2.11.0.0 + , mpsAvoidHsKeyword :: Text -> Text + -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords. + -- + -- Default: suffix "_". + -- + -- @since 2.14.6.0 , mpsConstraintLabelModifier :: Text -> Text -> Text -- ^ Customise the Constraint names using the entity and field name. The -- result should be a valid haskell type (start with an upper cased letter). @@ -1070,6 +1104,10 @@ -- 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: @@ -1160,7 +1198,9 @@ , mpsGeneric = False , mpsPrefixFields = True , mpsFieldLabelModifier = (++) + , mpsAvoidHsKeyword = (++ "_") , mpsConstraintLabelModifier = (++) + , mpsEntityHaddocks = False , mpsEntityJSON = Just EntityJSON { entityToJSON = 'entityIdToJSON , entityFromJSON = 'entityIdFromJSON @@ -1203,10 +1243,24 @@ 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 @@ -1231,7 +1285,7 @@ | otherwise = (mkEntityDefName entDef, []) - cols :: [VarBangType] + cols :: [(VarBangType, Maybe Text)] cols = do fieldDef <- getUnboundFieldDefs entDef let @@ -1243,11 +1297,13 @@ 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) @@ -2991,11 +3047,7 @@ mkEntityFieldConstr fieldHaskellName mkInstance fieldNameT fieldTypeT entityFieldConstr - mkey <- - case unboundPrimarySpec ed of - NaturalKey _ -> - pure [] - _ -> do + mkey <- do let fieldHaskellName = FieldNameHS "Id" @@ -3130,7 +3182,7 @@ unFieldNameHS fieldNameHS avoidKeyword :: Text -> Text - avoidKeyword name = if name `Set.member` haskellKeywords then name ++ "_" else name + avoidKeyword name = if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name haskellKeywords :: Set.Set Text haskellKeywords = Set.fromList diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -201,7 +201,28 @@ -- 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 @@ ] Just xs -> xs - where - fields = filter isHaskellField $ entityFields ent type ExtraLine = [Text] diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.5.2 +version: 2.14.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -173,6 +173,7 @@ 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/test/Database/Persist/TH/CommentSpec.hs b/test/Database/Persist/TH/CommentSpec.hs --- a/test/Database/Persist/TH/CommentSpec.hs +++ b/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/test/Database/Persist/TH/EntityHaddockSpec.hs b/test/Database/Persist/TH/EntityHaddockSpec.hs new file mode 100644 --- /dev/null +++ b/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/test/Database/Persist/TH/OverloadedLabelSpec.hs b/test/Database/Persist/TH/OverloadedLabelSpec.hs --- a/test/Database/Persist/TH/OverloadedLabelSpec.hs +++ b/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 @@ Organization name String +Student + userId UserId + departmentName String + Primary userId |] spec :: Spec @@ -57,6 +61,12 @@ it "works for id labels" $ do let UserId = #id orgId = #id :: EntityField Organization OrganizationId + + compiles + + it "works for Primary labels" $ do + let StudentId = #id + studentId = #id :: EntityField Student StudentId compiles diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs --- a/test/Database/Persist/THSpec.hs +++ b/test/Database/Persist/THSpec.hs @@ -53,6 +53,7 @@ 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 @@ -75,7 +76,7 @@ -- machinery type TextId = Text -share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }] [persistUpperCase| +share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| Person json name Text @@ -101,6 +102,10 @@ Id sql=id_col name Text deriving Show Eq + +QualifiedReference + jsonEncoding JsonEncodingSpec.JsonEncodingId + |] mkPersist sqlSettings [persistLowerCase| @@ -204,7 +209,15 @@ ToFromPersistValuesSpec.spec JsonEncodingSpec.spec CommentSpec.spec + EntityHaddockSpec.spec CompositeKeyStyleSpec.spec + it "QualifiedReference" $ do + let ed = entityDef @QualifiedReference Proxy + [FieldDef {..}] = entityFields ed + fieldType `shouldBe` FTTypeCon (Just "JsonEncodingSpec") "JsonEncodingId" + fieldSqlType `shouldBe` sqlType @JsonEncodingSpec.JsonEncodingId Proxy + fieldReference `shouldBe` ForeignRef (EntityNameHS "JsonEncoding") + describe "TestDefaultKeyCol" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @TestDefaultKeyCol))