{-# 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)|]