diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for persistent-documentation +## 0.1.0.3 + +* Support `persistent-2.12` and `persistent-2.13`. [#4](https://github.com/lumihq/persistent-documentation/pull/4) + ## 0.1.0.2 * Support `persistent-2.11.0.0` [#3](https://github.com/lumihq/persistent-documentation/pull/3) diff --git a/persistent-documentation.cabal b/persistent-documentation.cabal --- a/persistent-documentation.cabal +++ b/persistent-documentation.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: persistent-documentation -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Documentation DSL for persistent entities description: A convenient DSL that allows you to attach documentation to persistent database entities -- bug-reports: @@ -44,6 +44,8 @@ test default-language: Haskell2010 + build-tool-depends: + hspec-discover:hspec-discover build-depends: base >= 4.9 && < 5 , containers diff --git a/src/Database/Persist/Documentation.hs b/src/Database/Persist/Documentation.hs --- a/src/Database/Persist/Documentation.hs +++ b/src/Database/Persist/Documentation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} @@ -152,7 +153,7 @@ import Control.Monad.Writer import qualified Data.Char as Char -import Data.Foldable (fold) +import Data.Foldable (fold, toList) import Data.Map (Map) import qualified Data.Map as Map import Data.String @@ -166,6 +167,12 @@ import Data.StrMap import Database.Persist.Documentation.Internal +#if MIN_VERSION_persistent(2,13,0) +import Database.Persist.EntityDef.Internal +import Database.Persist.FieldDef.Internal +import Database.Persist.Quasi.Internal +#endif + -- | This function accepts a list of 'EntityDef' and an 'EntityDoc' block, and -- substitutes the 'entityComments' and 'fieldComments' from the -- 'EntityDoc'. @@ -178,14 +185,25 @@ typeReps = Map.mapKeys show (unSemiMap schemaDocs) associate edef = let - tyStr = Text.unpack . unHaskellName . entityHaskell $ edef + tyStr = Text.unpack . unEntityNameHS . entityHaskell $ edef in case Map.lookup tyStr typeReps of Just (SomeDocs (EntityDocs e cs)) -> edef { entityComments = Just e , entityFields = alignFields (entityFields edef) cs - , entityId = head (alignFields [entityId edef] cs) + , entityId = +#if MIN_VERSION_persistent(2,13,0) + case getEntityIdField edef of + Nothing -> + entityId edef + Just field -> + -- this is safe because it's a `map`, under the + -- hood + head $ EntityIdField <$> alignFields [field] cs +#else + head $ alignFields [entityId edef] cs +#endif } Nothing -> edef @@ -215,7 +233,7 @@ where f ent = renderEntity ent entityDocs renderedFields where - fields = entityId ent : entityFields ent + fields = toList $ keyAndEntityFields ent entityDocs = entityComments ent renderedFields = renderFields (map (\f -> renderField f (fieldComments f)) fields) @@ -271,10 +289,11 @@ markdownTableRenderer :: Renderer Text markdownTableRenderer = Renderer{..} where + renderField :: FieldDef -> Maybe Text -> Text renderField FieldDef{..} mextra = fold [ "| `" - , unDBName fieldDB + , unFieldNameDB fieldDB , "` | " , showType fieldSqlType , " | " @@ -282,23 +301,35 @@ , " |" ] + renderFields :: [Text] -> Text renderFields xs = Text.unlines $ "| Column name | Type | Description |" : "|-|-|-|" : xs - renderEntity EntityDef{..} mdocs fields = - Text.unlines - [ "# `" <> unDBName entityDB <> "`" - , case mdocs of + renderEntity :: EntityDef -> Maybe Text -> Text -> Text + renderEntity ed@EntityDef{..} mdocs fields = + Text.unlines (concat + [ pure $ "# `" <> unEntityNameDB entityDB <> "`" + , pure $ case mdocs of Just entityDocs -> "\n" <> entityDocs <> "\n" Nothing -> "" - , "* Primary ID: `" <> unDBName (fieldDB entityId) <> "`" - , "" - ] + , +#if MIN_VERSION_persistent(2,13,0) + case getEntityIdField ed of + Nothing -> + [] + Just field -> + pure $ "* Primary ID: `" <> unFieldNameDB (fieldDB field) <> "`" +#else + pure $ "* Primary ID: `" <> unFieldNameDB (fieldDB entityId) <> "`" +#endif + , pure "" + ]) <> fields + renderEntities :: [Text] -> Text renderEntities = Text.unlines @@ -338,7 +369,20 @@ -- This is necessary for using this library for internal reasons, unfortunately. -- -- @since 0.1.0.0 -deriveShowFields :: [EntityDef] -> Q [Dec] +deriveShowFields +#if MIN_VERSION_persistent(2,13,0) + :: [UnboundEntityDef] +#else + :: [EntityDef] +#endif + -> Q [Dec] deriveShowFields defs = fmap join . forM defs $ \def -> do - let name = conT . mkName . Text.unpack . unHaskellName . entityHaskell $ def + let name = conT . mkName . Text.unpack . unEntityNameHS . unname $ def [d|deriving instance Show (EntityField $(name) x)|] + where + unname = +#if MIN_VERSION_persistent(2,13,0) + getUnboundEntityNameHS +#else + entityHaskell +#endif diff --git a/src/Database/Persist/Documentation/Internal.hs b/src/Database/Persist/Documentation/Internal.hs --- a/src/Database/Persist/Documentation/Internal.hs +++ b/src/Database/Persist/Documentation/Internal.hs @@ -72,7 +72,7 @@ Nothing -> fld Just c -> fld { fieldComments = Just c } haskellNames = asHaskellNames strMap - nameAsText = lowercaseFirstChar . unHaskellName + nameAsText = lowercaseFirstChar . unFieldNameHS -- | Formats the @'SomeField' rec@ in the keys of the 'Map' to be formatted in -- the same way as the 'HaskellName' present in a 'FieldDef'. diff --git a/test/DocumentationSpec.hs b/test/DocumentationSpec.hs --- a/test/DocumentationSpec.hs +++ b/test/DocumentationSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DataKinds #-} @@ -30,6 +31,11 @@ import Database.Persist.Documentation.Internal (alignFields, single, asHaskellNames) import Data.StrMap +#if MIN_VERSION_persistent(2,13,0) +import Database.Persist.FieldDef.Internal +import Database.Persist.EntityDef.Internal +#endif + share [mkPersist sqlSettings, mkEntityDefList "entityDefs", deriveShowFields] [persistUpperCase| User firstName Text.Text @@ -66,7 +72,12 @@ let (userDoc : dogDog : userDogDoc : _) = docs describe "Example Documentation" $ do it "has documentation for ID field" $ do +#if MIN_VERSION_persistent(2,13,0) + let Just idField = getEntityIdField userDoc + fieldComments idField +#else fieldComments (entityId userDoc) +#endif `shouldBe` Just "You can document the user's ID field." it "has documentation for all User fields" $ do @@ -79,14 +90,6 @@ fieldComments userDogDog `shouldBe` Just "This should have type text." - it "has the right SQL Type" $ do - fieldSqlType userDogDog - `shouldBe` - sqlType (Proxy :: Proxy DogId) - it "has the appropriate reference" $ do - fieldReference userDogDog - `shouldBe` - ForeignRef (HaskellName "Dog") (FTTypeCon (Just "Text") "Text") describe "FieldDef" $ do let @@ -95,13 +98,13 @@ describe "fieldType" $ do it "does not have the entity prefix" $ do for_ fields $ \efield -> do - unHaskellName (fieldHaskell efield) + unFieldNameHS (fieldHaskell efield) `shouldSatisfy` (not . ("User" `Text.isPrefixOf`)) it "has a lowercase first letter" $ do for_ fields $ \efield -> do - Text.unpack (Text.take 1 (unHaskellName (fieldHaskell efield))) + Text.unpack (Text.take 1 (unFieldNameHS (fieldHaskell efield))) `shouldSatisfy` (all Char.isLower) @@ -120,7 +123,7 @@ describe "alignFields" $ do let userDef = entityDef (Nothing :: Maybe User) - fields = entityId userDef : entityFields userDef + fields = toList $ keyAndEntityFields userDef strMap@(StrMap theMap) = mconcat [ single UserFirstName "Hello, world" , single UserActive "If the user is active" @@ -135,4 +138,3 @@ Set.fromList (mapMaybe fieldComments (alignFields fields strMap)) `shouldBe` Set.fromList ["Hello, world", "If the user is active", "user identity"] -