{-# 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 :: [FieldDef] -> StrMap (SomeField rec) Text -> [FieldDef]
alignFields [FieldDef]
fields StrMap (SomeField rec) Text
strMap =
  (FieldDef -> FieldDef) -> [FieldDef] -> [FieldDef]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldDef
findFieldDoc [FieldDef]
fields
  where
    findFieldDoc :: FieldDef -> FieldDef
findFieldDoc fld :: FieldDef
fld@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
fieldComments :: FieldDef -> Maybe Text
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
..} =
      case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FieldNameHS -> Text
nameAsText FieldNameHS
fieldHaskell) Map Text Text
haskellNames of
        Maybe Text
Nothing -> FieldDef
fld
        Just Text
c -> FieldDef
fld { fieldComments :: Maybe Text
fieldComments = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c }
    haskellNames :: Map Text Text
haskellNames = StrMap (SomeField rec) Text -> Map Text Text
forall rec. RC rec => StrMap (SomeField rec) Text -> Map Text Text
asHaskellNames StrMap (SomeField rec) Text
strMap
    nameAsText :: FieldNameHS -> Text
nameAsText = Text -> Text
lowercaseFirstChar (Text -> Text) -> (FieldNameHS -> Text) -> FieldNameHS -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNameHS -> Text
unFieldNameHS

-- | 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 (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 ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
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 :: [Char]
recName =
      TypeRep -> [Char]
forall a. Show a => a -> [Char]
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))

-- | A type for defining documentation for a schema.
--
-- @since 0.1.0.0
newtype EntityDoc' a = ED (Writer SchemaDocs a)
  deriving (a -> EntityDoc' b -> EntityDoc' a
(a -> b) -> EntityDoc' a -> EntityDoc' b
(forall a b. (a -> b) -> EntityDoc' a -> EntityDoc' b)
-> (forall a b. a -> EntityDoc' b -> EntityDoc' a)
-> Functor EntityDoc'
forall a b. a -> EntityDoc' b -> EntityDoc' a
forall a b. (a -> b) -> EntityDoc' a -> EntityDoc' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EntityDoc' b -> EntityDoc' a
$c<$ :: forall a b. a -> EntityDoc' b -> EntityDoc' a
fmap :: (a -> b) -> EntityDoc' a -> EntityDoc' b
$cfmap :: forall a b. (a -> b) -> EntityDoc' a -> EntityDoc' b
Functor, Functor EntityDoc'
a -> EntityDoc' a
Functor EntityDoc'
-> (forall a. a -> EntityDoc' a)
-> (forall a b.
    EntityDoc' (a -> b) -> EntityDoc' a -> EntityDoc' b)
-> (forall a b c.
    (a -> b -> c) -> EntityDoc' a -> EntityDoc' b -> EntityDoc' c)
-> (forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b)
-> (forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' a)
-> Applicative EntityDoc'
EntityDoc' a -> EntityDoc' b -> EntityDoc' b
EntityDoc' a -> EntityDoc' b -> EntityDoc' a
EntityDoc' (a -> b) -> EntityDoc' a -> EntityDoc' b
(a -> b -> c) -> EntityDoc' a -> EntityDoc' b -> EntityDoc' c
forall a. a -> EntityDoc' a
forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' a
forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b
forall a b. EntityDoc' (a -> b) -> EntityDoc' a -> EntityDoc' b
forall a b c.
(a -> b -> c) -> EntityDoc' a -> EntityDoc' b -> EntityDoc' c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EntityDoc' a -> EntityDoc' b -> EntityDoc' a
$c<* :: forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' a
*> :: EntityDoc' a -> EntityDoc' b -> EntityDoc' b
$c*> :: forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b
liftA2 :: (a -> b -> c) -> EntityDoc' a -> EntityDoc' b -> EntityDoc' c
$cliftA2 :: forall a b c.
(a -> b -> c) -> EntityDoc' a -> EntityDoc' b -> EntityDoc' c
<*> :: EntityDoc' (a -> b) -> EntityDoc' a -> EntityDoc' b
$c<*> :: forall a b. EntityDoc' (a -> b) -> EntityDoc' a -> EntityDoc' b
pure :: a -> EntityDoc' a
$cpure :: forall a. a -> EntityDoc' a
$cp1Applicative :: Functor EntityDoc'
Applicative, Applicative EntityDoc'
a -> EntityDoc' a
Applicative EntityDoc'
-> (forall a b.
    EntityDoc' a -> (a -> EntityDoc' b) -> EntityDoc' b)
-> (forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b)
-> (forall a. a -> EntityDoc' a)
-> Monad EntityDoc'
EntityDoc' a -> (a -> EntityDoc' b) -> EntityDoc' b
EntityDoc' a -> EntityDoc' b -> EntityDoc' b
forall a. a -> EntityDoc' a
forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b
forall a b. EntityDoc' a -> (a -> EntityDoc' b) -> EntityDoc' b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EntityDoc' a
$creturn :: forall a. a -> EntityDoc' a
>> :: EntityDoc' a -> EntityDoc' b -> EntityDoc' b
$c>> :: forall a b. EntityDoc' a -> EntityDoc' b -> EntityDoc' b
>>= :: EntityDoc' a -> (a -> EntityDoc' b) -> EntityDoc' b
$c>>= :: forall a b. EntityDoc' a -> (a -> EntityDoc' b) -> EntityDoc' b
$cp1Monad :: Applicative EntityDoc'
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 (EntityDocs rec
r0 :: EntityDocs r0) <> :: SomeDocs -> SomeDocs -> SomeDocs
<> SomeDocs (EntityDocs rec
r1 :: EntityDocs r1) =
    case (Typeable rec, Typeable rec) => Maybe (rec :~: rec)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @r0 @r1 of
      Just rec :~: rec
Refl -> EntityDocs rec -> SomeDocs
forall rec. RC rec => EntityDocs rec -> SomeDocs
SomeDocs (EntityDocs rec
r0 EntityDocs rec -> EntityDocs rec -> EntityDocs rec
forall a. Semigroup a => a -> a -> a
<> EntityDocs rec
EntityDocs rec
r1)
      Maybe (rec :~: rec)
Nothing -> EntityDocs rec -> SomeDocs
forall rec. RC rec => EntityDocs rec -> SomeDocs
SomeDocs EntityDocs rec
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
  { EntityDocs rec -> Text
entityDocumentation :: Text
  , EntityDocs rec -> StrMap (SomeField rec) Text
fieldDocumentation :: StrMap (SomeField rec) Text
  }

instance Semigroup (EntityDocs rec) where
  EntityDocs Text
d0 StrMap (SomeField rec) Text
f0 <> :: EntityDocs rec -> EntityDocs rec -> EntityDocs rec
<> EntityDocs Text
d1 StrMap (SomeField rec) Text
f1 = Text -> StrMap (SomeField rec) Text -> EntityDocs rec
forall rec. Text -> StrMap (SomeField rec) Text -> EntityDocs rec
EntityDocs (Text
d0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d1) (StrMap (SomeField rec) Text
f0 StrMap (SomeField rec) Text
-> StrMap (SomeField rec) Text -> StrMap (SomeField rec) Text
forall a. Semigroup a => a -> a -> a
<> StrMap (SomeField rec) Text
f1)

instance Monoid (EntityDocs rec) where
  mempty :: EntityDocs rec
mempty = Text -> StrMap (SomeField rec) Text -> EntityDocs rec
forall rec. Text -> StrMap (SomeField rec) Text -> EntityDocs rec
EntityDocs Text
forall a. Monoid a => a
mempty StrMap (SomeField rec) Text
forall a. Monoid a => a
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 rec -> [Char]
show (SomeField EntityField rec typ
fld) = EntityField rec typ -> [Char]
forall a. Show a => a -> [Char]
show EntityField rec typ
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 (a -> FieldDoc' rec b -> FieldDoc' rec a
(a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
(forall a b. (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b)
-> (forall a b. a -> FieldDoc' rec b -> FieldDoc' rec a)
-> Functor (FieldDoc' rec)
forall a b. a -> FieldDoc' rec b -> FieldDoc' rec a
forall a b. (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
forall rec a b. a -> FieldDoc' rec b -> FieldDoc' rec a
forall rec a b. (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FieldDoc' rec b -> FieldDoc' rec a
$c<$ :: forall rec a b. a -> FieldDoc' rec b -> FieldDoc' rec a
fmap :: (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
$cfmap :: forall rec a b. (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
Functor, Functor (FieldDoc' rec)
a -> FieldDoc' rec a
Functor (FieldDoc' rec)
-> (forall a. a -> FieldDoc' rec a)
-> (forall a b.
    FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b)
-> (forall a b c.
    (a -> b -> c)
    -> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c)
-> (forall a b.
    FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b)
-> (forall a b.
    FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a)
-> Applicative (FieldDoc' rec)
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a
FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
(a -> b -> c)
-> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c
forall rec. Functor (FieldDoc' rec)
forall a. a -> FieldDoc' rec a
forall rec a. a -> FieldDoc' rec a
forall a b. FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a
forall a b. FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
forall a b.
FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a
forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
forall rec a b.
FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
forall a b c.
(a -> b -> c)
-> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c
forall rec a b c.
(a -> b -> c)
-> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a
$c<* :: forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec a
*> :: FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
$c*> :: forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
liftA2 :: (a -> b -> c)
-> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c
$cliftA2 :: forall rec a b c.
(a -> b -> c)
-> FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec c
<*> :: FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
$c<*> :: forall rec a b.
FieldDoc' rec (a -> b) -> FieldDoc' rec a -> FieldDoc' rec b
pure :: a -> FieldDoc' rec a
$cpure :: forall rec a. a -> FieldDoc' rec a
$cp1Applicative :: forall rec. Functor (FieldDoc' rec)
Applicative, Applicative (FieldDoc' rec)
a -> FieldDoc' rec a
Applicative (FieldDoc' rec)
-> (forall a b.
    FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b)
-> (forall a b.
    FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b)
-> (forall a. a -> FieldDoc' rec a)
-> Monad (FieldDoc' rec)
FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
forall rec. Applicative (FieldDoc' rec)
forall a. a -> FieldDoc' rec a
forall rec a. a -> FieldDoc' rec a
forall a b. FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
forall a b.
FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b
forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
forall rec a b.
FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> FieldDoc' rec a
$creturn :: forall rec a. a -> FieldDoc' rec a
>> :: FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
$c>> :: forall rec a b.
FieldDoc' rec a -> FieldDoc' rec b -> FieldDoc' rec b
>>= :: FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b
$c>>= :: forall rec a b.
FieldDoc' rec a -> (a -> FieldDoc' rec b) -> FieldDoc' rec b
$cp1Monad :: forall rec. Applicative (FieldDoc' rec)
Monad, MonadWriter (EntityDocs rec))

single
  :: FC rec typ
  => EntityField rec typ -> Text -> StrMap (SomeField rec) Text
single :: EntityField rec typ -> Text -> StrMap (SomeField rec) Text
single EntityField rec typ
k Text
t = SomeField rec
-> Text
-> StrMap (SomeField rec) Text
-> StrMap (SomeField rec) Text
forall k a. Show k => k -> a -> StrMap k a -> StrMap k a
insert (EntityField rec typ -> SomeField rec
forall rec typ. FC rec typ => EntityField rec typ -> SomeField rec
SomeField EntityField rec typ
k) Text
t StrMap (SomeField rec) Text
forall a. Monoid a => a
mempty

type family KnowResult a where
  KnowResult (i -> o) = KnowResult o
  KnowResult a = a

instance (a ~ ()) => IsString (FieldDoc' s a) where
  fromString :: [Char] -> FieldDoc' s a
fromString [Char]
str = EntityDocs s -> FieldDoc' s ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell EntityDocs s
forall a. Monoid a => a
mempty { entityDocumentation :: Text
entityDocumentation = [Char] -> Text
Text.pack [Char]
str }

lowercaseFirstChar :: Text -> Text
lowercaseFirstChar :: Text -> Text
lowercaseFirstChar Text
txt = case Text -> Maybe (Char, Text)
Text.uncons Text
txt of
  Just (Char
c, Text
r) -> Char -> Char
Char.toLower Char
c Char -> Text -> Text
`Text.cons` Text
r
  Maybe (Char, Text)
Nothing -> Text
""

-- | 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
a
_ --^ :: a -> FieldDoc r -> EntityDoc' ()
--^ FD Writer (EntityDocs r) ()
fieldDocs =
  SchemaDocs -> EntityDoc' ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  (SchemaDocs -> EntityDoc' ())
-> (Map TypeRep SomeDocs -> SchemaDocs)
-> Map TypeRep SomeDocs
-> EntityDoc' ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TypeRep SomeDocs -> SchemaDocs
forall k v. Map k v -> SemiMap k v
SemiMap
  (Map TypeRep SomeDocs -> EntityDoc' ())
-> Map TypeRep SomeDocs -> EntityDoc' ()
forall a b. (a -> b) -> a -> b
$ TypeRep -> SomeDocs -> Map TypeRep SomeDocs
forall k a. k -> a -> Map k a
Map.singleton
    (Proxy r -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy r
forall k (t :: k). Proxy t
Proxy @r))
    (EntityDocs r -> SomeDocs
forall rec. RC rec => EntityDocs rec -> SomeDocs
SomeDocs (Writer (EntityDocs r) () -> EntityDocs r
forall w a. Writer w a -> w
execWriter Writer (EntityDocs r) ()
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
EntityField rec typ
field # :: EntityField rec typ -> Text -> FieldDoc rec
# Text
txt = EntityDocs rec -> FieldDoc rec
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell EntityDocs Any
forall a. Monoid a => a
mempty { fieldDocumentation :: StrMap (SomeField rec) Text
fieldDocumentation = SomeField rec
-> Text
-> StrMap (SomeField rec) Text
-> StrMap (SomeField rec) Text
forall k a. Show k => k -> a -> StrMap k a -> StrMap k a
insert (EntityField rec typ -> SomeField rec
forall rec typ. FC rec typ => EntityField rec typ -> SomeField rec
SomeField EntityField rec typ
field) Text
txt StrMap (SomeField rec) Text
forall a. Monoid a => a
mempty }