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 Control.Monad (foldM)
import Control.Monad.State (MonadState (..), evalState, modify)
import Data.List (sort)
import Mdoc.Data.Argument
import Mdoc.Data.Command
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 addToPage $ treeMapParser (const void) p

getCommand :: Int -> String -> O.ParserInfo x -> Command
getCommand index name pinfo =
  Command
    { index
    , name
    , description = textToMdoc =<< docToText doc
    , synopsis = getSynopsis $ getPage $ O.infoParser pinfo
    }
 where
  doc =
    mconcat
      [ O.infoProgDesc pinfo
      , O.infoHeader pinfo
      , O.infoFooter pinfo
      ]

addToPage
  :: Int
  -> Page
  -> Described (O.Option x)
  -> Page
addToPage 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 _mGroup cmds ->
    let
      commands :: [Command]
      commands = zipWith (uncurry . getCommand) [1 ..] $ reverse cmds
    in
      addCommands commands acc
 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 -> Described (O.Option x) -> Page)
  -> O.OptTree (O.Option x)
  -> Page
foldOptTree f = flip evalState 0 . foldOptTreeM f mempty

foldOptTreeM
  :: MonadState Int m
  => (Int -> Page -> Described (O.Option x) -> Page)
  -> Page
  -> O.OptTree (O.Option x)
  -> m Page
foldOptTreeM f acc = \case
  O.Leaf o ->
    case O.optVisibility o of
      O.Visible -> do
        index <- get
        modify (+ 1)
        pure
          $ f index acc
          $ Described
            { item = o
            , optionality = maybe Required Defaulted (O.optShowDefault o)
            , multiple = False
            , help = textToMdoc =<< docToText (O.optHelp o)
            }
      O.Internal -> pure acc
      O.Hidden -> pure 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 -> foldOptTreeM fAsMultiple acc t
 where
  recur
    :: MonadState Int m
    => (Int -> Page -> Described (O.Option x) -> Page)
    -> [O.OptTree (O.Option x)]
    -> m Page
  recur g = foldM (foldOptTreeM g) acc

  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