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
  , command

    -- * Rendering in-line
  , InlineSynopsis (..)
  ) 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

newtype Synopsis = Synopsis
  { items :: [SynopsisItem]
  }
  deriving stock (Eq, Show)
  deriving newtype (Monoid, Semigroup)
  deriving (ToJSON) via (Rendered Synopsis)

instance Pretty Synopsis where
  pretty = renderUsage Vertical . (.items)

newtype InlineSynopsis = InlineSynopsis
  { unwrap :: Synopsis
  }
  deriving stock (Eq, Show)
  deriving (ToJSON) via (Rendered InlineSynopsis)

instance Pretty InlineSynopsis where
  pretty = renderUsage Inline . (.unwrap.items)

data SynopsisItem
  = Single (Described Positional)
  | Alternation Optionality [Described Positional]
  | Command Optionality
  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

command :: Optionality -> Synopsis
command o = Synopsis [Command o]

data Usage ann = Usage
  { chars :: [Char]
  -- ^ list those [short] options not taking arguments first, in alphabetical
  -- order
  , shorts :: [Doc ann]
  -- ^ After that, list all [short] options taking arguments
  , longs :: [Doc ann]
  -- ^ If there are long options, list them after the short options that take
  -- arguments, just before the command line arguments
  , args :: [Doc ann]
  -- ^ Arguments follow the last option
  , command :: [Doc ann]
  }
  deriving stock (Generic, Show)
  deriving (Monoid, Semigroup) via Generically (Usage ann)

usageSetter :: Positional -> Lens' (Usage ann) [Doc ann]
usageSetter = \case
  PositionalOption (Option {flag = Flag {}}) -> field @"shorts"
  PositionalOption (Option {flag = GNUFlag {}}) -> field @"longs"
  PositionalSwitch (GNUFlag {}) -> field @"longs"
  PositionalSwitch (Flag {}) -> field @"shorts" -- edge-case
  PositionalArgument {} -> field @"args"

data Alignment
  = Vertical
  | Inline

renderUsage :: Alignment -> [SynopsisItem] -> Doc ann
renderUsage a = go . buildUsage a
 where
  go u =
    maybe mempty (vsep' . toList)
      $ nonEmpty
      $ maybeToList (pChars <$> nonEmpty u.chars)
        <> u.shorts
        <> u.longs
        <> u.args
        <> u.command

  pChars cs = op a Optional $ "Fl" <+> pretty (fixMacro $ esc $ pack $ toList cs)

  vsep' = case a of
    Vertical -> vsep . map ("." <>) . (<> ["Ek"]) . (["Bk -words"] <>)
    Inline -> hsep

-- | 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 :: Alignment -> [SynopsisItem] -> Usage ann
buildUsage a = foldl (addUsage a) mempty . sort

addUsage :: Alignment -> Usage ann -> SynopsisItem -> Usage ann
addUsage a acc = \case
  Single (Described {item = PositionalSwitch (Flag c _)}) ->
    acc & field @"chars" %~ sortOn toLower . (<> [c])
  Single d ->
    acc
      & usageSetter d.item
        <>~ [ op a d.optionality
                $ ellipsis d
                $ pretty
                $ Positional1 d.item
            ]
  Alternation _ [] -> acc
  Alternation o ds@(d : _) ->
    acc
      & usageSetter d.item
        <>~ [ op a o
                $ mconcat
                $ punctuate " | "
                $ map (pretty . Positional1 . (.item)) ds
            ]
  Command o -> acc & field @"command" <>~ [op a o "Ar command"]

op :: Alignment -> Optionality -> Doc ann -> Doc ann
op a o = case (a, o) of
  (_, Required) -> id
  (Vertical, _) -> ("Op" <+>)
  (Inline, _) -> (\x -> "Oo" <+> x <+> "Oc")

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