{-# Language RecursiveDo, OverloadedStrings, GADTs, GeneralizedNewtypeDeriving #-}
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 Data.Monoid (Monoid(..))
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 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]
(topDoc, topMap) = runDocBuilder (valuesDoc False 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 False w
OptSection name desc w -> aux empty name desc <$> valuesDoc False 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 :: Bool -> ValueSpecs a -> DocBuilder Doc
valuesDoc nested =
fmap (disjunction nested) . sequenceA . runValueSpecs_ (fmap pure valueDoc)
disjunction :: Bool -> [Doc] -> Doc
disjunction _ [x] = x
disjunction True xs = parens (hsep (intersperse "or" xs))
disjunction False xs = hsep (intersperse "or" xs)
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 False s)
CustomSpec l w' -> (txt l <+>) <$> valuesDoc True w'
ListSpec ws -> ("list of" <+>) <$> valuesDoc True ws
AssocSpec ws -> ("association list of" <+>) <$> valuesDoc True ws
newtype DocBuilder a = DocBuilder (State (Map Text Doc) a)
deriving (Functor, Applicative, Monad)
runDocBuilder :: DocBuilder a -> (a, Map Text Doc)
runDocBuilder (DocBuilder b) = runState b mempty
instance S.Semigroup a => S.Semigroup (DocBuilder a) where
(<>) = liftA2 (S.<>)
instance (S.Semigroup a, Monoid a) => Monoid (DocBuilder a) where
mempty = pure mempty
mappend = (S.<>)
emitDoc ::
Text ->
DocBuilder Doc ->
DocBuilder Doc
emitDoc l (DocBuilder sub) = DocBuilder $
do m <- get
unless (Map.member l m) $
do rec put $! Map.insert l val m
val <- sub
return ()
return (txt l)
txt :: Text -> Doc
txt = text . Text.unpack
vcat' :: [Doc] -> Doc
vcat' = foldr ($+$) empty