Mdoc.hs

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

import Mdoc.Prelude

import Autodocodec.Schema (JSONSchema (..))
import Data.Aeson qualified as Aeson
import Data.List (intercalate)
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 OptEnvConf (ConfDoc (..), EnvDoc (..), OptDoc (..), Parser)
import OptEnvConf.Args (Dashed (..))
import OptEnvConf.Doc
  ( AnyDocs (..)
  , parserConfDocs
  , parserEnvDocs
  , parserOptDocs
  )

addToMan1 :: Parser a -> Man1 -> Man1
addToMan1 p base =
  base
    { switches = base.switches <> switches
    , options = base.options <> options
    , arguments = base.arguments <> getParserArgs p
    , environment = base.environment <> getParserEnvs p
    }
 where
  (switches, options) = partitionDescribed $ getParserOpts p

partitionDescribed :: [Described (Either a b)] -> ([Described a], [Described b])
partitionDescribed = go ([], [])
 where
  go acc [] = acc
  go (as, bs) (d : ds) = case d.item of
    Left a -> go (as <> [a <$ d], bs) ds
    Right b -> go (as, bs <> [b <$ d]) ds

addToMan5 :: Parser a -> Man5 -> Man5
addToMan5 p base =
  base
    { configs = base.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 = map (uncurry go . first toList) $ toList $ confDocKeys doc
 where
  go :: [String] -> JSONSchema -> Described Config
  go keys jSchema =
    Described
      { item =
          Config
            { name = intercalate "." keys
            , schema = simplifySchema jSchema
            , exampleLines = nonEmpty $ confDocExamples doc
            }
      , optionality = maybe Required Defaulted $ confDocDefault doc
      , multiple = False
      , helpLines = nonEmpty . lines =<< confDocHelp doc
      }

simplifySchema :: JSONSchema -> Schema
simplifySchema = \case
  AnySchema -> "any"
  NullSchema -> "null"
  BoolSchema -> "boolean"
  StringSchema {} -> "string"
  IntegerSchema {} -> "number"
  NumberSchema {} -> "number"
  ArraySchema s -> ListOf $ simplifySchema s
  MapSchema s -> simplifySchema s
  ObjectSchema {} -> "object"
  -- This is only used for `const`, it must match `Value` literally
  ValueSchema v -> case v of
    Aeson.Object {} -> "json"
    Aeson.Array {} -> "json"
    Aeson.String t -> Simple t
    Aeson.Number n -> Simple $ pack $ show n
    Aeson.Bool b -> Simple $ pack $ show b
    Aeson.Null -> "null"
  AnyOfSchema ss -> anyOf $ toList ss
  OneOfSchema ss -> anyOf $ toList ss
  CommentSchema c _ -> Simple c
  RefSchema t -> Simple t
  WithDefSchema _ s -> simplifySchema s
 where
  -- Work around bug in opt-env-conf where all configs are null|x
  anyOf [NullSchema, s] = simplifySchema s
  anyOf ss = AnyOf $ map simplifySchema ss

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}