Mdoc.hs

-- |
--
-- Module      : OptEnvConf.Mdoc
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- A small, semi-representative, not type-checked example:
--
-- @
-- -- This input parser
-- parser :: Parser Options
-- parser = Option
--   \<$> setting [short 'C', long "context", help "Include context" <> metavar "num"]
--   \<*> setting [short 'v', long "debug", env \"DEBUG\", help "Log more verbosely"]
--   \<*> some1 (setting [argument, metavar "file"])
-- @
--
-- @
-- .\" Generates this mandoc source
-- .Sh SYNOPSIS
-- .Nm
-- .Op Fl Ar Cv
-- .Op Fl Fl debug
-- .Ar file
-- .Op Ar file ...
-- .Sh DESCRIPTION
-- The options are as follows:
-- .Bl -tag -width indent
-- .It Fl C Ar num
-- Include context
-- .It Fl v | Fl Fl verbose
-- Log more verbosely
-- .It Ar file
-- .El
-- .Sh ENVIRONMENT
-- The following environment variables affect the execution of
-- .Bl -tag -width \"DEBUG\"
-- .It Cm DEBUG
-- Log more verbosely
-- .El
-- .Sh EXIT STATUS
-- .Ex -std
-- @
--
-- Which renders something like:
--
-- @
-- SYNOPSIS
--   thing [-Cv] [--debug] file [file ...]
--
-- DESCRIPTION
--   The options are as follows:
--
--   -C                 Include context
--
--   -v | --debug       Log more verbosely
--
--   file
--
-- ENVIRONMENT
--   The following environment variables affect the execution of thing:
--
--   DEBUG Log more verbosely
--
-- EXIT STATUS
--   The thing utility exits 0 for success, and >0 if an error occurs.
-- @
--
-- For something more complete, see "Mdoc.GenSpec".
module OptEnvConf.Mdoc
  ( addToMan1
  , addToMan5
  ) where

import Mdoc.Prelude

import Autodocodec.Schema.Mdoc qualified as JSONSchema
import Mdoc.Gen.Argument
import Mdoc.Gen.Config
import Mdoc.Gen.Described
import Mdoc.Gen.EnvVar
import Mdoc.Gen.Flag
import Mdoc.Gen.Man1
import Mdoc.Gen.Man5
import Mdoc.Gen.Option
import Mdoc.Gen.Optionality
import Mdoc.Optics
import OptEnvConf (ConfDoc (..), EnvDoc (..), OptDoc (..), Parser)
import OptEnvConf.Args (Dashed (..))
import OptEnvConf.Doc
  ( AnyDocs (..)
  , parserConfDocs
  , parserEnvDocs
  , parserOptDocs
  )

addToMan1 :: Parser a -> Man1 -> Man1
addToMan1 p m =
  m
    & field @"switches" <>~ switches
    & field @"options" <>~ options
    & field @"arguments" <>~ getParserArgs p
    & field @"environment" <>~ getParserEnvs p
 where
  (switches, options) = partitionDescribed $ getParserOpts p

addToMan5 :: Parser a -> Man5 -> Man5
addToMan5 p m = m & field @"configs" <>~ getParserConfs p

getParserOpts :: Parser a -> [Described (Either Flag Option)]
getParserOpts = walkNonCommandDocs (maybe [] optDocToOpt) . parserOptDocs

getParserArgs :: Parser a -> [Described Argument]
getParserArgs = walkNonCommandDocs (maybe [] optDocToArg) . parserOptDocs

getParserEnvs :: Parser a -> [Described EnvVar]
getParserEnvs = walkNonCommandDocs envDocToEnvVar . parserEnvDocs

-- getParserCmds :: Parser a -> [Command]
-- getParserCmds = walkCommandDocs commandDocToCommand . parserOptDocs

getParserConfs :: Parser a -> [Described Config]
getParserConfs = walkNonCommandDocs confToConfig . parserConfDocs

optDocToOpt :: OptDoc -> [Described (Either Flag Option)]
optDocToOpt doc =
  fromMaybe [] $ do
    flag <- dashedFlags $ optDocDasheds doc

    let item = case optDocMetavar doc of
          Nothing -> Left flag
          Just schema ->
            let
              argument = Argument {schema, optionality = Required}
              option = Option {flag, argument}
            in
              Right option

    pure
      [ Described
          { item
          , optionality = maybe Required Defaulted $ optDocDefault doc
          , multiple = False
          , helpLines = nonEmpty . lines =<< optDocHelp doc
          }
      ]

optDocToArg :: OptDoc -> [Described Argument]
optDocToArg doc =
  case (optDocDasheds doc, optDocMetavar doc) of
    ([], Just schema) ->
      [ Described
          { item =
              Argument
                { schema
                , optionality = Required
                }
          , optionality = maybe Required Defaulted $ optDocDefault doc
          , multiple = False
          , helpLines = nonEmpty . lines =<< optDocHelp doc
          }
      ]
    _ -> []

envDocToEnvVar :: EnvDoc -> [Described EnvVar]
envDocToEnvVar doc =
  [ Described
      { item =
          EnvVar
            { names = envDocVars doc
            , argument =
                envDocMetavar doc <&> \schema ->
                  Argument {schema, optionality = Required}
            }
      , optionality = maybe Required Defaulted $ envDocDefault doc
      , multiple = False
      , helpLines = nonEmpty . lines =<< envDocHelp doc
      }
  ]

-- commandDocToCommand :: CommandDoc (Maybe OptDoc) -> [Command]
-- commandDocToCommand c =
--   [ Command
--       { name = commandDocArgument c
--       , help = Just $ commandDocHelp c
--       , opts = walkNonCommandDocs 0 (maybe [] . optDocToOpt) $ commandDocs c
--       , args = walkNonCommandDocs 0 (maybe [] . optDocToArg) $ commandDocs c
--       , visible = True
--       , required = True
--       , multiple = False
--       , def = Nothing
--       }
--   ]

confToConfig :: ConfDoc -> [Described Config]
confToConfig doc =
  concatMap (\(keys, js) -> addMeta $ JSONSchema.getConfigs (Just keys) js)
    $ toList
    $ confDocKeys doc
 where
  addMeta :: [Described Config] -> [Described Config]
  addMeta = \case
    [] -> []
    (d : ds) ->
      d
        { optionality = maybe Required Defaulted $ confDocDefault doc
        , multiple = False
        , helpLines = nonEmpty . lines =<< confDocHelp doc
        }
        : ds

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

-- walkCommandDocs :: (CommandDoc a -> [b]) -> AnyDocs a -> [b]
-- walkCommandDocs f = \case
--   AnyDocsCommands _mDefault cmds -> concatMap f cmds
--   AnyDocsAnd ds -> concatMap (walkCommandDocs f) ds
--   AnyDocsOr ds -> concatMap (walkCommandDocs f) ds
--   AnyDocsSingle {} -> []

walkNonCommandDocs :: (a -> [Described b]) -> AnyDocs a -> [Described b]
walkNonCommandDocs f = \case
  AnyDocsCommands {} -> []
  AnyDocsAnd ds -> concatMap (walkNonCommandDocs f) ds
  AnyDocsOr ds -> concatMap (map mkMultiple . walkNonCommandDocs f) ds
  AnyDocsSingle d -> f 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 do treat it as both since
  -- it passes our current tests.
  mkMultiple d = d {optionality = Optional, multiple = True}