Mdoc.hs

{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

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

import Mdoc.Prelude

import Data.List (sort)
import Mdoc.Gen.Argument
import Mdoc.Gen.Described
import Mdoc.Gen.Flag
import Mdoc.Gen.Man1 (Man1 (..))
import Mdoc.Gen.Option
import Mdoc.Gen.Optionality
import Options.Applicative (Parser)
import Options.Applicative.Common (treeMapParser)
import Options.Applicative.Help.Chunk (Chunk (..), unChunk)
import Options.Applicative.Help.Pretty (Doc)
import Options.Applicative.Types qualified as O
import Prettyprinter qualified as Pretty
import Prettyprinter.Render.String qualified as Pretty

-- | Only the bits we work on here
--
-- We walk the options, building up one of these from empty, then we append what
-- we got to the same fields on the input 'Man1'.
data SubMan1 = SubMan1
  { switches :: [Described Flag]
  , options :: [Described Option]
  , arguments :: [Described Argument]
  }
  deriving stock (Generic)
  deriving (Monoid, Semigroup) via Generically SubMan1

toSub :: Man1 -> SubMan1
toSub Man1 {switches, options, arguments} =
  SubMan1 {switches, options, arguments}

fromSub :: Man1 -> SubMan1 -> Man1
fromSub m SubMan1 {switches, options, arguments} =
  m
    { switches = m.switches <> switches
    , options = m.options <> options
    , arguments = m.arguments <> arguments
    }

addToMan1 :: Parser a -> Man1 -> Man1
addToMan1 p base =
  fromSub base
    $ foldOptTree (toSub base) optionToMan1
    $ treeMapParser (const void) p

optionToMan1 :: SubMan1 -> Described (O.Option x) -> SubMan1
optionToMan1 acc d = case O.optMain o of
  O.OptReader onames _ _ -> fromMaybe acc $ do
    flag <- optFlags onames
    schema <- metavar
    let
      argument = Argument {schema, optionality = Required}
      option = Option {flag, argument}
    pure $ acc {options = acc.options <> [option <$ d]}
  O.FlagReader onames _ -> fromMaybe acc $ do
    flag <- optFlags onames
    pure $ acc {switches = acc.switches <> [flag <$ d]}
  O.ArgReader {} -> fromMaybe acc $ do
    schema <- metavar
    let argument = Argument {schema, optionality = Required}
    pure $ acc {arguments = acc.arguments <> [argument <$ d]}
  O.CmdReader {} -> acc -- TODO
 where
  o = d.item
  metavar = guarded (not . null) $ O.optMetaVar o

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

  aliasedAs :: [Flag] -> O.OptName -> Flag
  aliasedAs xs = \case
    O.OptShort x -> Flag x xs
    O.OptLong x -> GNUFlag x xs

foldOptTree
  :: SubMan1
  -> ( SubMan1
       -> Described (O.Option x)
       -> SubMan1
     )
  -> O.OptTree (O.Option x)
  -> SubMan1
foldOptTree acc f = \case
  O.Leaf o ->
    case O.optVisibility o of
      O.Visible ->
        f acc
          $ Described
            { item = o
            , optionality = maybe Required Defaulted (O.optShowDefault o)
            , multiple = False
            , helpLines = nonEmpty $ maybe [] lines $ docToString $ O.optHelp o
            }
      O.Internal -> acc
      O.Hidden -> acc
  O.MultNode ts ->
    maybe acc (foldMap1 $ foldOptTree mempty f) $ nonEmpty ts
  O.AltNode O.MarkDefault ts ->
    maybe acc (foldMap1 $ foldOptTree mempty fAsOptional) $ nonEmpty ts
  O.AltNode O.NoDefault ts ->
    maybe acc (foldMap1 $ foldOptTree mempty fAsRequired) $ nonEmpty ts
  O.BindNode t -> foldOptTree acc fAsMultiple t
 where
  fAsOptional m d = f m $ d {optionality = Optional}
  fAsRequired m d = f m $ d {optionality = Required}
  fAsMultiple m d = f m $ d {multiple = True}

docToString :: Chunk Doc -> Maybe String
docToString =
  fmap
    ( Pretty.renderString
        . Pretty.layoutPretty
          Pretty.defaultLayoutOptions {Pretty.layoutPageWidth = Pretty.Unbounded}
    )
    . unChunk