{-# 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.Function (on)
import Data.List (sort, intersperse, groupBy)
import Data.Foldable (any, foldl')
import Data.Maybe (maybeToList, catMaybes, fromMaybe)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (mempty)
#endif
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup (..))
#endif
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 :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
cmdDesc :: 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 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
$
            Int -> [(Doc, Doc)] -> Chunk Doc
tabulate (ParserPrefs -> Int
prefTabulateFill ParserPrefs
pprefs)
              [ (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 = Int -> [(Doc, Doc)] -> Chunk Doc
tabulate (ParserPrefs -> Int
prefTabulateFill ParserPrefs
pprefs) ([(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 }

descriptionHelp :: Chunk Doc -> ParserHelp
descriptionHelp :: Chunk Doc -> ParserHelp
descriptionHelp Chunk Doc
chunk = ParserHelp
forall a. Monoid a => a
mempty { helpDescription :: Chunk Doc
helpDescription = 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
$ 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 (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
group (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
hsep
      [ String -> Doc
string String
"Usage:",
        String -> Doc
string String
progn,
        Int -> Int -> Doc -> Doc
hangAtIfOver Int
9 Int
35 (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)