diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for persistent-documentation + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/persistent-documentation.cabal b/persistent-documentation.cabal new file mode 100644 --- /dev/null +++ b/persistent-documentation.cabal @@ -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 diff --git a/src/Data/SemiMap.hs b/src/Data/SemiMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/SemiMap.hs @@ -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 diff --git a/src/Data/StrMap.hs b/src/Data/StrMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/StrMap.hs @@ -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 + diff --git a/src/Database/Persist/Documentation.hs b/src/Database/Persist/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Documentation.hs @@ -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)|] diff --git a/src/Database/Persist/Documentation/Internal.hs b/src/Database/Persist/Documentation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Documentation/Internal.hs @@ -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 } + diff --git a/test/DocumentationSpec.hs b/test/DocumentationSpec.hs new file mode 100644 --- /dev/null +++ b/test/DocumentationSpec.hs @@ -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"] + diff --git a/test/Entities.hs b/test/Entities.hs new file mode 100644 --- /dev/null +++ b/test/Entities.hs @@ -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 +|] + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}