{-# Language OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}
module Config.Schema.Docs
( generateDocs
) where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text
import Config.Schema.Spec
generateDocs :: ValueSpecs a -> Text
generateDocs spec = Text.unlines
("Configuration file fields:"
: map (" " <>) top
++ concatMap sectionLines (Map.toList m'))
where
topname = ""
Just top = Map.lookup topname m
DocBuilder (m,"") = valuesDoc spec
m' = Map.delete topname m
sectionLines :: (Text, [Text]) -> [Text]
sectionLines (name, fields)
= ""
: name
: map (" "<>) fields
sectionsDoc :: Text -> SectionSpecs a -> DocBuilder Text
sectionsDoc l spec = emitDoc l =<< runSections_ sectionDoc spec
sectionDoc :: SectionSpec a -> DocBuilder [Text]
sectionDoc s =
case s of
ReqSection name desc w -> aux "REQUIRED " name desc <$> valuesDoc w
OptSection name desc w -> aux "" name desc <$> valuesDoc w
where
aux req name desc val =
(name <> ": " <> req <> val)
: if Text.null desc then [] else [" " <> desc]
valuesDoc :: ValueSpecs a -> DocBuilder Text
valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ valueDoc
disjunction :: NonEmpty Text -> Text
disjunction = Text.intercalate " or " . NonEmpty.toList
valueDoc :: ValueSpec a -> DocBuilder Text
valueDoc w =
case w of
TextSpec -> return "text"
IntegerSpec -> return "integer"
RationalSpec -> return "number"
AtomSpec a -> return ("`" <> a <> "`")
AnyAtomSpec -> return "atom"
SectionSpecs l s -> sectionsDoc l s
NamedSpec l s -> emitDoc l . pure =<< valuesDoc s
CustomSpec l w' -> ((l <> " ") <>) <$> valuesDoc w'
ListSpec ws -> ("list of " <>) <$> valuesDoc ws
newtype DocBuilder a = DocBuilder (Map Text [Text], a)
deriving (Functor, Applicative, Monad, Monoid, Show)
emitDoc ::
Text ->
[Text] ->
DocBuilder Text
emitDoc l xs = DocBuilder (Map.singleton l xs, l)