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
  ) 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 . (.items)

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

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"

renderUsage :: [SynopsisItem] -> Doc ann
renderUsage = go . buildUsage
 where
  go u =
    let ws =
          nonEmpty
            $ maybeToList (pChars <$> nonEmpty u.chars)
              <> u.shorts
              <> u.longs
              <> u.args
              <> u.command
    in  case ws of
          Nothing -> mempty
          Just ne -> vsep $ ".Bk -words" : toList ne <> [".Ek"]

  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 (Described {item = PositionalSwitch (Flag c _)}) ->
    acc & field @"chars" %~ sortOn toLower . (<> [c])
  Single d ->
    acc
      & usageSetter d.item
        <>~ [ opLine d
                $ ellipsis d
                $ pretty
                $ Positional1 d.item
            ]
  Alternation _ [] -> acc
  Alternation o ds@(d : _) ->
    acc
      & usageSetter d.item
        <>~ [ opLine' o
                $ mconcat
                $ punctuate " | "
                $ map (pretty . Positional1 . (.item)) ds
            ]
  Command -> acc & field @"command" <>~ [".Ar command"]

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