{-# 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
      { OptDescStyle -> Doc
descSep :: Doc,
        OptDescStyle -> Bool
descHidden :: Bool,
        OptDescStyle -> Bool
descGlobal :: Bool
      }

safelast :: [a] -> Maybe a
safelast :: forall a. [a] -> Maybe a
safelast = (Maybe a -> a -> Maybe a) -> Maybe a -> [a] -> Maybe a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((a -> Maybe a) -> Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const a -> Maybe a
forall a. a -> Maybe a
Just) Maybe a
forall a. Maybe a
Nothing

-- | Generate description for a single option.
optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic)
optDesc :: forall a.
ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (OptGroup, Chunk Doc, Parenthetic)
optDesc ParserPrefs
pprefs OptDescStyle
style ArgumentReachability
_reachability Option a
opt =
  let names :: [OptName]
names =
        [OptName] -> [OptName]
forall a. Ord a => [a] -> [a]
List.sort ([OptName] -> [OptName])
-> (Option a -> [OptName]) -> Option a -> [OptName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptReader a -> [OptName]
forall a. OptReader a -> [OptName]
optionNames (OptReader a -> [OptName])
-> (Option a -> OptReader a) -> Option a -> [OptName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option a -> OptReader a
forall a. Option a -> OptReader a
optMain (Option a -> [OptName]) -> Option a -> [OptName]
forall a b. (a -> b) -> a -> b
$ Option a
opt
      meta :: Chunk Doc
meta =
        String -> Chunk Doc
stringChunk (String -> Chunk Doc) -> String -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ Option a -> String
forall a. Option a -> String
optMetaVar Option a
opt
      grp :: OptGroup
grp = OptProperties -> OptGroup
propGroup (OptProperties -> OptGroup) -> OptProperties -> OptGroup
forall a b. (a -> b) -> a -> b
$ Option a -> OptProperties
forall a. Option a -> OptProperties
optProps Option a
opt
      descs :: [Doc ann]
descs =
        (OptName -> Doc ann) -> [OptName] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (OptName -> String) -> OptName -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptName -> String
showOption) [OptName]
names
      descriptions :: Chunk Doc
descriptions =
        [Doc] -> Chunk Doc
forall a. Semigroup a => [a] -> Chunk a
listToChunk (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse (OptDescStyle -> Doc
descSep OptDescStyle
style) [Doc]
forall {ann}. [Doc ann]
descs)
      desc :: Chunk Doc
desc
        | ParserPrefs -> Bool
prefHelpLongEquals ParserPrefs
pprefs Bool -> Bool -> Bool
&& Bool -> Bool
not (Chunk Doc -> Bool
forall a. Chunk a -> Bool
isEmpty Chunk Doc
meta) Bool -> Bool -> Bool
&& (OptName -> Bool) -> Maybe OptName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any OptName -> Bool
isLongName ([OptName] -> Maybe OptName
forall a. [a] -> Maybe a
safelast [OptName]
names) =
          Chunk Doc
descriptions Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Semigroup a => a -> a -> a
<> String -> Chunk Doc
stringChunk String
"=" Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Semigroup a => a -> a -> a
<> Chunk Doc
meta
        | Bool
otherwise =
          Chunk Doc
descriptions Chunk Doc -> Chunk Doc -> Chunk Doc
<<+>> Chunk Doc
meta
      show_opt :: Bool
show_opt
        | OptDescStyle -> Bool
descGlobal OptDescStyle
style Bool -> Bool -> Bool
&& Bool -> Bool
not (OptProperties -> Bool
propShowGlobal (Option a -> OptProperties
forall a. Option a -> OptProperties
optProps Option a
opt)) =
          Bool
False
        | Option a -> OptVisibility
forall a. Option a -> OptVisibility
optVisibility Option a
opt OptVisibility -> OptVisibility -> Bool
forall a. Eq a => a -> a -> Bool
== OptVisibility
Hidden =
          OptDescStyle -> Bool
descHidden OptDescStyle
style
        | Bool
otherwise =
          Option a -> OptVisibility
forall a. Option a -> OptVisibility
optVisibility Option a
opt OptVisibility -> OptVisibility -> Bool
forall a. Eq a => a -> a -> Bool
== OptVisibility
Visible
      wrapping :: Parenthetic
wrapping
        | [OptName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OptName]
names =
          Parenthetic
NeverRequired
        | [OptName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OptName]
names Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
          Parenthetic
MaybeRequired
        | Bool
otherwise =
          Parenthetic
AlwaysRequired
      rendered :: Chunk Doc
rendered
        | Bool -> Bool
not Bool
show_opt =
          Chunk Doc
forall a. Monoid a => a
mempty
        | Bool
otherwise =
          Chunk Doc
desc
      modified :: Chunk Doc
modified =
        (Chunk Doc -> Chunk Doc)
-> ((Doc -> Doc) -> Chunk Doc -> Chunk Doc)
-> Maybe (Doc -> Doc)
-> Chunk Doc
-> Chunk Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Chunk Doc -> Chunk Doc
forall a. a -> a
id (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Option a -> Maybe (Doc -> Doc)
forall a. Option a -> Maybe (Doc -> Doc)
optDescMod Option a
opt) Chunk Doc
rendered
   in (OptGroup
grp, Chunk Doc
modified, Parenthetic
wrapping)

-- | Generate descriptions for commands.
cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc :: forall a. ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc ParserPrefs
pprefs = (forall x.
 ArgumentReachability -> Option x -> (Maybe String, Chunk Doc))
-> Parser a -> [(Maybe String, Chunk Doc)]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser ArgumentReachability -> Option x -> (Maybe String, Chunk Doc)
forall x.
ArgumentReachability -> Option x -> (Maybe String, Chunk Doc)
forall {p} {a}. p -> Option a -> (Maybe String, Chunk Doc)
desc
  where
    desc :: p -> Option a -> (Maybe String, Chunk Doc)
desc p
_ Option a
opt =
      case Option a -> OptReader a
forall a. Option a -> OptReader a
optMain Option a
opt of
        CmdReader Maybe String
gn [(String, ParserInfo a)]
cmds ->
          (,) Maybe String
gn (Chunk Doc -> (Maybe String, Chunk Doc))
-> Chunk Doc -> (Maybe String, Chunk Doc)
forall a b. (a -> b) -> a -> b
$
            Int -> [(Doc, Doc)] -> Chunk Doc
tabulate (ParserPrefs -> Int
prefTabulateFill ParserPrefs
pprefs)
              [ (String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
nm, Doc -> Doc
forall ann. Doc ann -> Doc ann
align (Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk (ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoProgDesc ParserInfo a
cmd)))
              | (String
nm, ParserInfo a
cmd) <- [(String, ParserInfo a)] -> [(String, ParserInfo a)]
forall a. [a] -> [a]
reverse [(String, ParserInfo a)]
cmds
              ]
        OptReader a
_ -> (Maybe String, Chunk Doc)
forall a. Monoid a => a
mempty

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

-- | Generate a brief help text for a parser, only including mandatory
--   options and arguments.
missingDesc :: ParserPrefs -> Parser a -> Chunk Doc
missingDesc :: forall a. ParserPrefs -> Parser a -> Chunk Doc
missingDesc = Bool -> ParserPrefs -> Parser a -> Chunk Doc
forall a. Bool -> ParserPrefs -> Parser a -> Chunk Doc
briefDesc' Bool
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' :: forall a. Bool -> ParserPrefs -> Parser a -> Chunk Doc
briefDesc' Bool
showOptional ParserPrefs
pprefs =
  AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
NoDefault Parenthetic
MaybeRequired
    ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> (Parser a -> (Chunk Doc, Parenthetic)) -> Parser a -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
pprefs OptDescStyle
style
    (OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> (Parser a -> OptTree (Chunk Doc, Parenthetic))
-> Parser a
-> (Chunk Doc, Parenthetic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptTree (Chunk Doc, Parenthetic)
-> OptTree (Chunk Doc, Parenthetic)
forall {a}. OptTree a -> OptTree a
mFilterOptional
    (OptTree (Chunk Doc, Parenthetic)
 -> OptTree (Chunk Doc, Parenthetic))
-> (Parser a -> OptTree (Chunk Doc, Parenthetic))
-> Parser a
-> OptTree (Chunk Doc, Parenthetic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x.
 ArgumentReachability -> Option x -> (Chunk Doc, Parenthetic))
-> Parser a -> OptTree (Chunk Doc, Parenthetic)
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> OptTree b
treeMapParser ArgumentReachability -> Option x -> (Chunk Doc, Parenthetic)
forall x.
ArgumentReachability -> Option x -> (Chunk Doc, Parenthetic)
optDesc'
  where
    mFilterOptional :: OptTree a -> OptTree a
mFilterOptional
      | Bool
showOptional =
        OptTree a -> OptTree a
forall a. a -> a
id
      | Bool
otherwise =
        OptTree a -> OptTree a
forall {a}. OptTree a -> OptTree a
filterOptional
    style :: OptDescStyle
style = OptDescStyle
      { descSep :: Doc
descSep = Char -> Doc
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'|',
        descHidden :: Bool
descHidden = Bool
False,
        descGlobal :: Bool
descGlobal = Bool
False
      }
    optDesc' :: ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic)
optDesc' ArgumentReachability
reach Option a
opt =
      let
        (OptGroup
_, Chunk Doc
a, Parenthetic
b) =
          ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (OptGroup, Chunk Doc, Parenthetic)
forall a.
ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (OptGroup, Chunk Doc, Parenthetic)
optDesc ParserPrefs
pprefs OptDescStyle
style ArgumentReachability
reach Option a
opt
      in
        (Chunk Doc
a, Parenthetic
b)

-- | Wrap a doc in parentheses or brackets if required.
wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
altnode Parenthetic
mustWrapBeyond (Chunk Doc
chunk, Parenthetic
wrapping)
  | AltNodeType
altnode AltNodeType -> AltNodeType -> Bool
forall a. Eq a => a -> a -> Bool
== AltNodeType
MarkDefault =
    (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
forall ann. Doc ann -> Doc ann
brackets Chunk Doc
chunk
  | Parenthetic
wrapping Parenthetic -> Parenthetic -> Bool
forall a. Ord a => a -> a -> Bool
> Parenthetic
mustWrapBeyond =
    (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
forall ann. Doc ann -> Doc ann
parens Chunk Doc
chunk
  | Bool
otherwise =
    Chunk Doc
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 :: ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
_ OptDescStyle
_ (Leaf (Chunk Doc, Parenthetic)
x) =
  (Chunk Doc, Parenthetic)
x
foldTree ParserPrefs
prefs OptDescStyle
s (MultNode [OptTree (Chunk Doc, Parenthetic)]
xs) =
  let go :: OptTree (Chunk Doc, Parenthetic) -> Chunk Doc -> Chunk Doc
go =
        Chunk Doc -> Chunk Doc -> Chunk Doc
(<</>>) (Chunk Doc -> Chunk Doc -> Chunk Doc)
-> (OptTree (Chunk Doc, Parenthetic) -> Chunk Doc)
-> OptTree (Chunk Doc, Parenthetic)
-> Chunk Doc
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
NoDefault Parenthetic
MaybeRequired ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> (OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> OptTree (Chunk Doc, Parenthetic)
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
prefs OptDescStyle
s
      x :: Chunk Doc
x =
        (OptTree (Chunk Doc, Parenthetic) -> Chunk Doc -> Chunk Doc)
-> Chunk Doc -> [OptTree (Chunk Doc, Parenthetic)] -> Chunk Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr OptTree (Chunk Doc, Parenthetic) -> Chunk Doc -> Chunk Doc
go Chunk Doc
forall a. Monoid a => a
mempty [OptTree (Chunk Doc, Parenthetic)]
xs
      wrapLevel :: Parenthetic
wrapLevel =
        [OptTree (Chunk Doc, Parenthetic)] -> Parenthetic
forall {a}. [a] -> Parenthetic
multi_wrap [OptTree (Chunk Doc, Parenthetic)]
xs
   in (Chunk Doc
x, Parenthetic
wrapLevel)
  where
    multi_wrap :: [a] -> Parenthetic
multi_wrap [a
_] = Parenthetic
NeverRequired
    multi_wrap [a]
_ = Parenthetic
MaybeRequired
foldTree ParserPrefs
prefs OptDescStyle
s (AltNode AltNodeType
b [OptTree (Chunk Doc, Parenthetic)]
xs) =
  (\Chunk Doc
x -> (Chunk Doc
x, Parenthetic
NeverRequired))
    (Chunk Doc -> (Chunk Doc, Parenthetic))
-> ([OptTree (Chunk Doc, Parenthetic)] -> Chunk Doc)
-> [OptTree (Chunk Doc, Parenthetic)]
-> (Chunk Doc, Parenthetic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
groupOrNestLine
    (Chunk Doc -> Chunk Doc)
-> ([OptTree (Chunk Doc, Parenthetic)] -> Chunk Doc)
-> [OptTree (Chunk Doc, Parenthetic)]
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
b Parenthetic
MaybeRequired
    ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> ([OptTree (Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic))
-> [OptTree (Chunk Doc, Parenthetic)]
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
alt_node
    ([(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic))
-> ([OptTree (Chunk Doc, Parenthetic)]
    -> [(Chunk Doc, Parenthetic)])
-> [OptTree (Chunk Doc, Parenthetic)]
-> (Chunk Doc, Parenthetic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chunk Doc, Parenthetic) -> Bool)
-> [(Chunk Doc, Parenthetic)] -> [(Chunk Doc, Parenthetic)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Chunk Doc, Parenthetic) -> Bool)
-> (Chunk Doc, Parenthetic)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk Doc -> Bool
forall a. Chunk a -> Bool
isEmpty (Chunk Doc -> Bool)
-> ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> (Chunk Doc, Parenthetic)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk Doc, Parenthetic) -> Chunk Doc
forall a b. (a, b) -> a
fst)
    ([(Chunk Doc, Parenthetic)] -> [(Chunk Doc, Parenthetic)])
-> ([OptTree (Chunk Doc, Parenthetic)]
    -> [(Chunk Doc, Parenthetic)])
-> [OptTree (Chunk Doc, Parenthetic)]
-> [(Chunk Doc, Parenthetic)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> [OptTree (Chunk Doc, Parenthetic)] -> [(Chunk Doc, Parenthetic)]
forall a b. (a -> b) -> [a] -> [b]
map (ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
prefs OptDescStyle
s)
    ([OptTree (Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic))
-> [OptTree (Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
forall a b. (a -> b) -> a -> b
$ [OptTree (Chunk Doc, Parenthetic)]
xs
  where
    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
alt_node [(Chunk Doc, Parenthetic)
n] = (Chunk Doc, Parenthetic)
n
    alt_node [(Chunk Doc, Parenthetic)]
ns =
      (\Chunk Doc
y -> (Chunk Doc
y, Parenthetic
AlwaysRequired))
        (Chunk Doc -> (Chunk Doc, Parenthetic))
-> ([(Chunk Doc, Parenthetic)] -> Chunk Doc)
-> [(Chunk Doc, Parenthetic)]
-> (Chunk Doc, Parenthetic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chunk Doc, Parenthetic) -> Chunk Doc -> Chunk Doc)
-> Chunk Doc -> [(Chunk Doc, Parenthetic)] -> Chunk Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> Doc
altSep (Chunk Doc -> Chunk Doc -> Chunk Doc)
-> ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> (Chunk Doc, Parenthetic)
-> Chunk Doc
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
NoDefault Parenthetic
MaybeRequired) Chunk Doc
forall a. Monoid a => a
mempty
        ([(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic))
-> [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
forall a b. (a -> b) -> a -> b
$ [(Chunk Doc, Parenthetic)]
ns
foldTree ParserPrefs
prefs OptDescStyle
s (BindNode OptTree (Chunk Doc, Parenthetic)
x) =
  let rendered :: Chunk Doc
rendered =
        AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
NoDefault Parenthetic
NeverRequired (ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
prefs OptDescStyle
s OptTree (Chunk Doc, Parenthetic)
x)

      -- We always want to display the rendered option
      -- if it exists, and only attach the suffix then.
      withSuffix :: Chunk Doc
withSuffix =
        Chunk Doc
rendered Chunk Doc -> (Doc -> Chunk Doc) -> Chunk Doc
forall a b. Chunk a -> (a -> Chunk b) -> Chunk b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Doc
r -> Doc -> Chunk Doc
forall a. a -> Chunk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc
r Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Semigroup a => a -> a -> a
<> String -> Chunk Doc
stringChunk (ParserPrefs -> String
prefMultiSuffix ParserPrefs
prefs))
   in (Chunk Doc
withSuffix, Parenthetic
NeverRequired)

-- | Generate a full help text for a parser
fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
fullDesc :: forall a. ParserPrefs -> Parser a -> Chunk Doc
fullDesc = Bool -> ParserPrefs -> Parser a -> Chunk Doc
forall a. Bool -> ParserPrefs -> Parser a -> Chunk Doc
optionsDesc Bool
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 :: forall a. ParserPrefs -> Parser a -> Chunk Doc
globalDesc = Bool -> ParserPrefs -> Parser a -> Chunk Doc
forall a. Bool -> ParserPrefs -> Parser a -> Chunk Doc
optionsDesc Bool
True

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

    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
groupByTitle [Maybe (OptGroup, (Doc, Doc))]
xs = [(OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
forall a b. Ord a => [(a, b)] -> [[(a, b)]]
groupFstAll ([(OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]])
-> ([Maybe (OptGroup, (Doc, Doc))] -> [(OptGroup, (Doc, Doc))])
-> [Maybe (OptGroup, (Doc, Doc))]
-> [[(OptGroup, (Doc, Doc))]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (OptGroup, (Doc, Doc))] -> [(OptGroup, (Doc, Doc))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]])
-> [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]
forall a b. (a -> b) -> a -> b
$ [Maybe (OptGroup, (Doc, Doc))]
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 :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)
tabulateGroup l :: [(OptGroup, (Doc, Doc))]
l@((OptGroup
title,(Doc, Doc)
_):[(OptGroup, (Doc, Doc))]
_) =
      (OptGroup
title, Int -> [(Doc, Doc)] -> Chunk Doc
tabulate (ParserPrefs -> Int
prefTabulateFill ParserPrefs
pprefs) ((OptGroup, (Doc, Doc)) -> (Doc, Doc)
getGroup ((OptGroup, (Doc, Doc)) -> (Doc, Doc))
-> [(OptGroup, (Doc, Doc))] -> [(Doc, Doc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(OptGroup, (Doc, Doc))]
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 :: (OptGroup, (Doc, Doc)) -> (Doc, Doc)
getGroup o :: (OptGroup, (Doc, Doc))
o@(OptGroup
_, (Doc
x, Doc
y)) =
          let helpIndent :: Int
helpIndent = (OptGroup, (Doc, Doc)) -> Int
forall a. (OptGroup, a) -> Int
calcOptHelpIndent (OptGroup, (Doc, Doc))
o
          in (Doc
x, Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
indent Int
helpIndent Doc
y)

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

    tabulateGroup [] = ([String] -> OptGroup
OptGroup [], Chunk Doc
forall a. Monoid a => a
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' :: [(OptGroup, Chunk Doc)] -> [Chunk Doc]
formatTitle' = [Chunk Doc] -> [Chunk Doc]
forall a. [a] -> [a]
reverse ([Chunk Doc] -> [Chunk Doc])
-> ([(OptGroup, Chunk Doc)] -> [Chunk Doc])
-> [(OptGroup, Chunk Doc)]
-> [Chunk Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], [Chunk Doc]) -> [Chunk Doc]
forall a b. (a, b) -> b
snd (([String], [Chunk Doc]) -> [Chunk Doc])
-> ([(OptGroup, Chunk Doc)] -> ([String], [Chunk Doc]))
-> [(OptGroup, Chunk Doc)]
-> [Chunk Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], [Chunk Doc])
 -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc]))
-> ([String], [Chunk Doc])
-> [(OptGroup, Chunk Doc)]
-> ([String], [Chunk Doc])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([String], [Chunk Doc])
-> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])
formatTitle ([], [])

    formatTitle :: ([String], [Chunk Doc]) -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])
    formatTitle :: ([String], [Chunk Doc])
-> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])
formatTitle ([String]
printedGroups, [Chunk Doc]
acc) o :: (OptGroup, Chunk Doc)
o@(OptGroup [String]
groups, Chunk Doc
opts) =
      case [String]
parentGroups of
        -- No nested groups: No special logic.
        [] -> (String
groupTitle String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
printedGroups, ((\Doc
d -> String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
groupTitle Doc -> Doc -> Doc
.$. Doc
d) (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
opts) Chunk Doc -> [Chunk Doc] -> [Chunk Doc]
forall a. a -> [a] -> [a]
: [Chunk Doc]
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 :: [String]
parents@(String
_ : [String]
_) ->
          let groupLvl :: Int
groupLvl = (OptGroup, Chunk Doc) -> Int
forall a. (OptGroup, a) -> Int
optGroupToLevel (OptGroup, Chunk Doc)
o
              -- indent opts an extra lvlIndent to account for hyphen
              indentOpts :: Doc ann -> Doc ann
indentOpts = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
lvlIndent

              -- new printedGroups is all previous + this and parents.
              printedGroups' :: [String]
printedGroups' = String
groupTitle String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
parents [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
printedGroups

              parentsWithIndent :: [(Int, String)]
parentsWithIndent = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 .. ] [String]
parents

              -- docs for unprinted parent title groups
              parentDocs :: Chunk Doc
parentDocs = Doc -> Chunk Doc
forall a. a -> Chunk a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Chunk Doc) -> Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ [String] -> [(Int, String)] -> Doc
mkParentDocs [String]
printedGroups [(Int, String)]
parentsWithIndent

              -- docs for the current group
              thisDocs :: Chunk Doc
thisDocs =
                (\Doc
d -> Int -> Doc -> Doc
lvlIndentNSub1 Int
groupLvl (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc
forall ann. String -> Doc ann
hyphenate String
groupTitle) Doc -> Doc -> Doc
.$. Doc -> Doc
forall ann. Doc ann -> Doc ann
indentOpts Doc
d)
                  (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
opts

              allDocs :: Chunk Doc
allDocs = Chunk Doc
parentDocs Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Semigroup a => a -> a -> a
<> Chunk Doc
thisDocs

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

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

    maxGroupLevel :: Int
    maxGroupLevel :: Int
maxGroupLevel = [Maybe (OptGroup, (Doc, Doc))] -> Int
findMaxGroupLevel [Maybe (OptGroup, (Doc, Doc))]
docs

    -- Finds the maxium OptGroup level.
    findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int
    findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int
findMaxGroupLevel = (Int -> (OptGroup, (Doc, Doc)) -> Int)
-> Int -> [(OptGroup, (Doc, Doc))] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
acc -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
acc (Int -> Int)
-> ((OptGroup, (Doc, Doc)) -> Int) -> (OptGroup, (Doc, Doc)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptGroup, (Doc, Doc)) -> Int
forall a. (OptGroup, a) -> Int
optGroupToLevel) Int
0 ([(OptGroup, (Doc, Doc))] -> Int)
-> ([Maybe (OptGroup, (Doc, Doc))] -> [(OptGroup, (Doc, Doc))])
-> [Maybe (OptGroup, (Doc, Doc))]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (OptGroup, (Doc, Doc))] -> [(OptGroup, (Doc, Doc))]
forall a. [Maybe a] -> [a]
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 :: forall a. (OptGroup, a) -> Int
optGroupToLevel (OptGroup [], a
_) = Int
0
    optGroupToLevel (OptGroup xs :: [String]
xs@(String
_ : [String]
_), a
_) = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

    doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc))
    doc :: forall x.
ArgumentReachability -> Option x -> Maybe (OptGroup, (Doc, Doc))
doc ArgumentReachability
info Option a
opt = do
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Chunk Doc -> Bool) -> Chunk Doc -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Chunk Doc -> Bool) -> Chunk Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk Doc -> Bool
forall a. Chunk a -> Bool
isEmpty (Chunk Doc -> Maybe ()) -> Chunk Doc -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Chunk Doc
n
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Chunk Doc -> Bool) -> Chunk Doc -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Chunk Doc -> Bool) -> Chunk Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk Doc -> Bool
forall a. Chunk a -> Bool
isEmpty (Chunk Doc -> Maybe ()) -> Chunk Doc -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Chunk Doc
h
      (OptGroup, (Doc, Doc)) -> Maybe (OptGroup, (Doc, Doc))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (OptGroup
grp, (Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk Chunk Doc
n, Doc -> Doc
forall ann. Doc ann -> Doc ann
align (Doc -> Doc) -> (Chunk Doc -> Doc) -> Chunk Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk (Chunk Doc -> Doc) -> Chunk Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Chunk Doc
h Chunk Doc -> Chunk Doc -> Chunk Doc
<</>> Chunk Doc
forall {ann}. Chunk (Doc ann)
hdef))
      where
        (OptGroup
grp, Chunk Doc
n, Parenthetic
_) = ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (OptGroup, Chunk Doc, Parenthetic)
forall a.
ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (OptGroup, Chunk Doc, Parenthetic)
optDesc ParserPrefs
pprefs OptDescStyle
style ArgumentReachability
info Option a
opt
        h :: Chunk Doc
h = Option a -> Chunk Doc
forall a. Option a -> Chunk Doc
optHelp Option a
opt
        hdef :: Chunk (Doc ann)
hdef = Maybe (Doc ann) -> Chunk (Doc ann)
forall a. Maybe a -> Chunk a
Chunk (Maybe (Doc ann) -> Chunk (Doc ann))
-> (Option a -> Maybe (Doc ann)) -> Option a -> Chunk (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc ann) -> Maybe String -> Maybe (Doc ann)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
show_def (Maybe String -> Maybe (Doc ann))
-> (Option a -> Maybe String) -> Option a -> Maybe (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option a -> Maybe String
forall a. Option a -> Maybe String
optShowDefault (Option a -> Chunk (Doc ann)) -> Option a -> Chunk (Doc ann)
forall a b. (a -> b) -> a -> b
$ Option a
opt
        show_def :: a -> Doc ann
show_def a
s = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"default:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
s)
    style :: OptDescStyle
style = OptDescStyle
      { descSep :: Doc
descSep = Char -> Doc
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
',',
        descHidden :: Bool
descHidden = Bool
True,
        descGlobal :: Bool
descGlobal = Bool
global
      }

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

    hyphenate :: String -> Doc ann
hyphenate String
s = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s)

    lvlIndentNSub1 :: Int -> Doc -> Doc
    lvlIndentNSub1 :: Int -> Doc -> Doc
lvlIndentNSub1 Int
n = Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
indent (Int
lvlIndent Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

    lvlIndent :: Int
    lvlIndent :: Int
lvlIndent = Int
2

errorHelp :: Chunk Doc -> ParserHelp
errorHelp :: Chunk Doc -> ParserHelp
errorHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpError = chunk }

headerHelp :: Chunk Doc -> ParserHelp
headerHelp :: Chunk Doc -> ParserHelp
headerHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpHeader = chunk }

suggestionsHelp :: Chunk Doc -> ParserHelp
suggestionsHelp :: Chunk Doc -> ParserHelp
suggestionsHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpSuggestions = chunk }

globalsHelp :: Chunk Doc -> ParserHelp
globalsHelp :: Chunk Doc -> ParserHelp
globalsHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpGlobals = chunk }

usageHelp :: Chunk Doc -> ParserHelp
usageHelp :: Chunk Doc -> ParserHelp
usageHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpUsage = chunk }

descriptionHelp :: Chunk Doc -> ParserHelp
descriptionHelp :: Chunk Doc -> ParserHelp
descriptionHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpDescription = chunk }

bodyHelp :: Chunk Doc -> ParserHelp
bodyHelp :: Chunk Doc -> ParserHelp
bodyHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpBody = chunk }

footerHelp :: Chunk Doc -> ParserHelp
footerHelp :: Chunk Doc -> ParserHelp
footerHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpFooter = chunk }

-- | Generate the help text for a program.
parserHelp :: ParserPrefs -> Parser a -> ParserHelp
parserHelp :: forall a. ParserPrefs -> Parser a -> ParserHelp
parserHelp ParserPrefs
pprefs Parser a
p =
  Chunk Doc -> ParserHelp
bodyHelp (Chunk Doc -> ParserHelp)
-> ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> ParserHelp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Chunk Doc] -> Chunk Doc
vsepChunks ([Chunk Doc] -> ParserHelp) -> [Chunk Doc] -> ParserHelp
forall a b. (a -> b) -> a -> b
$
    ParserPrefs -> Parser a -> Chunk Doc
forall a. ParserPrefs -> Parser a -> Chunk Doc
fullDesc ParserPrefs
pprefs Parser a
p
      Chunk Doc -> [Chunk Doc] -> [Chunk Doc]
forall a. a -> [a] -> [a]
: ([(Maybe String, Chunk Doc)] -> Chunk Doc
group_title ([(Maybe String, Chunk Doc)] -> Chunk Doc)
-> [[(Maybe String, Chunk Doc)]] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Maybe String, Chunk Doc)]]
cs)
  where
    def :: String
def = String
"Available commands:"
    cs :: [[(Maybe String, Chunk Doc)]]
cs = [(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]]
forall a b. Ord a => [(a, b)] -> [[(a, b)]]
groupFstAll ([(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]])
-> [(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]]
forall a b. (a -> b) -> a -> b
$ ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
forall a. ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc ParserPrefs
pprefs Parser a
p

    group_title :: [(Maybe String, Chunk Doc)] -> Chunk Doc
group_title a :: [(Maybe String, Chunk Doc)]
a@((Maybe String
n, Chunk Doc
_) : [(Maybe String, Chunk Doc)]
_) =
      String -> Chunk Doc -> Chunk Doc
with_title (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
def Maybe String
n) (Chunk Doc -> Chunk Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$
        [Chunk Doc] -> Chunk Doc
vcatChunks ((Maybe String, Chunk Doc) -> Chunk Doc
forall a b. (a, b) -> b
snd ((Maybe String, Chunk Doc) -> Chunk Doc)
-> [(Maybe String, Chunk Doc)] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe String, Chunk Doc)]
a)
    group_title [(Maybe String, Chunk Doc)]
_ = Chunk Doc
forall a. Monoid a => a
mempty

    with_title :: String -> Chunk Doc -> Chunk Doc
    with_title :: String -> Chunk Doc -> Chunk Doc
with_title String
title = (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
title Doc -> Doc -> Doc
.$.)


parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
parserGlobals :: forall a. ParserPrefs -> Parser a -> ParserHelp
parserGlobals ParserPrefs
pprefs Parser a
p =
  Chunk Doc -> ParserHelp
globalsHelp (Chunk Doc -> ParserHelp) -> Chunk Doc -> ParserHelp
forall a b. (a -> b) -> a -> b
$ ParserPrefs -> Parser a -> Chunk Doc
forall a. ParserPrefs -> Parser a -> Chunk Doc
globalDesc ParserPrefs
pprefs Parser a
p



-- | Generate option summary.
parserUsage :: ParserPrefs -> Parser a -> String -> Doc
parserUsage :: forall a. ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs Parser a
p String
progn =
  Doc -> Doc
forall ann. Doc ann -> Doc ann
group (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
hsep
      [ String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"Usage:",
        String -> Doc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
progn,
        Int -> Int -> Doc -> Doc
hangAtIfOver Int
9 (ParserPrefs -> Int
prefBriefHangPoint ParserPrefs
pprefs) (Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk (ParserPrefs -> Parser a -> Chunk Doc
forall a. ParserPrefs -> Parser a -> Chunk Doc
briefDesc ParserPrefs
pprefs Parser a
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 (Parenthetic -> Parenthetic -> Bool
(Parenthetic -> Parenthetic -> Bool)
-> (Parenthetic -> Parenthetic -> Bool) -> Eq Parenthetic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Parenthetic -> Parenthetic -> Bool
== :: Parenthetic -> Parenthetic -> Bool
$c/= :: Parenthetic -> Parenthetic -> Bool
/= :: Parenthetic -> Parenthetic -> Bool
Eq, Eq Parenthetic
Eq Parenthetic =>
(Parenthetic -> Parenthetic -> Ordering)
-> (Parenthetic -> Parenthetic -> Bool)
-> (Parenthetic -> Parenthetic -> Bool)
-> (Parenthetic -> Parenthetic -> Bool)
-> (Parenthetic -> Parenthetic -> Bool)
-> (Parenthetic -> Parenthetic -> Parenthetic)
-> (Parenthetic -> Parenthetic -> Parenthetic)
-> Ord Parenthetic
Parenthetic -> Parenthetic -> Bool
Parenthetic -> Parenthetic -> Ordering
Parenthetic -> Parenthetic -> Parenthetic
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Parenthetic -> Parenthetic -> Ordering
compare :: Parenthetic -> Parenthetic -> Ordering
$c< :: Parenthetic -> Parenthetic -> Bool
< :: Parenthetic -> Parenthetic -> Bool
$c<= :: Parenthetic -> Parenthetic -> Bool
<= :: Parenthetic -> Parenthetic -> Bool
$c> :: Parenthetic -> Parenthetic -> Bool
> :: Parenthetic -> Parenthetic -> Bool
$c>= :: Parenthetic -> Parenthetic -> Bool
>= :: Parenthetic -> Parenthetic -> Bool
$cmax :: Parenthetic -> Parenthetic -> Parenthetic
max :: Parenthetic -> Parenthetic -> Parenthetic
$cmin :: Parenthetic -> Parenthetic -> Parenthetic
min :: Parenthetic -> Parenthetic -> Parenthetic
Ord, Int -> Parenthetic -> String -> String
[Parenthetic] -> String -> String
Parenthetic -> String
(Int -> Parenthetic -> String -> String)
-> (Parenthetic -> String)
-> ([Parenthetic] -> String -> String)
-> Show Parenthetic
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Parenthetic -> String -> String
showsPrec :: Int -> Parenthetic -> String -> String
$cshow :: Parenthetic -> String
show :: Parenthetic -> String
$cshowList :: [Parenthetic] -> String -> String
showList :: [Parenthetic] -> String -> String
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 :: forall a b. 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.
  (NonEmpty (Int, (a, b)) -> [(a, b)])
-> [NonEmpty (Int, (a, b))] -> [[(a, b)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty (a, b) -> [(a, b)]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (a, b) -> [(a, b)])
-> (NonEmpty (Int, (a, b)) -> NonEmpty (a, b))
-> NonEmpty (Int, (a, b))
-> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
forall a b. NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
dropIdx)
    ([NonEmpty (Int, (a, b))] -> [[(a, b)]])
-> ([(a, b)] -> [NonEmpty (Int, (a, b))]) -> [(a, b)] -> [[(a, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (Int, (a, b)) -> Int)
-> [NonEmpty (Int, (a, b))] -> [NonEmpty (Int, (a, b))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn NonEmpty (Int, (a, b)) -> Int
forall a b. NonEmpty (Int, (a, b)) -> Int
toIdx
    ([NonEmpty (Int, (a, b))] -> [NonEmpty (Int, (a, b))])
-> ([(a, b)] -> [NonEmpty (Int, (a, b))])
-> [(a, b)]
-> [NonEmpty (Int, (a, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (a, b)) -> (Int, (a, b)) -> Bool)
-> [(Int, (a, b))] -> [NonEmpty (Int, (a, b))]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NE.groupBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> ((Int, (a, b)) -> a) -> (Int, (a, b)) -> (Int, (a, b)) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, (a, b)) -> a
forall a b. (Int, (a, b)) -> a
fst')
    ([(Int, (a, b))] -> [NonEmpty (Int, (a, b))])
-> ([(a, b)] -> [(Int, (a, b))])
-> [(a, b)]
-> [NonEmpty (Int, (a, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (a, b)) -> a) -> [(Int, (a, b))] -> [(Int, (a, b))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Int, (a, b)) -> a
forall a b. (Int, (a, b)) -> a
fst'
    ([(Int, (a, b))] -> [(Int, (a, b))])
-> ([(a, b)] -> [(Int, (a, b))]) -> [(a, b)] -> [(Int, (a, b))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, b)] -> [(Int, (a, b))]
forall a b. [(a, b)] -> [(Int, (a, b))]
zipWithIndex
  where
    dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
    dropIdx :: forall a b. NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
dropIdx = ((Int, (a, b)) -> (a, b))
-> NonEmpty (Int, (a, b)) -> NonEmpty (a, b)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, (a, b)) -> (a, b)
forall a b. (a, b) -> b
snd

    toIdx :: NonEmpty (Int, (a, b)) -> Int
    toIdx :: forall a b. NonEmpty (Int, (a, b)) -> Int
toIdx ((Int
x, (a, b)
_) :| [(Int, (a, b))]
_) = Int
x

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

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

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