Synopsis.hs

-- |
--
-- Module      : Mdoc.Data.Synopsis
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Mdoc.Data.Synopsis
  ( Synopsis
  , singleton
  , alternation
  , custom
  ) where

import Mdoc.Prelude

import Data.Char (toLower)
import Data.List (sort, sortOn)
import Mdoc.Data.Described
import Mdoc.Data.Flag
import Mdoc.Data.Optionality
import Mdoc.Data.Positional
import Mdoc.Optics
import Mdoc.Pretty
import Mdoc.Syntax

data Synopsis
  = Synopsis [SynopsisItem]
  | SynopsisCustom Mdoc
  deriving stock (Eq, Show)
  deriving (ToJSON) via (Rendered Synopsis)

instance Semigroup Synopsis where
  _ <> a@SynopsisCustom {} = a
  a@SynopsisCustom {} <> _ = a
  Synopsis a <> Synopsis b = Synopsis $ a <> b

instance Monoid Synopsis where
  mempty = Synopsis mempty

instance Pretty Synopsis where
  pretty = \case
    Synopsis items -> renderUsage items
    SynopsisCustom ls -> pretty ls

data SynopsisItem
  = Single (Described Positional)
  | Alternation Optionality [Described Positional]
  deriving stock (Eq, Show)

instance Ord SynopsisItem where
  compare = comparing getFirstPositional
   where
    getFirstPositional :: SynopsisItem -> Maybe (Described Positional)
    getFirstPositional = \case
      Single p -> Just p
      Alternation _ (p : _) -> Just p
      _ -> Nothing

singleton :: Described Positional -> Synopsis
singleton = Synopsis . pure . Single

alternation :: Optionality -> [Described Positional] -> Synopsis
alternation o = Synopsis . pure . Alternation o

custom :: Mdoc -> Synopsis
custom = SynopsisCustom

data Usage ann = Usage
  { chars :: [Char]
  , items :: [Doc ann]
  }
  deriving stock (Generic, Show)
  deriving (Monoid, Semigroup) via Generically (Usage ann)

renderUsage :: [SynopsisItem] -> Doc ann
renderUsage = go . buildUsage
 where
  go u = vsep $ maybeToList (pChars <$> nonEmpty u.chars) <> u.items
  pChars cs = ".Op Fl" <+> pretty (fixMacro $ esc $ pack $ toList cs)

-- | Fix for when short-switches accidentally become a macro name
--
-- For example, @docker(1)@ has short switches @-D@ and @-v@, which become:
--
-- @
-- .Op Fl Dv
-- @
--
-- We have to escape the @Dv@ since it's a macro name.
--
-- It's safe to do this always, I guess, but also easy to only do it if needed.
fixMacro :: Text -> Text
fixMacro t
  | t `elem` macroNames = "\\&" <> t
  | otherwise = t

buildUsage :: [SynopsisItem] -> Usage ann
buildUsage = foldl addUsage mempty . sort

addUsage :: Usage ann -> SynopsisItem -> Usage ann
addUsage acc = \case
  Single d
    | Just c <- getPositionalSwitchChar d.item ->
        acc & field @"chars" %~ sortOn toLower . (<> [c])
    | otherwise ->
        acc
          & field @"items"
            <>~ [ opLine d
                    $ ellipsis d
                    $ pretty
                    $ Positional1 d.item
                ]
  Alternation o ps ->
    acc
      & field @"items"
        <>~ [ opLine' o
                $ mconcat
                $ punctuate " | "
                $ map (pretty . Positional1 . (.item)) ps
            ]

getPositionalSwitchChar :: Positional -> Maybe Char
getPositionalSwitchChar = \case
  PositionalSwitch (Flag c _) -> Just c
  _ -> Nothing

opLine :: Described a -> Doc ann -> Doc ann
opLine = opLine' . (.optionality)

opLine' :: Optionality -> Doc ann -> Doc ann
opLine' = \case
  Required -> ("." <>)
  _ -> (".Op" <+>)

ellipsis :: Described a -> Doc ann -> Doc ann
ellipsis d
  | d.multiple = (<+> "...")
  | otherwise = id