module Options.Applicative.Help.Core (
  cmdDesc,
  briefDesc,
  missingDesc,
  fullDesc,
  globalDesc,
  ParserHelp(..),
  errorHelp,
  headerHelp,
  suggestionsHelp,
  usageHelp,
  bodyHelp,
  footerHelp,
  globalsHelp,
  parserHelp,
  parserUsage,
  parserGlobals
  ) where

import Control.Applicative
import Control.Monad (guard)
import Data.Function (on)
import Data.List (sort, intersperse, groupBy)
import Data.Foldable (any, foldl')
import Data.Maybe (maybeToList, catMaybes, fromMaybe)
import Data.Monoid (mempty)
import Data.Semigroup (Semigroup (..))
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 :: [a] -> Maybe a
safelast = (Maybe a -> a -> Maybe a) -> Maybe a -> [a] -> Maybe a
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 -> (Chunk Doc, Parenthetic)
optDesc :: ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (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]
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
      descs :: [Doc]
descs =
        (OptName -> Doc) -> [OptName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
string (String -> Doc) -> (OptName -> String) -> OptName -> Doc
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]
intersperse (OptDescStyle -> Doc
descSep OptDescStyle
style) [Doc]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [OptName]
names =
          Parenthetic
NeverRequired
        | [OptName] -> 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 (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 (Chunk Doc
modified, Parenthetic
wrapping)

-- | Generate descriptions for commands.
cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc = (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 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]
cmds String -> Maybe (ParserInfo a)
p ->
          (,) Maybe String
gn (Chunk Doc -> (Maybe String, Chunk Doc))
-> Chunk Doc -> (Maybe String, Chunk Doc)
forall a b. (a -> b) -> a -> b
$
            [(Doc, Doc)] -> Chunk Doc
tabulate
              [ (String -> Doc
string String
cmd, Doc -> Doc
align (Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk Chunk Doc
d))
                | String
cmd <- [String] -> [String]
forall a. [a] -> [a]
reverse [String]
cmds,
                  Chunk Doc
d <- Maybe (Chunk Doc) -> [Chunk Doc]
forall a. Maybe a -> [a]
maybeToList (Maybe (Chunk Doc) -> [Chunk Doc])
-> (Maybe (ParserInfo a) -> Maybe (Chunk Doc))
-> Maybe (ParserInfo a)
-> [Chunk Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParserInfo a -> Chunk Doc)
-> Maybe (ParserInfo a) -> Maybe (Chunk Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParserInfo a -> Chunk Doc
forall a. ParserInfo a -> Chunk Doc
infoProgDesc (Maybe (ParserInfo a) -> [Chunk Doc])
-> Maybe (ParserInfo a) -> [Chunk Doc]
forall a b. (a -> b) -> a -> b
$ String -> Maybe (ParserInfo a)
p String
cmd
              ]
        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 :: 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 :: 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' :: 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 (ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option x
-> (Chunk Doc, Parenthetic)
forall a.
ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (Chunk Doc, Parenthetic)
optDesc ParserPrefs
pprefs OptDescStyle
style)
  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 :: Doc -> Bool -> Bool -> OptDescStyle
OptDescStyle
      { descSep :: Doc
descSep = String -> Doc
string String
"|",
        descHidden :: Bool
descHidden = Bool
False,
        descGlobal :: Bool
descGlobal = Bool
False
      }

-- | 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
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 (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
mult_wrap [OptTree (Chunk Doc, Parenthetic)]
xs
   in (Chunk Doc
x, Parenthetic
wrapLevel)
  where
    mult_wrap :: [a] -> Parenthetic
mult_wrap [a
_] = Parenthetic
NeverRequired
    mult_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 (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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Doc
r -> Doc -> Chunk Doc
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 :: 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 :: 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 :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
optionsDesc Bool
global ParserPrefs
pprefs = [(Doc, Doc)] -> Chunk Doc
tabulate ([(Doc, Doc)] -> Chunk Doc)
-> (Parser a -> [(Doc, Doc)]) -> Parser a -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Doc, Doc)] -> [(Doc, Doc)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Doc, Doc)] -> [(Doc, Doc)])
-> (Parser a -> [Maybe (Doc, Doc)]) -> Parser a -> [(Doc, Doc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. ArgumentReachability -> Option x -> Maybe (Doc, Doc))
-> Parser a -> [Maybe (Doc, Doc)]
forall b a.
(forall x. ArgumentReachability -> Option x -> b)
-> Parser a -> [b]
mapParser forall x. ArgumentReachability -> Option x -> Maybe (Doc, Doc)
forall (m :: * -> *) a.
(Monad m, Alternative m) =>
ArgumentReachability -> Option a -> m (Doc, Doc)
doc
  where
    doc :: ArgumentReachability -> Option a -> m (Doc, Doc)
doc ArgumentReachability
info Option a
opt = do
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> (Chunk Doc -> Bool) -> Chunk Doc -> m ()
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 -> m ()) -> Chunk Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Chunk Doc
n
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> (Chunk Doc -> Bool) -> Chunk Doc -> m ()
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 -> m ()) -> Chunk Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Chunk Doc
h
      (Doc, Doc) -> m (Doc, Doc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Chunk Doc -> Doc
forall a. Monoid a => Chunk a -> a
extractChunk Chunk Doc
n, Doc -> Doc
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
hdef)
      where
        n :: Chunk Doc
n = (Chunk Doc, Parenthetic) -> Chunk Doc
forall a b. (a, b) -> a
fst ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (Chunk Doc, Parenthetic)
forall a.
ParserPrefs
-> OptDescStyle
-> ArgumentReachability
-> Option a
-> (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
hdef = Maybe Doc -> Chunk Doc
forall a. Maybe a -> Chunk a
Chunk (Maybe Doc -> Chunk Doc)
-> (Option a -> Maybe Doc) -> Option a -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> Maybe String -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Doc
show_def (Maybe String -> Maybe Doc)
-> (Option a -> Maybe String) -> Option a -> Maybe Doc
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) -> Option a -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ Option a
opt
        show_def :: String -> Doc
show_def String
s = Doc -> Doc
parens (String -> Doc
string String
"default:" Doc -> Doc -> Doc
<+> String -> Doc
string String
s)
    style :: OptDescStyle
style = OptDescStyle :: Doc -> Bool -> Bool -> OptDescStyle
OptDescStyle
      { descSep :: Doc
descSep = String -> Doc
string String
",",
        descHidden :: Bool
descHidden = Bool
True,
        descGlobal :: Bool
descGlobal = Bool
global
      }

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

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

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

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

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

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

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

-- | Generate the help text for a program.
parserHelp :: ParserPrefs -> Parser a -> ParserHelp
parserHelp :: 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
$
    String -> Chunk Doc -> Chunk Doc
with_title String
"Available options:" (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) -> Bool)
-> [(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe String -> Maybe String -> Bool)
-> ((Maybe String, Chunk Doc) -> Maybe String)
-> (Maybe String, Chunk Doc)
-> (Maybe String, Chunk Doc)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe String, Chunk Doc) -> Maybe String
forall a b. (a, b) -> a
fst) ([(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]])
-> [(Maybe String, Chunk Doc)] -> [[(Maybe String, Chunk Doc)]]
forall a b. (a -> b) -> a -> b
$ Parser a -> [(Maybe String, Chunk Doc)]
forall a. Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Doc
string String
title Doc -> Doc -> Doc
.$.)


parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
parserGlobals :: 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
$
    Doc -> Doc -> Doc
(.$.) (Doc -> Doc -> Doc) -> Chunk Doc -> Chunk (Doc -> Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Chunk Doc
stringChunk String
"Global options:"
          Chunk (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f 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 :: ParserPrefs -> Parser a -> String -> Doc
parserUsage ParserPrefs
pprefs Parser a
p String
progn =
  [Doc] -> Doc
hsep
    [ String -> Doc
string String
"Usage:",
      String -> Doc
string String
progn,
      Doc -> Doc
align (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
/= :: Parenthetic -> Parenthetic -> Bool
$c/= :: Parenthetic -> Parenthetic -> Bool
== :: Parenthetic -> Parenthetic -> Bool
$c== :: 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
min :: Parenthetic -> Parenthetic -> Parenthetic
$cmin :: Parenthetic -> Parenthetic -> Parenthetic
max :: Parenthetic -> Parenthetic -> Parenthetic
$cmax :: Parenthetic -> Parenthetic -> Parenthetic
>= :: Parenthetic -> Parenthetic -> Bool
$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
compare :: Parenthetic -> Parenthetic -> Ordering
$ccompare :: Parenthetic -> Parenthetic -> Ordering
$cp1Ord :: Eq Parenthetic
Ord, Int -> Parenthetic -> ShowS
[Parenthetic] -> ShowS
Parenthetic -> String
(Int -> Parenthetic -> ShowS)
-> (Parenthetic -> String)
-> ([Parenthetic] -> ShowS)
-> Show Parenthetic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Parenthetic] -> ShowS
$cshowList :: [Parenthetic] -> ShowS
show :: Parenthetic -> String
$cshow :: Parenthetic -> String
showsPrec :: Int -> Parenthetic -> ShowS
$cshowsPrec :: Int -> Parenthetic -> ShowS
Show)