module Config.Schema.Docs
( generateDocs
) where
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Text.PrettyPrint (Doc, fsep, text, ($+$), (<>), (<+>), nest, empty, hsep)
import Config.Schema.Spec
generateDocs :: ValueSpecs a -> Doc
generateDocs spec = vcat' docLines
where
sectionLines :: (Text, Doc) -> [Doc]
sectionLines (name, fields) = [text "", txt name, nest 4 fields]
(topMap, topDoc) = runDocBuilder (valuesDoc spec)
docLines =
case runValueSpecs_ (pure . SomeSpec) spec of
SomeSpec (SectionSpecs name _) :| []
| Just top <- Map.lookup name topMap ->
txt "Top-level configuration file fields:" :
nest 4 top :
concatMap sectionLines (Map.toList (Map.delete name topMap))
_ -> txt "Top-level configuration file format:" :
nest 4 topDoc :
concatMap sectionLines (Map.toList topMap)
data SomeSpec where SomeSpec :: ValueSpec a -> SomeSpec
sectionsDoc :: Text -> SectionSpecs a -> DocBuilder Doc
sectionsDoc l spec = emitDoc l . vcat' =<< runSections_ (fmap pure . sectionDoc) spec
sectionDoc :: SectionSpec a -> DocBuilder Doc
sectionDoc s =
case s of
ReqSection name desc w -> aux "REQUIRED" name desc <$> valuesDoc w
OptSection name desc w -> aux empty name desc <$> valuesDoc w
where
aux req name desc val =
txt name <> ":" <+> req <+> val $+$
if Text.null desc
then empty
else nest 4 (fsep (txt <$> Text.splitOn " " desc))
valuesDoc :: ValueSpecs a -> DocBuilder Doc
valuesDoc = fmap disjunction . sequenceA . runValueSpecs_ (fmap pure valueDoc)
disjunction :: [Doc] -> Doc
disjunction = hsep . intersperse "or"
valueDoc :: ValueSpec a -> DocBuilder Doc
valueDoc w =
case w of
TextSpec -> pure "text"
IntegerSpec -> pure "integer"
RationalSpec -> pure "number"
AtomSpec a -> pure ("`" <> txt a <> "`")
AnyAtomSpec -> pure "atom"
SectionSpecs l s -> sectionsDoc l s
NamedSpec l s -> emitDoc l =<< valuesDoc s
CustomSpec l w' -> (txt l <+>) <$> valuesDoc w'
ListSpec ws -> ("list of" <+>) <$> valuesDoc ws
AssocSpec ws -> ("association list of" <+>) <$> valuesDoc ws
newtype DocBuilder a = DocBuilder { runDocBuilder :: (Map Text Doc, a) }
deriving (Functor, Applicative, Monad, Monoid, Show)
emitDoc ::
Text ->
Doc ->
DocBuilder Doc
emitDoc l xs = DocBuilder (Map.singleton l xs, txt l)
txt :: Text -> Doc
txt = text . Text.unpack
vcat' :: [Doc] -> Doc
vcat' = foldr ($+$) empty