Mdoc.hs

-- |
--
-- Module      : OptEnvConf.Mdoc
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- See "Mdoc.Examples.OptEnvConf".
module OptEnvConf.Mdoc
  ( getPage
  ) where

import Mdoc.Prelude

import Autodocodec.Schema.Mdoc qualified as JSONSchema
import Control.Monad (foldM)
import Control.Monad.State (MonadState (..), evalState, modify)
import Mdoc.Data.Argument
import Mdoc.Data.Command
import Mdoc.Data.Config
import Mdoc.Data.Described
import Mdoc.Data.EnvVar
import Mdoc.Data.Flag
import Mdoc.Data.Option
import Mdoc.Data.Optionality
import Mdoc.Data.Page
import Mdoc.Syntax
import OptEnvConf (CommandDoc (..), Parser, SetDoc (..))
import OptEnvConf.Args (Dashed (..))
import OptEnvConf.Doc (AnyDocs (..), parserDocs)

getPage :: Parser a -> Page
getPage = foldSetDocs addToPage . parserDocs

getCommand :: Int -> CommandDoc (Maybe SetDoc) -> Command
getCommand index doc =
  Command
    { index
    , name = commandDocArgument doc
    , description = textToMdoc $ pack $ commandDocHelp doc
    , synopsis = getSynopsis $ foldSetDocs addToPage $ commandDocs doc
    }

addToPage
  :: Int
  -> Page
  -> Either [CommandDoc (Maybe SetDoc)] (Described SetDoc)
  -> Page
addToPage index acc = \case
  Left cdocs -> addCommands (zipWith getCommand [1 ..] cdocs) acc
  Right d ->
    flip appEndo acc
      $ mconcat
      $ catMaybes
        [ Endo . addSwitch <$> traverse setDocToFlag d
        , Endo . addOption <$> traverse setDocToOption d
        , Endo . addArgument <$> traverse (setDocToArgument index) d
        , Endo . addEnvVar <$> traverse setDocToEnvVar d
        , Just $ foldMap (Endo . addConfig) $ traverse setDocToConfigs d
        ]

setDocToFlag :: SetDoc -> Maybe Flag
setDocToFlag doc = do
  flag <- dashedFlags $ setDocDasheds doc
  flag <$ guard (isNothing $ setDocMetavar doc)

setDocToOption :: SetDoc -> Maybe Option
setDocToOption doc = do
  flag <- dashedFlags $ setDocDasheds doc
  schema <- setDocMetavar doc
  pure $ Option {flag, argument = fromString schema}

setDocToArgument :: Int -> SetDoc -> Maybe Argument
setDocToArgument index doc = do
  guard $ null $ setDocDasheds doc
  schema <- setDocMetavar doc
  pure $ Argument {index, schema, optionality = Required}

setDocToEnvVar :: SetDoc -> Maybe EnvVar
setDocToEnvVar doc = do
  names <- setDocEnvVars doc
  pure $ EnvVar {names, argument = setDocMetavar doc <&> fromString}

setDocToConfigs :: SetDoc -> [Config]
setDocToConfigs =
  map (.item)
    . concatMap (\(keys, js) -> JSONSchema.getConfigs (Just keys) js)
    . maybe [] toList
    . setDocConfKeys

foldSetDocs
  :: (Int -> Page -> Either [CommandDoc (Maybe SetDoc)] (Described SetDoc) -> Page)
  -> AnyDocs (Maybe SetDoc)
  -> Page
foldSetDocs f = flip evalState 0 . foldSetDocsM f mempty

foldSetDocsM
  :: MonadState Int m
  => (Int -> Page -> Either [CommandDoc (Maybe SetDoc)] (Described SetDoc) -> Page)
  -> Page
  -> AnyDocs (Maybe SetDoc)
  -> m Page
foldSetDocsM f acc = \case
  AnyDocsCommands _ cdocs -> do
    index <- get
    modify (+ 1)
    pure $ f index acc $ Left cdocs
  AnyDocsAnd ds -> foldM (foldSetDocsM f) acc ds
  AnyDocsOr ds -> foldM (foldSetDocsM fForOr) acc ds
  AnyDocsSingle Nothing -> pure acc -- hidden/internal
  AnyDocsSingle (Just d) -> do
    index <- get
    modify (+ 1)
    pure
      $ f index acc
      $ Right
      $ Described
        { item = d
        , optionality = maybe Required Defaulted (setDocDefault d)
        , multiple = False
        , help = textToMdoc . pack =<< setDocHelp d
        , example = exampleMdoc <$> nonEmpty (setDocExamples d)
        }
 where
  -- AnyDocsOr is used for Empty, Alt, and Many. The former two map to
  -- optionality while the latter maps to multiple. We don't have enough
  -- information to know what's what, so we treat such cases as both optional
  -- and multiple. I guess that's what OptEnvConf's own `--help` rendering must
  -- do, since it operates on the same lossy `AnyDocs` structure.
  fForOr i m e = f i m $ (<$> e) $ \d ->
    d
      { optionality = case d.optionality of
          Required -> Optional
          o -> o
      , multiple = True
      }

exampleMdoc :: NonEmpty String -> Mdoc
exampleMdoc = Mdoc . map (TextLine . esc . pack) . toList

dashedFlags :: [Dashed] -> Maybe Flag
dashedFlags = fmap go . nonEmpty
 where
  go :: NonEmpty Dashed -> Flag
  go ne =
    let aliases = map (aliasedAs []) $ tail ne
    in  aliasedAs aliases $ head ne

  aliasedAs :: [Flag] -> Dashed -> Flag
  aliasedAs xs = \case
    DashedShort x -> Flag x xs
    DashedLong x -> GNUFlag (toList x) xs