{-# 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, MonadPlus)
import Data.Bifunctor (Bifunctor(first))
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.Ann
import Options.Applicative.Help.Chunk
import Options.Applicative.Help.Pretty

{- HLINT ignore "Functor law" -}
{- HLINT ignore "Redundant $" -}
{- HLINT ignore "Redundant id" -}
{- HLINT ignore "Use <$>" -}
{- HLINT ignore "Use tuple-section" -}

-- | 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 = (Chunk Doc -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"optDesc") ((Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall a b. (a -> b) -> a -> b
$
  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 = ((Maybe String, Chunk Doc) -> (Maybe String, Chunk Doc))
-> [(Maybe String, Chunk Doc)] -> [(Maybe String, Chunk Doc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Chunk Doc -> Chunk Doc)
-> (Maybe String, Chunk Doc) -> (Maybe String, Chunk Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"cmdDesc")) ([(Maybe String, Chunk Doc)] -> [(Maybe String, Chunk Doc)])
-> (Parser a -> [(Maybe String, Chunk Doc)])
-> Parser a
-> [(Maybe String, Chunk Doc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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
forall ann. Doc ann -> Doc ann
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 = (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"briefDesc") ((Parser a -> Chunk Doc) -> Parser a -> Chunk Doc)
-> (ParserPrefs -> Parser a -> Chunk Doc)
-> ParserPrefs
-> Parser a
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"missingDesc") ((Parser a -> Chunk Doc) -> Parser a -> Chunk Doc)
-> (ParserPrefs -> Parser a -> Chunk Doc)
-> ParserPrefs
-> Parser a
-> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"briefDesc'")
    (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> 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)
-> (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)
  | Chunk Doc -> Bool
chunkIsEffectivelyEmpty Chunk Doc
chunk =
    Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"wrapOver0" (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
chunk
  | AltNodeType
altnode AltNodeType -> AltNodeType -> Bool
forall a. Eq a => a -> a -> Bool
== AltNodeType
MarkDefault =
    Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"wrapOver1" (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 =
    Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"wrapOver2" (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 =
    Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"wrapOver3" 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 -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"foldTree1")
  (Chunk Doc, Parenthetic)
x
foldTree ParserPrefs
prefs OptDescStyle
s (MultNode [OptTree (Chunk Doc, Parenthetic)]
xs) =
  ( let generous :: Chunk Doc
        generous :: Chunk Doc
generous = Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"generous" (Chunk Doc -> Chunk Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$
            if [OptTree (Chunk Doc, Parenthetic)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OptTree (Chunk Doc, Parenthetic)]
xs
              then Chunk Doc
forall a. Monoid a => a
mempty
              else Chunk Doc -> Chunk Doc
forall a. a -> a
id
                (Chunk Doc -> Chunk Doc)
-> ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Chunk Doc] -> Chunk Doc
forall a. Monoid a => [a] -> a
mconcat
                ([Chunk Doc] -> Chunk Doc)
-> ([Chunk Doc] -> [Chunk Doc]) -> [Chunk Doc] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc, Chunk Doc) -> Chunk Doc)
-> [(Doc, Chunk Doc)] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Doc
w, Chunk Doc
d) -> (Doc
w Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
d)
                ([(Doc, Chunk Doc)] -> [Chunk Doc])
-> ([Chunk Doc] -> [(Doc, Chunk Doc)])
-> [Chunk Doc]
-> [Chunk Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Chunk Doc] -> [(Doc, Chunk Doc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Doc]
leads
                ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ (OptTree (Chunk Doc, Parenthetic) -> Chunk Doc)
-> [OptTree (Chunk Doc, Parenthetic)] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
. (Chunk Doc -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Doc -> Doc
nest Int
2)) ((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
. ParserPrefs
-> OptDescStyle
-> OptTree (Chunk Doc, Parenthetic)
-> (Chunk Doc, Parenthetic)
foldTree ParserPrefs
prefs OptDescStyle
s) [OptTree (Chunk Doc, Parenthetic)]
xs
        compact :: Chunk Doc
        compact :: Chunk Doc
compact = Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"compact" (Chunk Doc -> Chunk Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$
          (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 ((Doc -> Doc -> Doc) -> Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. (a -> a -> a) -> Chunk a -> Chunk a -> Chunk a
chunked Doc -> Doc -> 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) Chunk Doc
forall a. Monoid a => a
mempty [OptTree (Chunk Doc, Parenthetic)]
xs
    in Doc -> Doc
forall ann. Doc ann -> Doc ann
group (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc -> Chunk Doc -> Chunk Doc
chunkFlatAlt Chunk Doc
generous Chunk Doc
compact
  , [OptTree (Chunk Doc, Parenthetic)] -> Parenthetic
forall a. [a] -> Parenthetic
mult_wrap [OptTree (Chunk Doc, Parenthetic)]
xs
  )
  where
    mult_wrap :: [a] -> Parenthetic
mult_wrap [a
_] = Parenthetic
NeverRequired
    mult_wrap [a]
_ = Parenthetic
MaybeRequired
    leads :: [Doc]
    leads :: [Doc]
leads = Doc
forall a. Monoid a => a
memptyDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Doc -> [Doc]
forall a. a -> [a]
repeat (Doc
forall ann. Doc ann
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty String
"  ")

foldTree ParserPrefs
prefs OptDescStyle
s (AltNode AltNodeType
b [OptTree (Chunk Doc, Parenthetic)]
xs) = (Chunk Doc -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"foldTree2") ((Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall a b. (a -> b) -> a -> b
$
  (\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) -> (Chunk Doc, Parenthetic))
-> [(Chunk Doc, Parenthetic)] -> [(Chunk Doc, Parenthetic)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Chunk Doc -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\Chunk Doc
d -> Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 (Chunk Doc -> String
forall a. Show a => a -> String
show Chunk Doc
d) Chunk Doc
d))
    ([(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 =
      ( (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
forall ann. Doc ann -> Doc ann
group
        (Chunk Doc -> Chunk Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ Chunk Doc -> Chunk Doc -> Chunk Doc
chunkFlatAlt
          ( if [(Chunk Doc, Parenthetic)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Chunk Doc, Parenthetic)]
ns
              then Chunk Doc
forall a. Monoid a => a
mempty
              else
                ( [Chunk Doc] -> Chunk Doc
forall a. Monoid a => [a] -> a
mconcat
                ([Chunk Doc] -> Chunk Doc)
-> ([Chunk Doc] -> [Chunk Doc]) -> [Chunk Doc] -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc, Chunk Doc) -> Chunk Doc)
-> [(Doc, Chunk Doc)] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Doc
w, Chunk Doc
d) -> (Doc
w Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chunk Doc
d)
                ([(Doc, Chunk Doc)] -> [Chunk Doc])
-> ([Chunk Doc] -> [(Doc, Chunk Doc)])
-> [Chunk Doc]
-> [Chunk Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Chunk Doc] -> [(Doc, Chunk Doc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Doc]
leads
                ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ ((Chunk Doc, Parenthetic) -> Chunk Doc)
-> [(Chunk Doc, Parenthetic)] -> [Chunk Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
wrapOver AltNodeType
NoDefault Parenthetic
MaybeRequired) [(Chunk Doc, Parenthetic)]
ns
                ) Chunk Doc -> Chunk Doc -> Chunk Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Chunk Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc
forall ann. Doc ann
line
          )

          ( ((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)
-> [(Chunk Doc, Parenthetic)] -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ [(Chunk Doc, Parenthetic)]
ns
          )
      , Parenthetic
AlwaysRequired
      )
    leads :: [Doc]
    leads :: [Doc]
leads = String -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty String
" "Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:Doc -> [Doc]
forall a. a -> [a]
repeat (Doc
forall ann. Doc ann
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
forall a ann. Pretty a => a -> Doc ann
pretty String
"| ")

foldTree ParserPrefs
prefs OptDescStyle
s (BindNode OptTree (Chunk Doc, Parenthetic)
x) = (Chunk Doc -> Chunk Doc)
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"foldTree3") ((Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic))
-> (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
forall a b. (a -> b) -> a -> b
$
  let rendered :: Chunk Doc
rendered = Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
3 String
"rendered" (Chunk Doc -> Chunk Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> a -> b
$
        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 = (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"fullDesc") ((Parser a -> Chunk Doc) -> Parser a -> Chunk Doc)
-> (ParserPrefs -> Parser a -> Chunk Doc)
-> ParserPrefs
-> Parser a
-> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Chunk Doc -> Chunk Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"globalDesc") ((Parser a -> Chunk Doc) -> Parser a -> Chunk Doc)
-> (ParserPrefs -> Parser a -> Chunk Doc)
-> ParserPrefs
-> Parser a
-> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> Chunk Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"optionsDesc")
    (Chunk Doc -> Chunk Doc)
-> (Parser a -> Chunk Doc) -> Parser a -> Chunk Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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.
MonadPlus m =>
ArgumentReachability -> Option a -> m (Doc, Doc)
doc
  where
    doc :: MonadPlus m => ArgumentReachability -> Option a -> m (Doc, Doc)
    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
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
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
forall ann. Doc ann -> Doc ann -> Doc ann
<+> 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
forall (f :: * -> *).
(CanAnnotate (f Doc), Functor f) =>
String -> f Doc -> f 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
forall (f :: * -> *).
(CanAnnotate (f Doc), Functor f) =>
String -> f Doc -> f 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 -> f Doc -> f Doc
with_title String
title = Int -> String -> f Doc -> f Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
1 String
"with_title" (f Doc -> f Doc) -> (f Doc -> f Doc) -> f Doc -> f Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc) -> f Doc -> f 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 = Int -> String -> Doc -> Doc
forall a. CanAnnotate a => Int -> String -> a -> a
annTrace Int
2 String
"parserUsage" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
  case ParserPrefs -> UsageOverflow
prefUsageOverflow ParserPrefs
pprefs of
    UsageOverflow
UsageOverflowAlign ->
      [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
hsep
        [ String -> Doc
string String
"Usage:",
          String -> Doc
string String
progn,
          Doc -> Doc
forall ann. Doc ann -> Doc ann
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))
        ]
    UsageOverflowHang Int
level ->
      Int -> Doc -> Doc
hang Int
level (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
hsep
          [ String -> Doc
string String
"Usage:",
            String -> Doc
string String
progn,
            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)