{-# 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)
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
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
. HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (EntityDef -> HaskellName) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> HaskellName
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 :: FieldDef
entityId = [FieldDef] -> FieldDef
forall a. [a] -> a
head ([FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
forall rec.
RC rec =>
[FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
alignFields [EntityDef -> FieldDef
entityId EntityDef
edef] StrMap (SomeField rec) Text
cs)
}
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 = EntityDef -> FieldDef
entityId EntityDef
ent FieldDef -> [FieldDef] -> [FieldDef]
forall a. a -> [a] -> [a]
: EntityDef -> [FieldDef]
entityFields 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
forall (t :: * -> *). Foldable t => FieldDef -> t Text -> Text
renderEntities :: [Text] -> Text
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderFields :: [Text] -> Text
renderField :: forall (t :: * -> *). Foldable t => FieldDef -> t Text -> Text
renderEntities :: [Text] -> Text
renderEntity :: EntityDef -> Maybe Text -> Text -> Text
renderFields :: [Text] -> Text
renderField :: FieldDef -> Maybe Text -> Text
..}
where
renderField :: FieldDef -> t Text -> Text
renderField FieldDef{Bool
[FieldAttr]
Maybe Text
HaskellName
DBName
FieldType
ReferenceDef
FieldCascade
SqlType
fieldHaskell :: FieldDef -> HaskellName
fieldDB :: FieldDef -> DBName
fieldType :: FieldDef -> FieldType
fieldSqlType :: FieldDef -> SqlType
fieldAttrs :: FieldDef -> [FieldAttr]
fieldStrict :: FieldDef -> Bool
fieldReference :: FieldDef -> ReferenceDef
fieldCascade :: FieldDef -> FieldCascade
fieldGenerated :: FieldDef -> Maybe Text
fieldGenerated :: Maybe Text
fieldComments :: Maybe Text
fieldCascade :: FieldCascade
fieldReference :: ReferenceDef
fieldStrict :: Bool
fieldAttrs :: [FieldAttr]
fieldSqlType :: SqlType
fieldType :: FieldType
fieldDB :: DBName
fieldHaskell :: HaskellName
fieldComments :: FieldDef -> Maybe Text
..} t Text
mextra =
[Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
[ Text
"| `"
, DBName -> Text
unDBName DBName
fieldDB
, Text
"` | "
, SqlType -> Text
showType SqlType
fieldSqlType
, Text
" | "
, t Text -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold t Text
mextra
, 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{Bool
[Text]
[FieldDef]
[UniqueDef]
[ForeignDef]
Maybe Text
Map Text [[Text]]
HaskellName
DBName
FieldDef
entityDB :: EntityDef -> DBName
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 :: FieldDef
entityDB :: DBName
entityHaskell :: HaskellName
entityId :: EntityDef -> FieldDef
entityFields :: EntityDef -> [FieldDef]
entityComments :: EntityDef -> Maybe Text
entityHaskell :: EntityDef -> HaskellName
..} Maybe Text
mdocs Text
fields =
[Text] -> Text
Text.unlines
[ Text
"# `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBName -> Text
unDBName DBName
entityDB Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
, 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
""
, Text
"* Primary ID: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DBName -> Text
unDBName (FieldDef -> DBName
fieldDB FieldDef
entityId) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
, Text
""
]
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fields
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
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 :: [EntityDef] -> Q [Dec]
deriveShowFields :: [EntityDef] -> Q [Dec]
deriveShowFields [EntityDef]
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])
-> ((EntityDef -> Q [Dec]) -> Q [[Dec]])
-> (EntityDef -> Q [Dec])
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EntityDef] -> (EntityDef -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [EntityDef]
defs ((EntityDef -> Q [Dec]) -> Q [Dec])
-> (EntityDef -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \EntityDef
def -> do
let name :: TypeQ
name = Name -> TypeQ
conT (Name -> TypeQ) -> (EntityDef -> Name) -> EntityDef -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (EntityDef -> String) -> EntityDef -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String) -> (EntityDef -> Text) -> EntityDef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaskellName -> Text
unHaskellName (HaskellName -> Text)
-> (EntityDef -> HaskellName) -> EntityDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> HaskellName
entityHaskell (EntityDef -> TypeQ) -> EntityDef -> TypeQ
forall a b. (a -> b) -> a -> b
$ EntityDef
def
[d|deriving instance Show (EntityField $(name) x)|]