{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving, CPP #-}

{-|
Module      : Config.Schema.Docs
Description : Documentation generation for config schemas
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

This module generates a simple textual documentation format for a configuration
schema. Each subsection and named value specification will generate it's own
top-level component in the documentation.

This module is only one of the ways one could generate documentation for a
particular configuration specification. All of the defintions would would need
to be able to generate another form are exported by "Config.Schema.Spec".

@
configSpec :: ValueSpec (Text,Maybe Int)
configSpec = sectionsSpec ""
           $ liftA2 (,)
               (reqSection "username" "Name used to login")
               (optSection "attempts" "Number of login attempts")

generateDocs configSpec

-- Top-level configuration file fields:
--     username: REQUIRED text
--        Name used to login
--     attempts: integer
--        Number of login attempts
@

-}
module Config.Schema.Docs
  ( generateDocs
  ) where

import           Control.Applicative (liftA2)
import           Control.Monad (unless)
import           Control.Monad.Trans.State.Strict (runState, get, put, State)
import           Data.List (intersperse)
import           Data.List.NonEmpty (NonEmpty((:|)))
import           Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Semigroup as S
import           Data.Text (Text)
import qualified Data.Text as Text
import           Text.PrettyPrint
                    (Doc, fsep, text, (<>), ($+$), (<+>), nest, empty, hsep, parens)
import           Prelude hiding ((<>))

#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid (Monoid(..))
#endif

import           Config.Schema.Spec
import           Config.Schema.Types

-- | Default documentation generator.
generateDocs :: ValueSpec a -> Doc
generateDocs :: ValueSpec a -> Doc
generateDocs spec :: ValueSpec a
spec = [Doc] -> Doc
vcat' [Doc]
docLines
  where
    sectionLines :: (Text, Doc) -> [Doc]
    sectionLines :: (Text, Doc) -> [Doc]
sectionLines (name :: Text
name, fields :: Doc
fields) = [String -> Doc
text "", Text -> Doc
txt Text
name, Int -> Doc -> Doc
nest 4 Doc
fields]

    (topDoc :: Doc
topDoc, topMap :: Map Text Doc
topMap) = DocBuilder Doc -> (Doc, Map Text Doc)
forall a. DocBuilder a -> (a, Map Text Doc)
runDocBuilder (Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
False ValueSpec a
spec)

    docLines :: [Doc]
docLines =
      case (forall x. PrimValueSpec x -> NonEmpty SomeSpec)
-> ValueSpec a -> NonEmpty SomeSpec
forall m a.
Semigroup m =>
(forall x. PrimValueSpec x -> m) -> ValueSpec a -> m
runValueSpec_ (SomeSpec -> NonEmpty SomeSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeSpec -> NonEmpty SomeSpec)
-> (PrimValueSpec x -> SomeSpec)
-> PrimValueSpec x
-> NonEmpty SomeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValueSpec x -> SomeSpec
forall a. PrimValueSpec a -> SomeSpec
SomeSpec) ValueSpec a
spec of
        -- single, top-level sections spec
        SomeSpec (SectionsSpec name :: Text
name _) :| []
          | Just top :: Doc
top <- Text -> Map Text Doc -> Maybe Doc
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Doc
topMap ->
              Text -> Doc
txt "Top-level configuration file fields:" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
              Int -> Doc -> Doc
nest 4 Doc
top Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
              ((Text, Doc) -> [Doc]) -> [(Text, Doc)] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Doc) -> [Doc]
sectionLines (Map Text Doc -> [(Text, Doc)]
forall k a. Map k a -> [(k, a)]
Map.toList (Text -> Map Text Doc -> Map Text Doc
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
name Map Text Doc
topMap))

        -- otherwise
        _ -> Text -> Doc
txt "Top-level configuration file format:" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
             Int -> Doc -> Doc
nest 4 Doc
topDoc Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
             ((Text, Doc) -> [Doc]) -> [(Text, Doc)] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Doc) -> [Doc]
sectionLines (Map Text Doc -> [(Text, Doc)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Doc
topMap)


-- | Forget the type of the value spec
data SomeSpec where SomeSpec :: PrimValueSpec a -> SomeSpec


-- | Compute the documentation for a list of sections, store the
-- documentation in the sections map and return the name of the section.
sectionsDoc :: Text -> SectionsSpec a -> DocBuilder Doc
sectionsDoc :: Text -> SectionsSpec a -> DocBuilder Doc
sectionsDoc l :: Text
l spec :: SectionsSpec a
spec = Text -> DocBuilder Doc -> DocBuilder Doc
emitDoc Text
l ([Doc] -> Doc
vcat' ([Doc] -> Doc) -> DocBuilder [Doc] -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. PrimSectionSpec x -> DocBuilder [Doc])
-> SectionsSpec a -> DocBuilder [Doc]
forall m a.
Monoid m =>
(forall x. PrimSectionSpec x -> m) -> SectionsSpec a -> m
runSections_ ((Doc -> [Doc]) -> DocBuilder Doc -> DocBuilder [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> [Doc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DocBuilder Doc -> DocBuilder [Doc])
-> (PrimSectionSpec x -> DocBuilder Doc)
-> PrimSectionSpec x
-> DocBuilder [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimSectionSpec x -> DocBuilder Doc
forall a. PrimSectionSpec a -> DocBuilder Doc
sectionDoc) SectionsSpec a
spec)


-- | Compute the documentation lines for a single key-value pair.
sectionDoc :: PrimSectionSpec a -> DocBuilder Doc
sectionDoc :: PrimSectionSpec a -> DocBuilder Doc
sectionDoc s :: PrimSectionSpec a
s =
  case PrimSectionSpec a
s of
    ReqSection name :: Text
name desc :: Text
desc w :: ValueSpec a
w -> Doc -> Text -> Text -> Doc -> Doc
aux "REQUIRED" Text
name Text
desc (Doc -> Doc) -> DocBuilder Doc -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
False ValueSpec a
w
    OptSection name :: Text
name desc :: Text
desc w :: ValueSpec a
w -> Doc -> Text -> Text -> Doc -> Doc
aux Doc
empty      Text
name Text
desc (Doc -> Doc) -> DocBuilder Doc -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
False ValueSpec a
w
  where
    aux :: Doc -> Text -> Text -> Doc -> Doc
aux req :: Doc
req name :: Text
name desc :: Text
desc val :: Doc
val =
      (Text -> Doc
txt Text
name Doc -> Doc -> Doc
<> ":") Doc -> Doc -> Doc
<+> Doc
req Doc -> Doc -> Doc
<+> Doc
val Doc -> Doc -> Doc
$+$
      if Text -> Bool
Text.null Text
desc
        then Doc
empty
        else Int -> Doc -> Doc
nest 4 ([Doc] -> Doc
fsep (Text -> Doc
txt (Text -> Doc) -> [Text] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
Text.splitOn " " Text
desc)) -- line wrap logic


-- | Compute the documentation line for a particular value specification.
-- Any sections contained in the specification will be stored in the
-- sections map.
--
-- Set nested to 'True' when using valuesDoc in a nested context and
-- parentheses would be needed in the case of multiple alternatives.
valuesDoc :: Bool {- ^ nested -} -> ValueSpec a -> DocBuilder Doc
valuesDoc :: Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc nested :: Bool
nested =
  ([Doc] -> Doc) -> DocBuilder [Doc] -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> [Doc] -> Doc
disjunction Bool
nested) (DocBuilder [Doc] -> DocBuilder Doc)
-> (ValueSpec a -> DocBuilder [Doc])
-> ValueSpec a
-> DocBuilder Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DocBuilder Doc] -> DocBuilder [Doc]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([DocBuilder Doc] -> DocBuilder [Doc])
-> (ValueSpec a -> [DocBuilder Doc])
-> ValueSpec a
-> DocBuilder [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. PrimValueSpec x -> [DocBuilder Doc])
-> ValueSpec a -> [DocBuilder Doc]
forall m a.
Semigroup m =>
(forall x. PrimValueSpec x -> m) -> ValueSpec a -> m
runValueSpec_ ((DocBuilder Doc -> [DocBuilder Doc])
-> (PrimValueSpec x -> DocBuilder Doc)
-> PrimValueSpec x
-> [DocBuilder Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DocBuilder Doc -> [DocBuilder Doc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimValueSpec x -> DocBuilder Doc
forall a. PrimValueSpec a -> DocBuilder Doc
valueDoc)


-- | Combine a list of text with the word @or@.
disjunction :: Bool {- ^ nested -} -> [Doc] -> Doc
disjunction :: Bool -> [Doc] -> Doc
disjunction _ [x :: Doc
x]    = Doc
x
disjunction True  xs :: [Doc]
xs = Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse "or" [Doc]
xs))
disjunction False xs :: [Doc]
xs =         [Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse "or" [Doc]
xs)



-- | Compute the documentation fragment for an individual value specification.
valueDoc :: PrimValueSpec a -> DocBuilder Doc
valueDoc :: PrimValueSpec a -> DocBuilder Doc
valueDoc w :: PrimValueSpec a
w =
  case PrimValueSpec a
w of
    TextSpec         -> Doc -> DocBuilder Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure "text"
    NumberSpec       -> Doc -> DocBuilder Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure "number"
    AtomSpec a :: Text
a       -> Doc -> DocBuilder Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("`" Doc -> Doc -> Doc
<> Text -> Doc
txt Text
a Doc -> Doc -> Doc
<> "`")
    AnyAtomSpec      -> Doc -> DocBuilder Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure "atom"
    SectionsSpec l :: Text
l s :: SectionsSpec a
s -> Text -> SectionsSpec a -> DocBuilder Doc
forall a. Text -> SectionsSpec a -> DocBuilder Doc
sectionsDoc Text
l SectionsSpec a
s
    NamedSpec    l :: Text
l s :: ValueSpec a
s -> Text -> DocBuilder Doc -> DocBuilder Doc
emitDoc Text
l (Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
False ValueSpec a
s)
    CustomSpec l :: Text
l w' :: ValueSpec (Either Text a)
w'  -> (Text -> Doc
txt Text
l                 Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> DocBuilder Doc -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ValueSpec (Either Text a) -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
True ValueSpec (Either Text a)
w'
    ListSpec ws :: ValueSpec a
ws      -> ("list of"             Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> DocBuilder Doc -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
True ValueSpec a
ws
    AssocSpec ws :: ValueSpec a
ws     -> ("association list of" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> DocBuilder Doc -> DocBuilder Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ValueSpec a -> DocBuilder Doc
forall a. Bool -> ValueSpec a -> DocBuilder Doc
valuesDoc Bool
True ValueSpec a
ws


-- | A writer-like type. A mapping of section names and documentation
-- lines is accumulated.
newtype DocBuilder a = DocBuilder (State (Map Text Doc) a)
  deriving (a -> DocBuilder b -> DocBuilder a
(a -> b) -> DocBuilder a -> DocBuilder b
(forall a b. (a -> b) -> DocBuilder a -> DocBuilder b)
-> (forall a b. a -> DocBuilder b -> DocBuilder a)
-> Functor DocBuilder
forall a b. a -> DocBuilder b -> DocBuilder a
forall a b. (a -> b) -> DocBuilder a -> DocBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DocBuilder b -> DocBuilder a
$c<$ :: forall a b. a -> DocBuilder b -> DocBuilder a
fmap :: (a -> b) -> DocBuilder a -> DocBuilder b
$cfmap :: forall a b. (a -> b) -> DocBuilder a -> DocBuilder b
Functor, Functor DocBuilder
a -> DocBuilder a
Functor DocBuilder =>
(forall a. a -> DocBuilder a)
-> (forall a b.
    DocBuilder (a -> b) -> DocBuilder a -> DocBuilder b)
-> (forall a b c.
    (a -> b -> c) -> DocBuilder a -> DocBuilder b -> DocBuilder c)
-> (forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b)
-> (forall a b. DocBuilder a -> DocBuilder b -> DocBuilder a)
-> Applicative DocBuilder
DocBuilder a -> DocBuilder b -> DocBuilder b
DocBuilder a -> DocBuilder b -> DocBuilder a
DocBuilder (a -> b) -> DocBuilder a -> DocBuilder b
(a -> b -> c) -> DocBuilder a -> DocBuilder b -> DocBuilder c
forall a. a -> DocBuilder a
forall a b. DocBuilder a -> DocBuilder b -> DocBuilder a
forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b
forall a b. DocBuilder (a -> b) -> DocBuilder a -> DocBuilder b
forall a b c.
(a -> b -> c) -> DocBuilder a -> DocBuilder b -> DocBuilder 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
<* :: DocBuilder a -> DocBuilder b -> DocBuilder a
$c<* :: forall a b. DocBuilder a -> DocBuilder b -> DocBuilder a
*> :: DocBuilder a -> DocBuilder b -> DocBuilder b
$c*> :: forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b
liftA2 :: (a -> b -> c) -> DocBuilder a -> DocBuilder b -> DocBuilder c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DocBuilder a -> DocBuilder b -> DocBuilder c
<*> :: DocBuilder (a -> b) -> DocBuilder a -> DocBuilder b
$c<*> :: forall a b. DocBuilder (a -> b) -> DocBuilder a -> DocBuilder b
pure :: a -> DocBuilder a
$cpure :: forall a. a -> DocBuilder a
$cp1Applicative :: Functor DocBuilder
Applicative, Applicative DocBuilder
a -> DocBuilder a
Applicative DocBuilder =>
(forall a b. DocBuilder a -> (a -> DocBuilder b) -> DocBuilder b)
-> (forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b)
-> (forall a. a -> DocBuilder a)
-> Monad DocBuilder
DocBuilder a -> (a -> DocBuilder b) -> DocBuilder b
DocBuilder a -> DocBuilder b -> DocBuilder b
forall a. a -> DocBuilder a
forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b
forall a b. DocBuilder a -> (a -> DocBuilder b) -> DocBuilder 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 -> DocBuilder a
$creturn :: forall a. a -> DocBuilder a
>> :: DocBuilder a -> DocBuilder b -> DocBuilder b
$c>> :: forall a b. DocBuilder a -> DocBuilder b -> DocBuilder b
>>= :: DocBuilder a -> (a -> DocBuilder b) -> DocBuilder b
$c>>= :: forall a b. DocBuilder a -> (a -> DocBuilder b) -> DocBuilder b
$cp1Monad :: Applicative DocBuilder
Monad)

runDocBuilder :: DocBuilder a -> (a, Map Text Doc)
runDocBuilder :: DocBuilder a -> (a, Map Text Doc)
runDocBuilder (DocBuilder b :: State (Map Text Doc) a
b) = State (Map Text Doc) a -> Map Text Doc -> (a, Map Text Doc)
forall s a. State s a -> s -> (a, s)
runState State (Map Text Doc) a
b Map Text Doc
forall a. Monoid a => a
mempty

-- | lifts underlying 'S.Semigroup' instance
instance S.Semigroup a => S.Semigroup (DocBuilder a) where
  <> :: DocBuilder a -> DocBuilder a -> DocBuilder a
(<>) = (a -> a -> a) -> DocBuilder a -> DocBuilder a -> DocBuilder a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(S.<>)

-- | lifts underlying 'Monoid' instance
instance (S.Semigroup a, Monoid a) => Monoid (DocBuilder a) where
  mempty :: DocBuilder a
mempty  = a -> DocBuilder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
  mappend :: DocBuilder a -> DocBuilder a -> DocBuilder a
mappend = DocBuilder a -> DocBuilder a -> DocBuilder a
forall a. Semigroup a => a -> a -> a
(S.<>)


-- | Given a section name and section body, store the body
-- in the map of sections and return the section name.
emitDoc ::
  Text           {- ^ section name     -} ->
  DocBuilder Doc {- ^ section body     -} ->
  DocBuilder Doc {- ^ section name doc -}
emitDoc :: Text -> DocBuilder Doc -> DocBuilder Doc
emitDoc l :: Text
l (DocBuilder sub :: State (Map Text Doc) Doc
sub) = State (Map Text Doc) Doc -> DocBuilder Doc
forall a. State (Map Text Doc) a -> DocBuilder a
DocBuilder (State (Map Text Doc) Doc -> DocBuilder Doc)
-> State (Map Text Doc) Doc -> DocBuilder Doc
forall a b. (a -> b) -> a -> b
$
  do Map Text Doc
m <- StateT (Map Text Doc) Identity (Map Text Doc)
forall (m :: * -> *) s. Monad m => StateT s m s
get
     Bool
-> StateT (Map Text Doc) Identity ()
-> StateT (Map Text Doc) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Map Text Doc -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
l Map Text Doc
m) (StateT (Map Text Doc) Identity ()
 -> StateT (Map Text Doc) Identity ())
-> StateT (Map Text Doc) Identity ()
-> StateT (Map Text Doc) Identity ()
forall a b. (a -> b) -> a -> b
$
       do rec Map Text Doc -> StateT (Map Text Doc) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Map Text Doc -> StateT (Map Text Doc) Identity ())
-> Map Text Doc -> StateT (Map Text Doc) Identity ()
forall a b. (a -> b) -> a -> b
$! Text -> Doc -> Map Text Doc -> Map Text Doc
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
l Doc
val Map Text Doc
m
              Doc
val <- State (Map Text Doc) Doc
sub
          () -> StateT (Map Text Doc) Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     Doc -> State (Map Text Doc) Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Doc
txt Text
l)
  -- by using a recursively defined do block and
  -- inserting the element /before/ executing the @sub@
  -- action we ensure that @sub@ doesn't attempt to
  -- also explore elements named @l@

------------------------------------------------------------------------

-- | Like text, but works on Text values.
txt :: Text -> Doc
txt :: Text -> Doc
txt = String -> Doc
text (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack

-- | Like vcat but using ($+$) instead of ($$) to avoid overlap.
vcat' :: [Doc] -> Doc
vcat' :: [Doc] -> Doc
vcat' = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($+$) Doc
empty