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 (..)
  , fromList
  , singleton
  ) 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 [Described Positional]
  | 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 ps -> pretty $ buildUsage ps
    SynopsisCustom ls -> pretty ls

fromList :: [Described Positional] -> Synopsis
fromList = foldMap singleton

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

data Usage ann = Usage
  { chars :: [Char]
  , shorts :: [Doc ann]
  , longs :: [Doc ann]
  , args :: [Doc ann]
  }
  deriving stock (Generic, Show)
  deriving (Monoid, Semigroup) via Generically (Usage ann)
  deriving (ToJSON) via (Rendered (Usage ann))

instance Pretty (Usage ann) where
  pretty u =
    unAnnotate
      $ vsep
      $ catMaybes
        [ Just ".Nm"
        , Just ".Bk -words"
        , (".Op Fl" <+>) . pretty . esc . pack . toList <$> nonEmpty u.chars
        , vsep . toList <$> nonEmpty (u.shorts <> u.longs <> u.args)
        , Just ".Ek"
        ]

buildUsage :: [Described Positional] -> Usage ann
buildUsage = foldl go mempty . sort

go :: Usage ann -> Described Positional -> Usage ann
go acc d = case d.item of
  PositionalSwitch f -> case f of
    Flag c _ -> acc & field @"chars" %~ sortOn toLower . (<> [c])
    GNUFlag {} -> acc & field @"longs" <>~ [opLine $ pretty $ Flag1 f]
  PositionalOption o ->
    let doc = opLine $ pretty $ Option1 o
    in  case o.flag of
          Flag {} -> acc & field @"shorts" <>~ [doc]
          GNUFlag {} -> acc & field @"longs" <>~ [doc]
  PositionalArgument a -> acc & field @"args" <>~ [opLine $ ellipsis $ pretty a]
 where
  opLine = case d.optionality of
    Required -> ("." <>)
    _ -> (".Op" <+>)

  ellipsis
    | d.multiple = (<+> "...")
    | otherwise = id