persistent-documentation (empty) → 0.1.0.0
raw patch · 12 files changed
+1081/−0 lines, 12 filesdep +basedep +containersdep +hspecsetup-changed
Dependencies added: base, containers, hspec, hspec-discover, mtl, persistent, persistent-documentation, persistent-template, template-haskell, text
Files
- CHANGELOG.md +5/−0
- LICENSE +202/−0
- README.md +5/−0
- Setup.hs +2/−0
- persistent-documentation.cabal +54/−0
- src/Data/SemiMap.hs +17/−0
- src/Data/StrMap.hs +55/−0
- src/Database/Persist/Documentation.hs +350/−0
- src/Database/Persist/Documentation/Internal.hs +255/−0
- test/DocumentationSpec.hs +102/−0
- test/Entities.hs +33/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for persistent-documentation++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2019 Lumi++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,5 @@+# persistent-documentation++This library provides a DSL for attaching documentation to persistent entities as well as rendering documentation.++For an example, check out [the test suite](https://github.com/lumihq/persistent-documentation/blob/master/test/DocumentationSpec.hs#L30-L38), and the [rendered example](test/example.md).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ persistent-documentation.cabal view
@@ -0,0 +1,54 @@+cabal-version: >=1.10++name: persistent-documentation+version: 0.1.0.0+synopsis: Documentation DSL for persistent entities+description: A convenient DSL that allows you to attach documentation to persistent database entities+-- bug-reports:+license: Apache-2.0+license-file: LICENSE+author: parsonsmatt+maintainer: parsonsmatt@gmail.com+copyright: 2019 Lumi+category: Database+build-type: Simple+extra-source-files: CHANGELOG.md, README.md++library+ exposed-modules:+ Database.Persist.Documentation+ Database.Persist.Documentation.Internal+ Data.StrMap+ Data.SemiMap+ -- other-modules:+ build-depends: + base >= 4.9 && < 5.0+ , containers+ , persistent >= 2.10 && < 3.0+ , text+ , mtl+ , template-haskell+ hs-source-dirs: src+ default-language: Haskell2010++test-suite spec+ type: + exitcode-stdio-1.0+ main-is: + Spec.hs+ hs-source-dirs:+ test+ default-language:+ Haskell2010+ build-depends: + base >= 4.9 && < 5+ , containers+ , hspec+ , hspec-discover+ , persistent+ , persistent-documentation+ , persistent-template >= 2.7+ , text+ other-modules:+ DocumentationSpec + Entities
+ src/Data/SemiMap.hs view
@@ -0,0 +1,17 @@+module Data.SemiMap where++import Data.Map (Map)+import qualified Data.Map as Map++-- | A newtype around 'Map' which uses @'Map.unionWith' '(<>)'@ for the+-- semigroup and monoid instance.+--+-- @since 0.1.0.0+newtype SemiMap k v = SemiMap { unSemiMap :: Map k v }+ deriving (Eq, Ord, Show)++instance (Ord k, Semigroup v) => Semigroup (SemiMap k v) where+ SemiMap m0 <> SemiMap m1 = SemiMap (Map.unionWith (<>) m0 m1)++instance (Ord k, Semigroup v) => Monoid (SemiMap k v) where+ mempty = SemiMap mempty
+ src/Data/StrMap.hs view
@@ -0,0 +1,55 @@+module Data.StrMap where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text++-- | A 'StrMap' is sort of like a 'HashMap', but sorts the keys on a 'Text'+-- representation. Additionally, it has more useful 'Semigroup' and 'Monoid'+-- instances that '(<>)' the values when present.+--+-- @since 0.1.0.0+newtype StrMap k a = StrMap (Map (AsStr k) a)+ deriving (Eq, Ord, Show)++instance Semigroup a => Semigroup (StrMap k a) where+ StrMap as <> StrMap bs = StrMap $+ Map.unionWith (<>) as bs++instance Semigroup a => Monoid (StrMap k a) where+ mempty = StrMap mempty++-- | Insert a value into a 'StrMap'.+--+-- @since 0.1.0.0+insert :: Show k => k -> a -> StrMap k a -> StrMap k a+insert k a (StrMap m) = StrMap (Map.insert (asStr k) a m)++-- | Lookup a value in the 'StrMap'.+--+-- @since 0.1.0.0+lookup :: Show k => k -> StrMap k a -> Maybe a+lookup k (StrMap m) = Map.lookup (asStr k) m++-- | A datatype for representing the keys of entries in a 'StrMap'.+-- Contains the original value as well as the 'Text'ual representation of+-- that value.+--+-- The 'Eq' and 'Ord' instances only use the 'Text' value.+--+-- @since 0.1.0.0+data AsStr k = AsStr { asStrText :: Text, asStrValue :: k } deriving Show++instance Eq (AsStr k) where+ AsStr a _ == AsStr b _ = a == b++instance Ord (AsStr k) where+ AsStr a _ `compare` AsStr b _ = compare a b++-- | Pack a value into an 'AsStr' of that value.+--+-- @since 0.1.0.0+asStr :: Show k => k -> AsStr k+asStr k = AsStr (Text.pack (show k)) k+
+ src/Database/Persist/Documentation.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++-- | This module contains code for documenting a set of @persistent@ entity+-- definitions. All the library provides is a means to render a Markdown+-- document with table and column documentation and comments. A further+-- expansion could use the information here to generate PostgreSQL @COMMENT@s on+-- the fields and tables too.+--+-- = Getting Started+--+-- You probably already have a @persistent@ entity definitions somewhere, and+-- they probably look like this:+--+-- @+-- 'share' ['mkPersist' 'sqlSettings'] ['persistUpperCase'|+-- User+-- firstName Text.Text+-- active Bool+-- deriving Show Eq Read Ord+-- |]+-- @+--+-- The 'persistUpperCase' QuasiQuoter parses the block of text and returns+-- a value of type @['EntityDef']@. We need to get our hands on that+-- definition so we can document it.+--+-- Due to GHC staging restrictions, we have to extract the QuasiQuoter (or+-- file parser) into a separate module:+--+-- @+-- module Entities where+--+-- entityDefs :: ['EntityDef']+-- entityDefs = ['persistUpperCase'|+-- User+-- firstName Text.Text+-- active Bool+-- deriving Show Eq Read Ord+-- |]+-- @+--+-- Now, we'll import that value, and use it with the Template Haskell+-- function. We also need to use 'deriveShowFields' to derive instances of+-- 'Show' for the 'EntityField's that are generated.+--+-- @+-- 'share' ['mkPersist' 'sqlSettings', 'deriveShowFields'] entityDefs+-- @+--+-- That's all the setup we need to start writing documentation for our+-- entites.+--+-- = Documentating The Schema+--+-- Now, we're going to use the 'document' function to link up the+-- @entityDefs@ with a documentation expression (type 'EntityDoc').+--+-- @+-- docs :: ['EntityDef']+-- docs = 'document' entityDefs (pure ())+-- @+--+-- The 'EntityDoc' type is a monad, and we'll use @do@ notation to sequence+-- multiple entity definitions.+--+-- @+-- docs :: ['EntityDef']+-- docs = 'document' entityDefs $ do+-- User --^ do+-- pure ()+-- @+--+-- The '(--^)' operator mimics the Haddock comment syntax. We use the+-- constructor of the entity (in this case, @User@). On the right, we+-- provide documentation for the entity. The right hand expression will+-- have the type 'FieldDoc', and we can use @do@ notation to construct it.+--+-- We can use string literals to document the entity itself, with the+-- @OverloadedStrings@ extension enabled. The string literals are+-- concatenated, and used to provide entity-level comments. You'll need to+-- manage whitespace yourself, though.+--+-- @+-- docs :: ['EntityDef']+-- docs = 'document' entityDefs $ do+-- User --^ do+-- "This is user documentation. "+-- "You can have multiple lines, but you need to watch out for spaces. "+-- "The lines will be combined."+-- @+--+-- We can also document the entity fields. We do this using the '(#)'+-- operator.+--+-- @+-- docs :: ['EntityDef']+-- docs = 'document' entityDefs $ do+-- User --^ do+-- "This is user documentation. "+-- "You can have multiple lines, but you need to watch out for spaces. "+-- "The lines will be combined."+--+-- UserFirstName # "The user's first name."+-- UserActive # "Whether or not the user is able to log in."+-- @+--+-- This attaches the comment to the entity field.+--+-- = Rendering the Documentation+--+-- Finally, we'll use 'render' and provide a 'Renderer' to generate+-- documentation. For an example of what this looks like, check out the+-- file @test/example.md@ in the repository (linked from the README).+--+-- @+-- renderedDocs :: Text+-- renderedDocs = 'render' 'markdownTableRenderer' docs+-- @+module Database.Persist.Documentation+ ( -- * The Documentation DSL+ document+ , (--^)+ , (#)+ , EntityDoc+ , FieldDoc+ , deriveShowFields+ -- * Rendering Documentation+ , Renderer(..)+ , render+ , markdownTableRenderer+ ) where++import Control.Monad.Writer+import qualified Data.Char as Char+import Data.Foldable (fold)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Typeable+import Database.Persist.Sql hiding (insert)+import Language.Haskell.TH++import Data.StrMap+import Data.SemiMap+import Database.Persist.Documentation.Internal++-- | This function accepts a list of 'EntityDef' and an 'EntityDoc' block, and+-- substitutes the 'entityComments' and 'fieldComments' from the+-- 'EntityDoc'.+--+-- @since 0.1.0.0+document :: [EntityDef] -> EntityDoc -> [EntityDef]+document entities (ED docs) = fmap associate entities+ where+ schemaDocs = execWriter docs+ typeReps = Map.mapKeys show (unSemiMap schemaDocs)+ associate edef =+ let+ tyStr = Text.unpack . unHaskellName . 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)+ }+ Nothing -> edef++-- | A renderer for documented entities, abstract in the intermediate+-- representations of entities and fields.+--+-- @since 0.1.0.0+data Renderer rendered where+ Renderer+ :: { renderField :: FieldDef -> Maybe Text -> renderedField+ -- ^ Render a field definition as some intermediate structure+ , renderFields :: [renderedField] -> renderedFields+ -- ^ Fold a collection of rendered fields+ , renderEntity :: EntityDef -> Maybe Text -> renderedFields -> renderedEntity+ -- ^ Attach some entity-level metadata to a rendered collection of fields+ , renderEntities :: [renderedEntity] -> rendered+ -- ^ Finally, fold a collection of rendered entities+ }+ -> Renderer rendered++-- | Given a 'Renderer' for a list of entity defintiions, render it.+--+-- @since 0.1.0.0+render :: Renderer rendered -> [EntityDef] -> rendered+render Renderer{..} =+ renderEntities . map f+ where+ f ent = renderEntity ent entityDocs renderedFields+ where+ fields = entityId ent : entityFields ent+ entityDocs = entityComments ent+ renderedFields =+ renderFields (map (\f -> renderField f (fieldComments f)) fields)++-- | A 'Renderer' that generates Markdown tables for an entity.+--+-- === __ Example __+--+-- Given 'entityDefs' like:+--+-- @+-- entityDefs :: ['EntityDef']+-- entityDefs = ['persistUpperCase'|+-- User+-- firstName Text.Text+-- active Bool+-- deriving Show Eq Read Ord+-- |]+-- @+--+-- and a doc block like:+--+-- @+-- docs :: [EntityDef]+-- docs = document entityDefs $ do+-- User --^ do+-- "you can use string literals to write documentation for the entity itself. "+-- "The strings will be mappended together, so you'll need to handle "+-- "whitespace yourself."+-- UserFirstName # "The user's first name."+-- UserActive # "Whether or not the user is able to log in."+-- UserId # "You can document the user's ID field."+-- @+--+-- This will rende the given Markdown output:+--+-- @+-- # `User`+--+-- you can use string literals to write documentation for the entity itself. The strings will be+-- mappended together, so you'll need to handle whitespace yourself.+--+-- * Primary ID: `id`+--+-- | Column name | Type | Description |+-- |-|-|-|+-- | `id` | integer (64) | You can document the user's ID field. |+-- | `firstName` | string | The user's first name. |+-- | `active` | boolean | Whether or not the user is able to log in. |+-- @+--+-- @since 0.1.0.0+markdownTableRenderer :: Renderer Text+markdownTableRenderer = Renderer{..}+ where+ renderField FieldDef{..} mextra =+ fold+ [ "| `"+ , unDBName fieldDB+ , "` | "+ , showType fieldSqlType+ , " | "+ , fold mextra+ , " |"+ ]++ renderFields xs =+ Text.unlines $+ "| Column name | Type | Description |"+ : "|-|-|-|"+ : xs++ renderEntity EntityDef{..} mdocs fields =+ Text.unlines+ [ "# `" <> unDBName entityDB <> "`"+ , case mdocs of+ Just entityDocs -> "\n" <> entityDocs <> "\n"+ Nothing -> ""+ , "* Primary ID: `" <> unDBName (fieldDB entityId) <> "`"+ , ""+ ]+ <> fields++ renderEntities =+ Text.unlines++ showType SqlString = "string"+ showType SqlInt32 = "integer (32)"+ showType SqlInt64 = "integer (64)"+ showType SqlReal = "double"+ showType SqlNumeric{} = "numeric"+ showType SqlDay = "date"+ showType SqlTime = "time"+ showType SqlDayTime = "datetime"+ showType SqlBlob = "blob"+ showType SqlBool = "boolean"+ showType (SqlOther t) = t++-- | Render the '[EntityDef]' into a Markdown table representation. See+-- 'markdownTable+--+-- @since 0.1.0.0+toMarkdownTables :: [EntityDef] -> Text+toMarkdownTables = render markdownTableRenderer++-- | Formats the @'SomeField' rec@ in the keys of the 'Map' to be formatted in+-- the same way as the 'HaskellName' present in a 'FieldDef'.+--+-- @since 0.1.0.0+asHaskellNames+ :: forall rec. RC rec+ => StrMap (SomeField rec) Text -> Map Text Text+asHaskellNames (StrMap extraDocMap) =+ Map.mapKeys (lowercaseFirstChar . Text.drop (length recName) . asStrText) extraDocMap+ where+ recName =+ show (typeRep (Proxy @rec))++-- | Given a list of entity definitions, derives `Show` for all their fields.+-- This is necessary for using this library for internal reasons, unfortunately.+--+-- @since 0.1.0.0+deriveShowFields :: [EntityDef] -> Q [Dec]+deriveShowFields defs = fmap join . forM defs $ \def -> do+ let name = conT . mkName . Text.unpack . unHaskellName . entityHaskell $ def+ [d|deriving instance Show (EntityField $(name) x)|]
+ src/Database/Persist/Documentation/Internal.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++-- | This module defines the helpers and internal types that are used in+-- the documentation DSL.+module Database.Persist.Documentation.Internal where++import Control.Monad.Writer+import qualified Data.Char as Char+import Data.Foldable (fold)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Typeable+import Database.Persist.Sql hiding (insert)+import Language.Haskell.TH++import Data.StrMap+import Data.SemiMap++-- | Given a list of 'FieldDef's, this associates each 'FieldDef' with the+-- additional documentation comment provided in the @'StrMap' ('SomeField' rec)+-- 'Text'@ for that entity, if any is present.+--+-- Precondition: The @['FieldDef']@ comes from the @'PersistEntity' rec@ that+-- this is called for. Doing eg:+--+-- @+-- alignFields+-- (entityFields (entityDef (Proxy :: Proxy User)))+-- (strMap :: StrMap (SomeField Order) Text)+-- @+--+-- will be extremely weird.+--+-- @since 0.1.0.0+alignFields+ :: forall rec. RC rec+ => [FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]+alignFields fields strMap =+ map findFieldDoc fields+ where+ findFieldDoc fld@FieldDef{..} =+ case Map.lookup (nameAsText fieldHaskell) haskellNames of+ Nothing -> fld+ Just c -> fld { fieldComments = Just c }+ haskellNames = asHaskellNames strMap+ nameAsText = lowercaseFirstChar . unHaskellName++-- | Formats the @'SomeField' rec@ in the keys of the 'Map' to be formatted in+-- the same way as the 'HaskellName' present in a 'FieldDef'.+--+-- @since 0.1.0.0+asHaskellNames+ :: forall rec. RC rec+ => StrMap (SomeField rec) Text -> Map Text Text+asHaskellNames (StrMap extraDocMap) =+ Map.mapKeys (lowercaseFirstChar . Text.drop (length recName) . asStrText) extraDocMap+ where+ recName =+ show (typeRep (Proxy @rec))++-- | A type for defining documentation for a schema.+--+-- @since 0.1.0.0+newtype EntityDoc' a = ED (Writer SchemaDocs a)+ deriving (Functor, Applicative, Monad, MonadWriter SchemaDocs)++-- | The 'SchemaDocs' maps a 'TypeRep' of the @'Entity' rec@ that is documented+-- to the 'SomeDocs' for that entity.+--+-- @since 0.1.0.0+type SchemaDocs = SemiMap TypeRep SomeDocs++-- | A wrapper around 'EntityDocs' that allows them to be stored in a list+-- together. Contains the 'RC' constraint alias, which will ensure that all+-- necessary constraints for document rendering are packaged in.+data SomeDocs where+ SomeDocs :: RC rec => EntityDocs rec -> SomeDocs++instance Semigroup SomeDocs where+ SomeDocs (r0 :: EntityDocs r0) <> SomeDocs (r1 :: EntityDocs r1) =+ case eqT @r0 @r1 of+ Just Refl -> SomeDocs (r0 <> r1)+ Nothing -> SomeDocs r0++-- | Expand this constraint synonym to pack necessary constraints in with the+-- 'EntityDocs' type. Used in a few places to ensure that constraints are easy to+-- modify in one place.+--+-- @since 0.1.0.0+type RC rec = (Typeable rec)++-- | 'EntityDocs' contain the documentation comment for the @'Entity' rec@ that+-- is being documented, as well as a map of documentation for the fields of that+-- entity.+--+-- @since 0.1.0.0+data EntityDocs rec = EntityDocs+ { entityDocumentation :: Text+ , fieldDocumentation :: StrMap (SomeField rec) Text+ }++instance Semigroup (EntityDocs rec) where+ EntityDocs d0 f0 <> EntityDocs d1 f1 = EntityDocs (d0 <> d1) (f0 <> f1)++instance Monoid (EntityDocs rec) where+ mempty = EntityDocs mempty mempty++-- | An expression of 'EntityDoc' is used to document the persistent+-- schema. To construct an 'EntityDoc', you'll use the 'Entity' constructor+-- and the '(--^)' operator. Everything to the right of the '(--^)'+-- operator is a 'FieldDoc rec' for the given entity.+--+-- This type is a monad, and you can use @do@ notation to sequence the+-- documentation.+--+-- @+-- doc :: 'EntityDoc'+-- doc = do+-- User --^ "Documentation for a User"+-- Dog --^ "Documentation for a Dog"+-- @+--+-- @since 0.1.0.0+type EntityDoc = EntityDoc' ()++-- | A 'FieldDoc' expression provides documentation for the given 'Entity'.+-- This type is a 'Monad' and you will want to use @do@ notation to create+-- this.+--+-- There are two ways to create 'FieldDoc' lines:+--+-- * String literals. These are collected and appended as documentation for+-- the entity itself.+-- * The '(#)' operator, which accepts an 'EntityField' and the text+-- documentation for that entity.+--+-- @since 0.1.0.0+type FieldDoc s = FieldDoc' s ()++-- | Wrap the result type of a 'EntityField' value so it can be stored in+-- homogenous containers.+--+-- @since 0.1.0.0+data SomeField rec where+ SomeField :: FC rec typ => EntityField rec typ -> SomeField rec++-- | We need this instance so we can store 'SomeField' values in the 'StrMap'.+-- The quantified constraint ensures that we can show the underlying field. The+-- 'deriveShowFields' function defined later ensures that this is defined for+-- records in the schema.+instance (forall typ. Show (EntityField rec typ)) => Show (SomeField rec) where+ show (SomeField fld) = show fld++-- | Expand this constraint synonym to pack necessary constraints for packing+-- 'EntityField' values into 'SomeField's.+type FC rec typ = forall x. Show (EntityField rec x)++-- | A monad for writing documentation on an entity's fields. Collects the+-- documentation into a 'Writer'.+--+-- @since 0.1.0.0+newtype FieldDoc' rec a = FD (Writer (EntityDocs rec) a)+ deriving (Functor, Applicative, Monad, MonadWriter (EntityDocs rec))++single+ :: FC rec typ+ => EntityField rec typ -> Text -> StrMap (SomeField rec) Text+single k t = insert (SomeField k) t mempty++type family KnowResult a where+ KnowResult (i -> o) = KnowResult o+ KnowResult a = a++instance (a ~ ()) => IsString (FieldDoc' s a) where+ fromString str = tell mempty { entityDocumentation = Text.pack str }++lowercaseFirstChar :: Text -> Text+lowercaseFirstChar txt = case Text.uncons txt of+ Just (c, r) -> Char.toLower c `Text.cons` r+ Nothing -> ""++-- | Define documentation for an entity. The left-hand side takes the+-- 'Entity' constructor, and the right hand side takes a 'FieldDoc'+-- expression that documents the entity and it's fields.+--+-- === __ Example __+--+-- @+-- x :: EntityDoc+-- x = do+-- User --^ do+-- "This comment is for the entity User."+-- UserName # "This comment is for a field.""+-- @+--+-- @since 0.1.0.0+(--^)+ :: forall a r. (KnowResult a ~ r, Typeable r, RC r)+ => a+ -- ^ A constructor for the @'Entity' r@ you want to document.+ -> FieldDoc r+ -- ^ A block that contains documentation for the @'Entity' r@.+ -> EntityDoc+_ --^ FD fieldDocs =+ tell+ . SemiMap+ $ Map.singleton+ (typeRep (Proxy @r))+ (SomeDocs (execWriter fieldDocs))++-- | Write documentation for the given 'EntityField'.+--+-- === __ Example __+--+-- @+-- x :: EntityDoc+-- x = do+-- User --^ do+-- "This comment is for the entity User."+-- UserName # "This comment is for a field.""+-- @+--+-- @since 0.1.0.0+(#) :: FC rec typ => EntityField rec typ -> Text -> FieldDoc rec+field # txt = tell mempty { fieldDocumentation = insert (SomeField field) txt mempty }+
+ test/DocumentationSpec.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}++module DocumentationSpec where++import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Maybe+import Data.Foldable+import Test.Hspec+import Database.Persist.Sql+import Database.Persist.TH++import Database.Persist.Documentation+import Database.Persist.Documentation.Internal (alignFields, single, asHaskellNames)+import Data.StrMap+import Entities++share [mkPersist sqlSettings, deriveShowFields] entityDefs++docs :: [EntityDef]+docs = document entityDefs $ do+ User --^ do+ "you can use string literals to write documentation for the entity itself. "+ "The strings will be mappended together, so you'll need to handle "+ "whitespace yourself."+ UserFirstName # "The user's first name."+ UserActive # "Whether or not the user is able to log in."+ UserId # "You can document the user's ID field."++spec :: Spec+spec = do+ runIO $ Text.writeFile "test/example.md" $ render markdownTableRenderer docs+ describe "Example Documentation" $ do+ it "has documentation for ID field" $ do+ fieldComments (entityId (head docs))+ `shouldBe`+ Just "You can document the user's ID field."+ it "has documentation for all fields" $ do+ for_ docs $ \ed ->+ for_ (entityFields ed) $ \f ->+ fieldComments f `shouldSatisfy` isJust++ describe "FieldDef" $ do+ let+ edef = entityDef (Nothing :: Maybe User)+ fields = entityFields edef+ describe "fieldType" $ do+ it "does not have the entity prefix" $ do+ for_ fields $ \efield -> do+ unHaskellName (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)))+ `shouldSatisfy`+ (all Char.isLower)++ describe "asHaskellNames" $ do+ let+ strMap = mconcat+ [ single UserFirstName "Hello, world"+ , single UserActive "If the user is active"+ , single UserId "UserID"+ ]+ it "formats the EntityField so it corresponds with the HaskellName" $ do+ Set.fromList (Map.keys (asHaskellNames strMap))+ `shouldBe`+ Set.fromList ["firstName", "active", "id"]++ describe "alignFields" $ do+ let+ userDef = entityDef (Nothing :: Maybe User)+ fields = entityId userDef : entityFields userDef+ strMap@(StrMap theMap) = mconcat+ [ single UserFirstName "Hello, world"+ , single UserActive "If the user is active"+ , single UserId "user identity"+ ]+ it "strMap contains an easy-to-find field name" $ do+ Set.fromList (fmap asStrText (Map.keys theMap))+ `shouldBe`+ Set.fromList ["UserActive", "UserFirstName", "UserId"]++ it "has Text for fields with a documented entry in the StrMap" $ do+ Set.fromList (mapMaybe fieldComments (alignFields fields strMap))+ `shouldBe`+ Set.fromList ["Hello, world", "If the user is active", "user identity"]+
+ test/Entities.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}++module Entities where++import qualified Data.Char as Char+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import Data.Maybe+import Data.Foldable+import Test.Hspec+import Database.Persist.Sql+import Database.Persist.TH++import Database.Persist.Documentation++entityDefs :: [EntityDef]+entityDefs = [persistUpperCase|+ User+ firstName Text.Text+ active Bool+ deriving Show Eq Read Ord+|]+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}