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
--
-- See "Mdoc.Examples.Grep".
module Options.Applicative.Mdoc
  ( getPage
  ) where

import Mdoc.Prelude

import Data.List (sort)
import Mdoc.Data.Argument
import Mdoc.Data.Described
import Mdoc.Data.Flag
import Mdoc.Data.Option
import Mdoc.Data.Optionality
import Mdoc.Data.Page
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.Text qualified as Pretty

getPage :: Parser a -> Page
getPage p = foldOptTree 0 mempty optionToMan1 $ treeMapParser (const void) p

optionToMan1
  :: Int
  -> Page
  -> Described (O.Option x)
  -> Page
optionToMan1 index acc d = case O.optMain o of
  O.OptReader onames _ _ -> fromMaybe acc $ do
    flag <- optFlags onames
    schema <- metavar
    let
      argument = Argument {index, schema, optionality = Required}
      option = Option {flag, argument}
    pure $ addOption (option <$ d) acc
  O.FlagReader onames _ -> fromMaybe acc $ do
    flag <- optFlags onames
    pure $ addSwitch (flag <$ d) acc
  O.ArgReader {} -> fromMaybe acc $ do
    schema <- metavar
    let argument = Argument {index, schema, optionality = Required}
    pure $ addArgument (argument <$ d) acc
  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
  :: Int
  -> Page
  -> (Int -> Page -> Described (O.Option x) -> Page)
  -> O.OptTree (O.Option x)
  -> Page
foldOptTree index acc f = \case
  O.Leaf o ->
    case O.optVisibility o of
      O.Visible ->
        f index acc
          $ Described
            { item = o
            , optionality = maybe Required Defaulted (O.optShowDefault o)
            , multiple = False
            , help = textToMdoc =<< docToText (O.optHelp o)
            }
      O.Internal -> acc
      O.Hidden -> acc
  O.MultNode ts -> recur f ts
  O.AltNode O.MarkDefault ts -> recur fAsOptional ts
  O.AltNode O.NoDefault ts -> recur fAsRequired ts
  O.BindNode t -> foldOptTree (index + 1) acc fAsMultiple t
 where
  recur g = maybe acc (foldMap1 $ foldOptTree (index + 1) acc g) . nonEmpty

  fAsOptional i m d = f i m $ d {optionality = Optional}
  fAsRequired i m d = f i m $ d {optionality = Required}
  fAsMultiple i m d = f i m $ d {multiple = True}

docToText :: Chunk Doc -> Maybe Text
docToText =
  fmap
    ( Pretty.renderStrict
        . Pretty.layoutPretty
          Pretty.defaultLayoutOptions {Pretty.layoutPageWidth = Pretty.Unbounded}
    )
    . unChunk