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 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 fAsMultiple) 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
        }
 where
  -- This is suspect, but it seems we can't distinguish if the Or is being used
  -- to indicate some/many or optionality. We'll just treat it as both since it
  -- passes our current tests.
  fAsMultiple i m e = f i m $ second (\d -> d {optionality = Optional, multiple = True}) e

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