Core.hs

{-# LANGUAGE CPP #-}
module Options.Applicative.Help.Core (
  cmdDesc,
  briefDesc,
  missingDesc,
  fullDesc,
  globalDesc,
  ParserHelp(..),
  errorHelp,
  headerHelp,
  suggestionsHelp,
  usageHelp,
  descriptionHelp,
  bodyHelp,
  footerHelp,
  globalsHelp,
  parserHelp,
  parserUsage,
  parserGlobals
  ) where

import           Control.Applicative
import           Control.Monad (guard)

import           Data.Foldable (any, foldl')
import           Data.Function (on)
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import           Data.Maybe (fromMaybe, catMaybes)

import           Prelude hiding (any)

import Options.Applicative.Common
import Options.Applicative.Types
import Options.Applicative.Help.Pretty
import Options.Applicative.Help.Chunk

-- | Style for rendering an option.
data OptDescStyle
  = OptDescStyle
      { descSep :: Doc,
        descHidden :: Bool,
        descGlobal :: Bool
      }

safelast :: [a] -> Maybe a
safelast = foldl' (const Just) Nothing

-- | Generate description for a single option.
optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic)
optDesc pprefs style _reachability opt =
  let names =
        List.sort . optionNames . optMain $ opt
      meta =
        stringChunk $ optMetaVar opt
      grp = propGroup $ optProps opt
      descs =
        map (pretty . showOption) names
      descriptions =
        listToChunk (List.intersperse (descSep style) descs)
      desc
        | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) =
          descriptions <> stringChunk "=" <> meta
        | otherwise =
          descriptions <<+>> meta
      show_opt
        | descGlobal style && not (propShowGlobal (optProps opt)) =
          False
        | optVisibility opt == Hidden =
          descHidden style
        | otherwise =
          optVisibility opt == Visible
      wrapping
        | null names =
          NeverRequired
        | length names == 1 =
          MaybeRequired
        | otherwise =
          AlwaysRequired
      rendered
        | not show_opt =
          mempty
        | otherwise =
          desc
      modified =
        maybe id fmap (optDescMod opt) rendered
   in (grp, modified, wrapping)

-- | Generate descriptions for commands.
cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc pprefs = mapParser desc
  where
    desc _ opt =
      case optMain opt of
        CmdReader gn cmds ->
          (,) gn $
            tabulate (prefTabulateFill pprefs)
              [ (pretty nm, align (extractChunk (infoProgDesc cmd)))
              | (nm, cmd) <- reverse cmds
              ]
        _ -> mempty

-- | Generate a brief help text for a parser.
briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
briefDesc = briefDesc' True

-- | Generate a brief help text for a parser, only including mandatory
--   options and arguments.
missingDesc :: ParserPrefs -> Parser a -> Chunk Doc
missingDesc = briefDesc' False

-- | Generate a brief help text for a parser, allowing the specification
--   of if optional arguments are show.
briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
briefDesc' showOptional pprefs =
  wrapOver NoDefault MaybeRequired
    . foldTree pprefs style
    . mFilterOptional
    . treeMapParser optDesc'
  where
    mFilterOptional
      | showOptional =
        id
      | otherwise =
        filterOptional
    style = OptDescStyle
      { descSep = pretty '|',
        descHidden = False,
        descGlobal = False
      }
    optDesc' reach opt =
      let
        (_, a, b) =
          optDesc pprefs style reach opt
      in
        (a, b)

-- | Wrap a doc in parentheses or brackets if required.
wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver altnode mustWrapBeyond (chunk, wrapping)
  | altnode == MarkDefault =
    fmap brackets chunk
  | wrapping > mustWrapBeyond =
    fmap parens chunk
  | otherwise =
    chunk

-- Fold a tree of option docs into a single doc with fully marked
-- optional areas and groups.
foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
foldTree _ _ (Leaf x) =
  x
foldTree prefs s (MultNode xs) =
  let go =
        (<</>>) . wrapOver NoDefault MaybeRequired . foldTree prefs s
      x =
        foldr go mempty xs
      wrapLevel =
        multi_wrap xs
   in (x, wrapLevel)
  where
    multi_wrap [_] = NeverRequired
    multi_wrap _ = MaybeRequired
foldTree prefs s (AltNode b xs) =
  (\x -> (x, NeverRequired))
    . fmap groupOrNestLine
    . wrapOver b MaybeRequired
    . alt_node
    . filter (not . isEmpty . fst)
    . map (foldTree prefs s)
    $ xs
  where
    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
    alt_node [n] = n
    alt_node ns =
      (\y -> (y, AlwaysRequired))
        . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty
        $ ns
foldTree prefs s (BindNode x) =
  let rendered =
        wrapOver NoDefault NeverRequired (foldTree prefs s x)

      -- We always want to display the rendered option
      -- if it exists, and only attach the suffix then.
      withSuffix =
        rendered >>= (\r -> pure r <> stringChunk (prefMultiSuffix prefs))
   in (withSuffix, NeverRequired)

-- | Generate a full help text for a parser
fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
fullDesc = optionsDesc False

-- | Generate a help text for the parser, showing
--   only what is relevant in the "Global options: section"
globalDesc :: ParserPrefs -> Parser a -> Chunk Doc
globalDesc = optionsDesc True

-- | Common generator for full descriptions and globals
optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
optionsDesc global pprefs p =
  vsepChunks
    . formatTitle'
    . fmap tabulateGroup
    . groupByTitle
    $ docs
  where
    docs :: [Maybe (OptGroup, (Doc, Doc))]
    docs = mapParser doc p

    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
    groupByTitle xs = groupFstAll . catMaybes $ xs

    -- NOTE: [Nested group alignment]
    --
    -- For nested groups, we want to produce output like:
    --
    -- Group 1
    --   --opt-1 INT          Option 1
    --
    -- - Group 2
    --     --opt-2 INT        Option 2
    --
    --   - Group 3
    --       - opt-3 INT      Option 3
    --
    -- That is, we have the following constraints:
    --
    --   1. Nested groups are prefixed with a hyphen '- ', where the hyphen
    --     starts on the same column as the parent group.
    --
    --   2. We still want the listed options to be indented twice under the
    --     group name, so this means nested options need to be indented
    --     again by the standard amount (2), due to the hyphen.
    --
    --   3. Help text should be __globally__ aligned.

    tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)
    tabulateGroup l@((title,_):_) =
      (title, tabulate (prefTabulateFill pprefs) (getGroup <$> l))
      where
        -- Handle NOTE: [Nested group alignment] 3. here i.e. indent the
        -- right Doc (help text) according to its indention level and
        -- global maxGroupLevel. Notice there is an inverse relationship here,
        -- as the further the entire group is indented, the less we need to
        -- indent the help text.
        getGroup :: (OptGroup, (Doc, Doc)) -> (Doc, Doc)
        getGroup o@(_, (x, y)) =
          let helpIndent = calcOptHelpIndent o
          in (x, indent helpIndent y)

        -- Indents the option help text, taking the option's group level and
        -- maximum group level into account.
        calcOptHelpIndent :: (OptGroup, a) -> Int
        calcOptHelpIndent g =
          let groupLvl = optGroupToLevel g
          in lvlIndent * (maxGroupLevel - groupLvl)

    tabulateGroup [] = (OptGroup [], mempty)

    -- Fold so we can update the (printedGroups :: [String]) arg as we
    -- iterate. End with a reverse since we use foldl'.
    formatTitle' :: [(OptGroup, Chunk Doc)] -> [Chunk Doc]
    formatTitle' = reverse . snd . foldl' formatTitle ([], [])

    formatTitle :: ([String], [Chunk Doc]) -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])
    formatTitle (printedGroups, acc) o@(OptGroup groups, opts) =
      case parentGroups of
        -- No nested groups: No special logic.
        [] -> (groupTitle : printedGroups, ((\d -> pretty groupTitle .$. d) <$> opts) : acc)
        -- We have at least one parent group title P for current group G: P has
        -- already been printed iff it is attached to another (non-grouped)
        -- option. In other words, P has __not__ been printed if its only
        -- member is another group.
        --
        -- The parameter (printedGroups :: [String]) holds all groups that
        -- have already been printed.
        parents@(_ : _) ->
          let groupLvl = optGroupToLevel o
              -- indent opts an extra lvlIndent to account for hyphen
              indentOpts = indent lvlIndent

              -- new printedGroups is all previous + this and parents.
              printedGroups' = groupTitle : parents ++ printedGroups

              parentsWithIndent = zip [0 .. ] parents

              -- docs for unprinted parent title groups
              parentDocs = pure $ mkParentDocs printedGroups parentsWithIndent

              -- docs for the current group
              thisDocs =
                (\d -> lvlIndentNSub1 groupLvl $ (hyphenate groupTitle) .$. indentOpts d)
                  <$> opts

              allDocs = parentDocs <> thisDocs

          in (printedGroups', allDocs : acc)
      where
        -- Separate parentGroups and _this_ group, in case we need to also
        -- print parent groups.
        (parentGroups, groupTitle) = case unsnoc groups of
          Nothing -> ([], defTitle)
          Just (parentGrps, grp) -> (parentGrps, grp)

        defTitle =
          if global
            then "Global options:"
            else "Available options:"

    maxGroupLevel :: Int
    maxGroupLevel = findMaxGroupLevel docs

    -- Finds the maxium OptGroup level.
    findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int
    findMaxGroupLevel = foldl' (\acc -> max acc . optGroupToLevel) 0 . catMaybes

    optGroupToLevel :: (OptGroup, a) -> Int
    -- 0 (defTitle) and 1 (custom group name) are handled identically
    -- w.r.t indenation (not indented). Hence the subtraction here.
    optGroupToLevel (OptGroup [], _) = 0
    optGroupToLevel (OptGroup xs@(_ : _), _) = length xs - 1

    doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc))
    doc info opt = do
      guard . not . isEmpty $ n
      guard . not . isEmpty $ h
      return (grp, (extractChunk n, align . extractChunk $ h <</>> hdef))
      where
        (grp, n, _) = optDesc pprefs style info opt
        h = optHelp opt
        hdef = Chunk . fmap show_def . optShowDefault $ opt
        show_def s = parens (pretty "default:" <+> pretty s)
    style = OptDescStyle
      { descSep = pretty ',',
        descHidden = True,
        descGlobal = global
      }

    --
    -- Prints all parent titles that have not already been printed
    -- (i.e. in printedGroups).
    mkParentDocs :: [String] -> [(Int, String)] -> Doc
    mkParentDocs printedGroups =
        foldr g mempty
      where
        g :: (Int, String) -> Doc ->  Doc
        g (i, s) acc
          | s `List.elem` printedGroups = acc
          | i == 0 = pretty s .$. acc
          | otherwise = lvlIndentNSub1 i $ hyphenate s .$. acc

    hyphenate s = pretty ("- " <> s)

    lvlIndentNSub1 :: Int -> Doc -> Doc
    lvlIndentNSub1 n = indent (lvlIndent * (n - 1))

    lvlIndent :: Int
    lvlIndent = 2

errorHelp :: Chunk Doc -> ParserHelp
errorHelp chunk = mempty { helpError = chunk }

headerHelp :: Chunk Doc -> ParserHelp
headerHelp chunk = mempty { helpHeader = chunk }

suggestionsHelp :: Chunk Doc -> ParserHelp
suggestionsHelp chunk = mempty { helpSuggestions = chunk }

globalsHelp :: Chunk Doc -> ParserHelp
globalsHelp chunk = mempty { helpGlobals = chunk }

usageHelp :: Chunk Doc -> ParserHelp
usageHelp chunk = mempty { helpUsage = chunk }

descriptionHelp :: Chunk Doc -> ParserHelp
descriptionHelp chunk = mempty { helpDescription = chunk }

bodyHelp :: Chunk Doc -> ParserHelp
bodyHelp chunk = mempty { helpBody = chunk }

footerHelp :: Chunk Doc -> ParserHelp
footerHelp chunk = mempty { helpFooter = chunk }

-- | Generate the help text for a program.
parserHelp :: ParserPrefs -> Parser a -> ParserHelp
parserHelp pprefs p =
  bodyHelp . vsepChunks $
    fullDesc pprefs p
      : (group_title <$> cs)
  where
    def = "Available commands:"
    cs = groupFstAll $ cmdDesc pprefs p

    group_title a@((n, _) : _) =
      with_title (fromMaybe def n) $
        vcatChunks (snd <$> a)
    group_title _ = mempty

    with_title :: String -> Chunk Doc -> Chunk Doc
    with_title title = fmap (pretty title .$.)


parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
parserGlobals pprefs p =
  globalsHelp $ globalDesc pprefs p



-- | Generate option summary.
parserUsage :: ParserPrefs -> Parser a -> String -> Doc
parserUsage pprefs p progn =
  group $
    hsep
      [ pretty "Usage:",
        pretty progn,
        hangAtIfOver 9 (prefBriefHangPoint pprefs) (extractChunk (briefDesc pprefs p))
      ]

-- | Peek at the structure of the rendered tree within.
--
--   For example, if a child is an option with multiple
--   alternatives, such as -a or -b, we need to know this
--   when wrapping it. For example, whether it's optional:
--   we don't want to have [(-a|-b)], rather [-a|-b] or
--   (-a|-b).
data Parenthetic
  = NeverRequired
  -- ^ Parenthesis are not required.
  | MaybeRequired
  -- ^ Parenthesis should be used if this group can be repeated
  | AlwaysRequired
  -- ^ Parenthesis should always be used.
  deriving (Eq, Ord, Show)

-- | Groups on the first element of the tuple. This differs from the simple
-- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped
-- together. For example:
--
-- @
--   groupFst = groupBy ((==) `on` fst)
--
--   let xs = [(1, "a"), (1, "b"), (3, "c"), (2, "d"), (3, "e"), (2, "f")]
--
--   groupFst xs === [[(1,"a"),(1,"b")],[(3,"c")],[(2,"d")],[(3,"e")],[(2,"f")]]
--   groupFstAll xs === [[(1,"a"),(1,"b")],[(3,"c"),(3,"e")],[(2,"d"),(2,"f")]]
-- @
--
-- Notice that the original order is preserved i.e. we do not first sort on
-- the first element.
--
-- @since 0.19.0.0
groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]]
groupFstAll =
  -- In order to group all (adjacent + non-adjacent) Eq elements together, we
  -- sort the list so that the Eq elements are in fact adjacent, _then_ group.
  -- We don't want to destroy the original order, however, so we add a
  -- temporary index that maintains this original order. The full logic is:
  --
  -- 1. Add index i that preserves original order.
  -- 2. Sort on tuple's fst.
  -- 3. Group by fst.
  -- 4. Sort by i, restoring original order.
  -- 5. Drop index i.
  fmap (NE.toList . dropIdx)
    . List.sortOn toIdx
    . NE.groupBy ((==) `on` fst')
    . List.sortOn fst'
    . zipWithIndex
  where
    dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
    dropIdx = fmap snd

    toIdx :: NonEmpty (Int, (a, b)) -> Int
    toIdx ((x, _) :| _) = x

    -- Like fst, ignores our added index
    fst' :: (Int, (a, b)) -> a
    fst' (_, (x, _)) = x

    zipWithIndex :: [(a, b)] -> [(Int, (a, b))]
    zipWithIndex = zip [1 ..]

-- | From base-4.19.0.0.
unsnoc :: [a] -> Maybe ([a], a)
unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing