persistent-documentation 0.1.0.2 → 0.1.0.3
raw patch · 5 files changed
+80/−28 lines, 5 filesdep ~persistentPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: persistent
API changes (from Hackage documentation)
- Database.Persist.Documentation: deriveShowFields :: [EntityDef] -> Q [Dec]
+ Database.Persist.Documentation: deriveShowFields :: [UnboundEntityDef] -> Q [Dec]
Files
- CHANGELOG.md +4/−0
- persistent-documentation.cabal +3/−1
- src/Database/Persist/Documentation.hs +58/−14
- src/Database/Persist/Documentation/Internal.hs +1/−1
- test/DocumentationSpec.hs +14/−12
CHANGELOG.md view
@@ -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)
persistent-documentation.cabal view
@@ -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
src/Database/Persist/Documentation.hs view
@@ -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
src/Database/Persist/Documentation/Internal.hs view
@@ -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'.
test/DocumentationSpec.hs view
@@ -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"]-