{-# LANGUAGE CPP #-}
{-# 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 #-}
module Database.Persist.Documentation
(
document
, (--^)
, (#)
, EntityDoc
, FieldDoc
, deriveShowFields
, Renderer(..)
, render
, markdownTableRenderer
) where
import Control.Monad.Writer
import qualified Data.Char as Char
import Data.Foldable (fold, toList)
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.SemiMap
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
document :: [EntityDef] -> EntityDoc -> [EntityDef]
document :: [EntityDef] -> EntityDoc -> [EntityDef]
document [EntityDef]
entities (ED Writer SchemaDocs ()
docs) = (EntityDef -> EntityDef) -> [EntityDef] -> [EntityDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EntityDef -> EntityDef
associate [EntityDef]
entities
where
schemaDocs :: SchemaDocs
schemaDocs = Writer SchemaDocs () -> SchemaDocs
forall w a. Writer w a -> w
execWriter Writer SchemaDocs ()
docs
typeReps :: Map String SomeDocs
typeReps = (TypeRep -> String) -> Map TypeRep SomeDocs -> Map String SomeDocs
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys TypeRep -> String
forall a. Show a => a -> String
show (SchemaDocs -> Map TypeRep SomeDocs
forall k v. SemiMap k v -> Map k v
unSemiMap SchemaDocs
schemaDocs)
associate :: EntityDef -> EntityDef
associate EntityDef
edef =
let
tyStr :: String
tyStr = Text -> String
Text.unpack (Text -> String) -> (EntityDef -> Text) -> EntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (EntityDef -> EntityNameHS) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> String) -> EntityDef -> String
forall a b. (a -> b) -> a -> b
$ EntityDef
edef
in
case String -> Map String SomeDocs -> Maybe SomeDocs
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
tyStr Map String SomeDocs
typeReps of
Just (SomeDocs (EntityDocs Text
e StrMap (SomeField rec) Text
cs)) ->
EntityDef
edef
{ entityComments :: Maybe Text
entityComments = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
e
, entityFields :: [FieldDef]
entityFields = [FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
forall rec.
RC rec =>
[FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
alignFields (EntityDef -> [FieldDef]
entityFields EntityDef
edef) StrMap (SomeField rec) Text
cs
, entityId :: EntityIdDef
entityId =
#if MIN_VERSION_persistent(2,13,0)
case EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
edef of
Maybe FieldDef
Nothing ->
EntityDef -> EntityIdDef
entityId EntityDef
edef
Just FieldDef
field ->
[EntityIdDef] -> EntityIdDef
forall a. [a] -> a
head ([EntityIdDef] -> EntityIdDef) -> [EntityIdDef] -> EntityIdDef
forall a b. (a -> b) -> a -> b
$ FieldDef -> EntityIdDef
EntityIdField (FieldDef -> EntityIdDef) -> [FieldDef] -> [EntityIdDef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
forall rec.
RC rec =>
[FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
alignFields [FieldDef
field] StrMap (SomeField rec) Text
cs
#else
head $ alignFields [entityId edef] cs
#endif
}
Maybe SomeDocs
Nothing -> EntityDef
edef
data Renderer rendered where
Renderer
:: { ()
renderField :: FieldDef -> Maybe Text -> renderedField
, ()
renderFields :: [renderedField] -> renderedFields
, ()
renderEntity :: EntityDef -> Maybe Text -> renderedFields -> renderedEntity
, ()
renderEntities :: [renderedEntity] -> rendered
}
-> Renderer rendered
render :: Renderer rendered -> [EntityDef] -> rendered
render :: Renderer rendered -> [EntityDef] -> rendered
render Renderer{[renderedField] -> renderedFields
[renderedEntity] -> rendered
EntityDef -> Maybe Text -> renderedFields -> renderedEntity
FieldDef -> Maybe Text -> renderedField
renderEntities :: [renderedEntity] -> rendered
renderEntity :: EntityDef -> Maybe Text -> renderedFields -> renderedEntity
renderFields :: [renderedField] -> renderedFields
renderField :: FieldDef -> Maybe Text -> renderedField
renderEntities :: ()
renderEntity :: ()
renderFields :: ()
renderField :: ()
..} =
[renderedEntity] -> rendered
renderEntities ([renderedEntity] -> rendered)
-> ([EntityDef] -> [renderedEntity]) -> [EntityDef] -> rendered
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityDef -> renderedEntity) -> [EntityDef] -> [renderedEntity]
forall a b. (a -> b) -> [a] -> [b]
map EntityDef -> renderedEntity
f
where
f :: EntityDef -> renderedEntity
f EntityDef
ent = EntityDef -> Maybe Text -> renderedFields -> renderedEntity
renderEntity EntityDef
ent Maybe Text
entityDocs renderedFields
renderedFields
where
fields :: [FieldDef]
fields = NonEmpty FieldDef -> [FieldDef]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty FieldDef -> [FieldDef])
-> NonEmpty FieldDef -> [FieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> NonEmpty FieldDef
keyAndEntityFields EntityDef
ent
entityDocs :: Maybe Text
entityDocs = EntityDef -> Maybe Text
entityComments EntityDef
ent
renderedFields :: renderedFields
renderedFields =
[renderedField] -> renderedFields
renderFields ((FieldDef -> renderedField) -> [FieldDef] -> [renderedField]
forall a b. (a -> b) -> [a] -> [b]
map (\FieldDef
f -> FieldDef -> Maybe Text -> renderedField
renderField FieldDef
f (FieldDef -> Maybe Text
fieldComments FieldDef
f)) [FieldDef]
fields)
markdownTableRenderer :: Renderer Text
markdownTableRenderer :: Renderer Text
markdownTableRenderer = Renderer :: forall renderedField renderedFields renderedEntity rendered.
(FieldDef -> Maybe Text -> renderedField)
-> ([renderedField] -> renderedFields)
-> (EntityDef -> Maybe Text -> renderedFields -> renderedEntity)
-> ([renderedEntity] -> rendered)
-> Renderer rendered
Renderer{[Text] -> Text
EntityDef -> Maybe Text -> Text -> Text
FieldDef -> Maybe Text -> Text
renderEntities :: [Text] -> Text
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderFields :: [Text] -> Text
renderField :: FieldDef -> Maybe Text -> Text
renderEntities :: [Text] -> Text
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderFields :: [Text] -> Text
renderField :: FieldDef -> Maybe Text -> Text
..}
where
renderField :: FieldDef -> Maybe Text -> Text
renderField :: FieldDef -> Maybe Text -> Text
renderField FieldDef{Bool
[FieldAttr]
Maybe Text
FieldType
ReferenceDef
FieldCascade
SqlType
FieldNameDB
FieldNameHS
fieldHaskell :: FieldDef -> FieldNameHS
fieldDB :: FieldDef -> FieldNameDB
fieldType :: FieldDef -> FieldType
fieldSqlType :: FieldDef -> SqlType
fieldAttrs :: FieldDef -> [FieldAttr]
fieldStrict :: FieldDef -> Bool
fieldReference :: FieldDef -> ReferenceDef
fieldCascade :: FieldDef -> FieldCascade
fieldGenerated :: FieldDef -> Maybe Text
fieldIsImplicitIdColumn :: FieldDef -> Bool
fieldIsImplicitIdColumn :: Bool
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: FieldNameDB
fieldHaskell :: FieldNameHS
fieldComments :: FieldDef -> Maybe Text
..} Maybe Text
mextra =
[Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Text
"| `"
, FieldNameDB -> Text
unFieldNameDB FieldNameDB
fieldDB
, Text
"` | "
, SqlType -> Text
showType SqlType
fieldSqlType
, Text
" | "
, (Text -> Text) -> Maybe Text -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Text
cleanComment Maybe Text
mextra
, Text
" |"
]
renderFields :: [Text] -> Text
renderFields :: [Text] -> Text
renderFields [Text]
xs =
[Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
Text
"| Column name | Type | Description |"
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"|-|-|-|"
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderEntity ed :: EntityDef
ed@EntityDef{Bool
[Text]
[UniqueDef]
[ForeignDef]
[FieldDef]
Maybe Text
Map Text [[Text]]
EntityIdDef
EntityNameHS
EntityNameDB
entityDB :: EntityDef -> EntityNameDB
entityAttrs :: EntityDef -> [Text]
entityUniques :: EntityDef -> [UniqueDef]
entityForeigns :: EntityDef -> [ForeignDef]
entityDerives :: EntityDef -> [Text]
entityExtra :: EntityDef -> Map Text [[Text]]
entitySum :: EntityDef -> Bool
entityComments :: Maybe Text
entitySum :: Bool
entityExtra :: Map Text [[Text]]
entityDerives :: [Text]
entityForeigns :: [ForeignDef]
entityUniques :: [UniqueDef]
entityFields :: [FieldDef]
entityAttrs :: [Text]
entityId :: EntityIdDef
entityDB :: EntityNameDB
entityHaskell :: EntityNameHS
entityId :: EntityDef -> EntityIdDef
entityFields :: EntityDef -> [FieldDef]
entityComments :: EntityDef -> Maybe Text
entityHaskell :: EntityDef -> EntityNameHS
..} Maybe Text
mdocs Text
fields =
[Text] -> Text
Text.unlines ([[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
"# `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EntityNameDB -> Text
unEntityNameDB EntityNameDB
entityDB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
, Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ case Maybe Text
mdocs of
Just Text
entityDocs -> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
entityDocs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
Maybe Text
Nothing -> Text
""
,
#if MIN_VERSION_persistent(2,13,0)
case EntityDef -> Maybe FieldDef
getEntityIdField EntityDef
ed of
Maybe FieldDef
Nothing ->
[]
Just FieldDef
field ->
Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
"* Primary ID: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldNameDB -> Text
unFieldNameDB (FieldDef -> FieldNameDB
fieldDB FieldDef
field) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
#else
pure $ "* Primary ID: `" <> unFieldNameDB (fieldDB entityId) <> "`"
#endif
, Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""
])
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fields
renderEntities :: [Text] -> Text
renderEntities :: [Text] -> Text
renderEntities =
[Text] -> Text
Text.unlines
showType :: SqlType -> Text
showType SqlType
SqlString = Text
"string"
showType SqlType
SqlInt32 = Text
"integer (32)"
showType SqlType
SqlInt64 = Text
"integer (64)"
showType SqlType
SqlReal = Text
"double"
showType SqlNumeric{} = Text
"numeric"
showType SqlType
SqlDay = Text
"date"
showType SqlType
SqlTime = Text
"time"
showType SqlType
SqlDayTime = Text
"datetime"
showType SqlType
SqlBlob = Text
"blob"
showType SqlType
SqlBool = Text
"boolean"
showType (SqlOther Text
t) = Text
t
cleanComment :: Text -> Text
cleanComment :: Text -> Text
cleanComment Text
comment =
let
newlineToBr :: Char -> Text
newlineToBr Char
'\n' = Text
"<br>"
newlineToBr Char
c = Char -> Text
Text.singleton Char
c
in
(Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
newlineToBr (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.strip Text
comment
toMarkdownTables :: [EntityDef] -> Text
toMarkdownTables :: [EntityDef] -> Text
toMarkdownTables = Renderer Text -> [EntityDef] -> Text
forall rendered. Renderer rendered -> [EntityDef] -> rendered
render Renderer Text
markdownTableRenderer
asHaskellNames
:: forall rec. RC rec
=> StrMap (SomeField rec) Text -> Map Text Text
asHaskellNames :: StrMap (SomeField rec) Text -> Map Text Text
asHaskellNames (StrMap Map (AsStr (SomeField rec)) Text
extraDocMap) =
(AsStr (SomeField rec) -> Text)
-> Map (AsStr (SomeField rec)) Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (Text -> Text
lowercaseFirstChar (Text -> Text)
-> (AsStr (SomeField rec) -> Text) -> AsStr (SomeField rec) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
recName) (Text -> Text)
-> (AsStr (SomeField rec) -> Text) -> AsStr (SomeField rec) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsStr (SomeField rec) -> Text
forall k. AsStr k -> Text
asStrText) Map (AsStr (SomeField rec)) Text
extraDocMap
where
recName :: String
recName =
TypeRep -> String
forall a. Show a => a -> String
show (Proxy rec -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy rec
forall k (t :: k). Proxy t
Proxy @rec))
deriveShowFields
#if MIN_VERSION_persistent(2,13,0)
:: [UnboundEntityDef]
#else
:: [EntityDef]
#endif
-> Q [Dec]
deriveShowFields :: [UnboundEntityDef] -> Q [Dec]
deriveShowFields [UnboundEntityDef]
defs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q [[Dec]] -> Q [Dec])
-> ((UnboundEntityDef -> Q [Dec]) -> Q [[Dec]])
-> (UnboundEntityDef -> Q [Dec])
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnboundEntityDef] -> (UnboundEntityDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnboundEntityDef]
defs ((UnboundEntityDef -> Q [Dec]) -> Q [Dec])
-> (UnboundEntityDef -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \UnboundEntityDef
def -> do
let name :: TypeQ
name = Name -> TypeQ
conT (Name -> TypeQ)
-> (UnboundEntityDef -> Name) -> UnboundEntityDef -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name)
-> (UnboundEntityDef -> String) -> UnboundEntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String)
-> (UnboundEntityDef -> Text) -> UnboundEntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (UnboundEntityDef -> EntityNameHS) -> UnboundEntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnboundEntityDef -> EntityNameHS
unname (UnboundEntityDef -> TypeQ) -> UnboundEntityDef -> TypeQ
forall a b. (a -> b) -> a -> b
$ UnboundEntityDef
def
[d|deriving instance Show (EntityField $(name) x)|]
where
unname :: UnboundEntityDef -> EntityNameHS
unname =
#if MIN_VERSION_persistent(2,13,0)
UnboundEntityDef -> EntityNameHS
getUnboundEntityNameHS
#else
entityHaskell
#endif