persistent 2.14.5.2 → 2.14.6.0
raw patch · 12 files changed
+199/−36 lines, 12 files
Files
- ChangeLog.md +13/−0
- Database/Persist/Class/PersistEntity.hs +14/−0
- Database/Persist/Class/PersistStore.hs +1/−1
- Database/Persist/Quasi.hs +2/−2
- Database/Persist/Sql/Orphan/PersistStore.hs +1/−1
- Database/Persist/TH.hs +63/−11
- Database/Persist/Types/Base.hs +22/−3
- persistent.cabal +2/−1
- test/Database/Persist/TH/CommentSpec.hs +7/−2
- test/Database/Persist/TH/EntityHaddockSpec.hs +36/−0
- test/Database/Persist/TH/OverloadedLabelSpec.hs +24/−14
- test/Database/Persist/THSpec.hs +14/−1
ChangeLog.md view
@@ -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)
Database/Persist/Class/PersistEntity.hs view
@@ -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.
Database/Persist/Class/PersistStore.hs view
@@ -79,7 +79,7 @@ -- @ -- foo :: -- ( 'PersistEntity' record--- , 'PeristEntityBackend' record ~ 'BaseBackend' backend+-- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @
Database/Persist/Quasi.hs view
@@ -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 <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>.-@persistent@ backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> 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 <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions. = Sum types
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -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
Database/Persist/TH.hs view
@@ -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
Database/Persist/Types/Base.hs view
@@ -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]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.14.5.2+version: 2.14.6.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -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
test/Database/Persist/TH/CommentSpec.hs view
@@ -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.
+ test/Database/Persist/TH/EntityHaddockSpec.hs view
@@ -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
test/Database/Persist/TH/OverloadedLabelSpec.hs view
@@ -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
test/Database/Persist/THSpec.hs view
@@ -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))