-- | Pretty-print of CommandDescs. To explain what the different functions
-- do, we will use an example CmdParser. The CommandDesc derived from that
-- CmdParser will serve as example input to the functions in this module.
--
-- > main = mainFromCmdParserWithHelpDesc $ \helpDesc -> do
-- > 
-- >   addCmdSynopsis "a simple butcher example program"
-- >   addCmdHelpStr "a very long help document"
-- > 
-- >   addCmd "version" $ do
-- >     porcelain <- addSimpleBoolFlag "" ["porcelain"]
-- >       (flagHelpStr "print nothing but the numeric version")
-- >     addCmdHelpStr "prints the version of this program"
-- >     addCmdImpl $ putStrLn $ if porcelain
-- >       then "0.0.0.999"
-- >       else "example, version 0.0.0.999"
-- > 
-- >   addCmd "help" $ addCmdImpl $ print $ ppHelpShallow helpDesc
-- > 
-- >   short <- addSimpleBoolFlag "" ["short"] (flagHelpStr "make the greeting short")
-- >   name <- addStringParam "NAME"
-- >     (paramHelpStr "your name, so you can be greeted properly")
-- > 
-- >   addCmdImpl $ do
-- >     if short
-- >       then putStrLn $ "hi, " ++ name ++ "!"
-- >       else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!"
module UI.Butcher.Monadic.Pretty
  ( ppUsage
  , ppUsageShortSub
  , ppUsageAt
  , ppHelpShallow
  , ppHelpDepthOne
  , ppUsageWithHelp
  , ppPartDescUsage
  , ppPartDescHeader
  , parsingErrorString
  , descendDescTo
  )
where



#include "prelude.inc"
import           Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict
                                               as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict
                                               as MultiStateS

import qualified Text.PrettyPrint              as PP
import           Text.PrettyPrint               ( (<+>)
                                                , ($$)
                                                , ($+$)
                                                )

import           Data.HList.ContainsType

import           UI.Butcher.Monadic.Internal.Types
import           UI.Butcher.Monadic.Internal.Core



-- | ppUsage exampleDesc yields:
--
-- > example [--short] NAME [version | help]
ppUsage :: CommandDesc a -> PP.Doc
ppUsage :: CommandDesc a -> Doc
ppUsage (CommandDesc mParent :: Maybe (Maybe String, CommandDesc a)
mParent _syn :: Maybe Doc
_syn _help :: Maybe Doc
_help parts :: [PartDesc]
parts out :: Maybe a
out children :: Deque (Maybe String, CommandDesc a)
children _hidden :: Visibility
_hidden) =
  Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent Doc -> Doc -> Doc
<+> [Doc] -> Doc
PP.sep [[Doc] -> Doc
PP.fsep [Doc]
partDocs, Doc
subsDoc]
 where
  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
  pparents :: Maybe (Maybe String, CommandDesc out) -> Doc
pparents Nothing              = Doc
PP.empty
  pparents (Just (Just n :: String
n , cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
n
  pparents (Just (Nothing, cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd)
  partDocs :: [Doc]
partDocs = (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
ppPartDescUsage [PartDesc]
parts
  visibleChildren :: Deque (String, CommandDesc a)
visibleChildren =
    [ (String
n, CommandDesc a
c) | (Just n :: String
n, c :: CommandDesc a
c) <- Deque (Maybe String, CommandDesc a)
children, CommandDesc a -> Visibility
forall out. CommandDesc out -> Visibility
_cmd_visibility CommandDesc a
c Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Visible ]
  subsDoc :: Doc
subsDoc = case Maybe a
out of
    _ | Deque (String, CommandDesc a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deque (String, CommandDesc a)
visibleChildren -> Doc
PP.empty
    Nothing | [PartDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PartDesc]
parts -> Doc
subDoc
            | Bool
otherwise  -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
subDoc
    Just{} -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
subDoc
  subDoc :: Doc
subDoc =
    [Doc] -> Doc
PP.fcat
      ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$   Doc -> [Doc] -> [Doc]
PP.punctuate (String -> Doc
PP.text " | ")
      ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$   Deque Doc -> [Doc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList
      (Deque Doc -> [Doc]) -> Deque Doc -> [Doc]
forall a b. (a -> b) -> a -> b
$   (String -> Doc
PP.text (String -> Doc)
-> ((String, CommandDesc a) -> String)
-> (String, CommandDesc a)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, CommandDesc a) -> String
forall a b. (a, b) -> a
fst)
      ((String, CommandDesc a) -> Doc)
-> Deque (String, CommandDesc a) -> Deque Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deque (String, CommandDesc a)
visibleChildren

-- | ppUsageShortSub exampleDesc yields:
--
-- > example [--short] NAME <command>
--
-- I.e. Subcommands are abbreviated using the @<command>@ label, instead
-- of being listed.
ppUsageShortSub :: CommandDesc a -> PP.Doc
ppUsageShortSub :: CommandDesc a -> Doc
ppUsageShortSub (CommandDesc mParent :: Maybe (Maybe String, CommandDesc a)
mParent _syn :: Maybe Doc
_syn _help :: Maybe Doc
_help parts :: [PartDesc]
parts out :: Maybe a
out children :: Deque (Maybe String, CommandDesc a)
children _hidden :: Visibility
_hidden) =
  Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent Doc -> Doc -> Doc
<+> [Doc] -> Doc
PP.sep [[Doc] -> Doc
PP.fsep [Doc]
partDocs, Doc
subsDoc]
 where
  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
  pparents :: Maybe (Maybe String, CommandDesc out) -> Doc
pparents Nothing              = Doc
PP.empty
  pparents (Just (Just n :: String
n , cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
n
  pparents (Just (Nothing, cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd)
  partDocs :: [Doc]
partDocs = (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
ppPartDescUsage [PartDesc]
parts
  visibleChildren :: Deque (String, CommandDesc a)
visibleChildren =
    [ (String
n, CommandDesc a
c) | (Just n :: String
n, c :: CommandDesc a
c) <- Deque (Maybe String, CommandDesc a)
children, CommandDesc a -> Visibility
forall out. CommandDesc out -> Visibility
_cmd_visibility CommandDesc a
c Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Visible ]
  subsDoc :: Doc
subsDoc = case Maybe a
out of
    _ | Deque (String, CommandDesc a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deque (String, CommandDesc a)
visibleChildren -> Doc
PP.empty
    Nothing                  -> Doc
subDoc
    Just{}                   -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
subDoc
  subDoc :: Doc
subDoc = if Deque (String, CommandDesc a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deque (String, CommandDesc a)
visibleChildren then Doc
PP.empty else String -> Doc
PP.text "<command>"

-- | ppUsageWithHelp exampleDesc yields:
--
-- > example [--short] NAME
-- >         [version | help]: a simple butcher example program
--
-- And yes, the line break is not optimal in this instance with default print.
ppUsageWithHelp :: CommandDesc a -> PP.Doc
ppUsageWithHelp :: CommandDesc a -> Doc
ppUsageWithHelp (CommandDesc mParent :: Maybe (Maybe String, CommandDesc a)
mParent _syn :: Maybe Doc
_syn help :: Maybe Doc
help parts :: [PartDesc]
parts out :: Maybe a
out children :: Deque (Maybe String, CommandDesc a)
children _hidden :: Visibility
_hidden) =
  Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent Doc -> Doc -> Doc
<+> [Doc] -> Doc
PP.fsep ([Doc]
partDocs [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
subsDoc]) Doc -> Doc -> Doc
PP.<> Doc
helpDoc
 where
  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
  pparents :: Maybe (Maybe String, CommandDesc out) -> Doc
pparents Nothing              = Doc
PP.empty
  pparents (Just (Just n :: String
n , cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd) Doc -> Doc -> Doc
<+> String -> Doc
PP.text String
n
  pparents (Just (Nothing, cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd)
  partDocs :: [Doc]
partDocs = (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
ppPartDescUsage [PartDesc]
parts
  subsDoc :: Doc
subsDoc  = case Maybe a
out of
    _ | Deque (Maybe String, CommandDesc a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deque (Maybe String, CommandDesc a)
children -> Doc
PP.empty -- TODO: remove debug
    Nothing | [PartDesc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PartDesc]
parts -> Doc
subDoc
            | Bool
otherwise  -> Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
subDoc
    Just{} -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
subDoc
  subDoc :: Doc
subDoc =
    [Doc] -> Doc
PP.fcat
      ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
PP.punctuate (String -> Doc
PP.text " | ")
      ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Deque Doc -> [Doc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList
      (Deque Doc -> [Doc]) -> Deque Doc -> [Doc]
forall a b. (a -> b) -> a -> b
$ [ String -> Doc
PP.text String
n | (Just n :: String
n, c :: CommandDesc a
c) <- Deque (Maybe String, CommandDesc a)
children, CommandDesc a -> Visibility
forall out. CommandDesc out -> Visibility
_cmd_visibility CommandDesc a
c Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Visible ]
  helpDoc :: Doc
helpDoc = case Maybe Doc
help of
    Nothing -> Doc
PP.empty
    Just h :: Doc
h  -> String -> Doc
PP.text ":" Doc -> Doc -> Doc
PP.<+> Doc
h

-- | > ppUsageAt [] = ppUsage
--
-- fromJust $ ppUsageAt ["version"] exampleDesc yields:
--
-- > example version [--porcelain]
ppUsageAt
  :: [String] -- (sub)command sequence
  -> CommandDesc a
  -> Maybe PP.Doc
ppUsageAt :: [String] -> CommandDesc a -> Maybe Doc
ppUsageAt strings :: [String]
strings desc :: CommandDesc a
desc = CommandDesc a -> Doc
forall a. CommandDesc a -> Doc
ppUsage (CommandDesc a -> Doc) -> Maybe (CommandDesc a) -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> CommandDesc a -> Maybe (CommandDesc a)
forall a. [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo [String]
strings CommandDesc a
desc

-- | Access a child command's CommandDesc.
descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo strings :: [String]
strings desc :: CommandDesc a
desc = case [String]
strings of
  [] -> CommandDesc a -> Maybe (CommandDesc a)
forall a. a -> Maybe a
Just CommandDesc a
desc
  (s :: String
s : sr :: [String]
sr) -> do -- Maybe
    (_, childDesc :: CommandDesc a
childDesc) <- ((Maybe String, CommandDesc a) -> Bool)
-> Deque (Maybe String, CommandDesc a)
-> Maybe (Maybe String, CommandDesc a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> Maybe String
forall a. a -> Maybe a
Just String
s Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe String -> Bool)
-> ((Maybe String, CommandDesc a) -> Maybe String)
-> (Maybe String, CommandDesc a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, CommandDesc a) -> Maybe String
forall a b. (a, b) -> a
fst) (CommandDesc a -> Deque (Maybe String, CommandDesc a)
forall out.
CommandDesc out -> Deque (Maybe String, CommandDesc out)
_cmd_children CommandDesc a
desc)
    [String] -> CommandDesc a -> Maybe (CommandDesc a)
forall a. [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo [String]
sr CommandDesc a
childDesc

-- | ppHelpShallow exampleDesc yields:
--
-- > NAME
-- > 
-- >   example - a simple butcher example program
-- > 
-- > USAGE
-- > 
-- >   example [--short] NAME [version | help]
-- > 
-- > DESCRIPTION
-- > 
-- >   a very long help document
-- > 
-- > ARGUMENTS
-- > 
-- >   --short             make the greeting short
-- >   NAME                your name, so you can be greeted properly
ppHelpShallow :: CommandDesc a -> PP.Doc
ppHelpShallow :: CommandDesc a -> Doc
ppHelpShallow desc :: CommandDesc a
desc =
  Doc
nameSection
    Doc -> Doc -> Doc
$+$ Doc
usageSection
    Doc -> Doc -> Doc
$+$ Doc
descriptionSection
    Doc -> Doc -> Doc
$+$ Doc
partsSection
    Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
 where
  CommandDesc mParent :: Maybe (Maybe String, CommandDesc a)
mParent syn :: Maybe Doc
syn help :: Maybe Doc
help parts :: [PartDesc]
parts _out :: Maybe a
_out _children :: Deque (Maybe String, CommandDesc a)
_children _hidden :: Visibility
_hidden = CommandDesc a
desc
  nameSection :: Doc
nameSection = case Maybe (Maybe String, CommandDesc a)
mParent of
    Nothing -> Doc
PP.empty
    Just{} ->
      String -> Doc
PP.text "NAME"
        Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
        Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest
              2
              (case Maybe Doc
syn of
                Nothing -> Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent
                Just s :: Doc
s  -> Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent Doc -> Doc -> Doc
<+> String -> Doc
PP.text "-" Doc -> Doc -> Doc
<+> Doc
s
              )
        Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
  pparents :: Maybe (Maybe String, CommandDesc out) -> Doc
pparents Nothing              = Doc
PP.empty
  pparents (Just (Just n :: String
n , cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd) Doc -> Doc -> Doc
PP.<+> String -> Doc
PP.text String
n
  pparents (Just (Nothing, cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd)
  usageSection :: Doc
usageSection = String -> Doc
PP.text "USAGE" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest 2 (CommandDesc a -> Doc
forall a. CommandDesc a -> Doc
ppUsage CommandDesc a
desc)
  descriptionSection :: Doc
descriptionSection = case Maybe Doc
help of
    Nothing -> Doc
PP.empty
    Just h :: Doc
h ->
      String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "DESCRIPTION" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest 2 Doc
h
  partsSection :: Doc
partsSection = if [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
partsTuples
    then Doc
PP.empty
    else String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "ARGUMENTS" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest
      2
      ([Doc] -> Doc
PP.vcat [Doc]
partsTuples)
  partsTuples :: [PP.Doc]
  partsTuples :: [Doc]
partsTuples = [PartDesc]
parts [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
   where
    go :: PartDesc -> [Doc]
go = \case
      PartLiteral{}      -> []
      PartVariable{}     -> []
      PartOptional p :: PartDesc
p     -> PartDesc -> [Doc]
go PartDesc
p
      PartAlts     ps :: [PartDesc]
ps    -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartSeq      ps :: [PartDesc]
ps    -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartDefault    _ p :: PartDesc
p -> PartDesc -> [Doc]
go PartDesc
p
      PartSuggestion _ p :: PartDesc
p -> PartDesc -> [Doc]
go PartDesc
p
      PartRedirect s :: String
s p :: PartDesc
p ->
        [String -> Doc
PP.text String
s Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
PP.nest 20 (Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
Maybe.fromMaybe Doc
PP.empty (Maybe Doc -> Doc) -> Maybe Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PartDesc -> Maybe Doc
ppPartDescUsage PartDesc
p)]
          [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (Int -> Doc -> Doc
PP.nest 2 (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartDesc -> [Doc]
go PartDesc
p)
      PartReorder ps :: [PartDesc]
ps     -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartMany    p :: PartDesc
p      -> PartDesc -> [Doc]
go PartDesc
p
      PartWithHelp doc :: Doc
doc p :: PartDesc
p -> [PartDesc -> Doc
ppPartDescHeader PartDesc
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
PP.nest 20 Doc
doc] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ PartDesc -> [Doc]
go PartDesc
p
      PartHidden{}       -> []

-- | ppHelpDepthOne exampleDesc yields:
--
-- > NAME
-- > 
-- >   example - a simple butcher example program
-- > 
-- > USAGE
-- > 
-- >   example [--short] NAME <command>
-- > 
-- > DESCRIPTION
-- > 
-- >   a very long help document
-- > 
-- > COMMANDS
-- > 
-- >   version
-- >   help
-- > 
-- > ARGUMENTS
-- > 
-- >   --short             make the greeting short
-- >   NAME                your name, so you can be greeted properly
ppHelpDepthOne :: CommandDesc a -> PP.Doc
ppHelpDepthOne :: CommandDesc a -> Doc
ppHelpDepthOne desc :: CommandDesc a
desc =
  Doc
nameSection
    Doc -> Doc -> Doc
$+$ Doc
usageSection
    Doc -> Doc -> Doc
$+$ Doc
descriptionSection
    Doc -> Doc -> Doc
$+$ Doc
commandSection
    Doc -> Doc -> Doc
$+$ Doc
partsSection
    Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
 where
  CommandDesc mParent :: Maybe (Maybe String, CommandDesc a)
mParent syn :: Maybe Doc
syn help :: Maybe Doc
help parts :: [PartDesc]
parts _out :: Maybe a
_out children :: Deque (Maybe String, CommandDesc a)
children _hidden :: Visibility
_hidden = CommandDesc a
desc
  nameSection :: Doc
nameSection = case Maybe (Maybe String, CommandDesc a)
mParent of
    Nothing -> Doc
PP.empty
    Just{} ->
      String -> Doc
PP.text "NAME"
        Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
        Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest
              2
              (case Maybe Doc
syn of
                Nothing -> Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent
                Just s :: Doc
s  -> Maybe (Maybe String, CommandDesc a) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents Maybe (Maybe String, CommandDesc a)
mParent Doc -> Doc -> Doc
<+> String -> Doc
PP.text "-" Doc -> Doc -> Doc
<+> Doc
s
              )
        Doc -> Doc -> Doc
$+$ String -> Doc
PP.text ""
  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
  pparents :: Maybe (Maybe String, CommandDesc out) -> Doc
pparents Nothing              = Doc
PP.empty
  pparents (Just (Just n :: String
n , cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd) Doc -> Doc -> Doc
PP.<+> String -> Doc
PP.text String
n
  pparents (Just (Nothing, cd :: CommandDesc out
cd)) = Maybe (Maybe String, CommandDesc out) -> Doc
forall out. Maybe (Maybe String, CommandDesc out) -> Doc
pparents (CommandDesc out -> Maybe (Maybe String, CommandDesc out)
forall out.
CommandDesc out -> Maybe (Maybe String, CommandDesc out)
_cmd_mParent CommandDesc out
cd)
  usageSection :: Doc
usageSection =
    String -> Doc
PP.text "USAGE" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest 2 (CommandDesc a -> Doc
forall a. CommandDesc a -> Doc
ppUsageShortSub CommandDesc a
desc)
  descriptionSection :: Doc
descriptionSection = case Maybe Doc
help of
    Nothing -> Doc
PP.empty
    Just h :: Doc
h ->
      String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "DESCRIPTION" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest 2 Doc
h
  visibleChildren :: Deque (String, CommandDesc a)
visibleChildren =
    [ (String
n, CommandDesc a
c) | (Just n :: String
n, c :: CommandDesc a
c) <- Deque (Maybe String, CommandDesc a)
children, CommandDesc a -> Visibility
forall out. CommandDesc out -> Visibility
_cmd_visibility CommandDesc a
c Visibility -> Visibility -> Bool
forall a. Eq a => a -> a -> Bool
== Visibility
Visible ]
  childDescs :: Deque Doc
childDescs = Deque (String, CommandDesc a)
visibleChildren Deque (String, CommandDesc a)
-> ((String, CommandDesc a) -> Doc) -> Deque Doc
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(n :: String
n, c :: CommandDesc a
c) ->
    String -> Doc
PP.text String
n Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
PP.nest 20 (Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
Maybe.fromMaybe Doc
PP.empty (CommandDesc a -> Maybe Doc
forall out. CommandDesc out -> Maybe Doc
_cmd_synopsis CommandDesc a
c))
  commandSection :: Doc
commandSection = if Deque (String, CommandDesc a) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Deque (String, CommandDesc a)
visibleChildren
    then Doc
PP.empty
    else String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "COMMANDS" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest
      2
      ([Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Deque Doc -> [Doc]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Deque Doc
childDescs)
  partsSection :: Doc
partsSection = if [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
partsTuples
    then Doc
PP.empty
    else String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "ARGUMENTS" Doc -> Doc -> Doc
$+$ String -> Doc
PP.text "" Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
PP.nest
      2
      ([Doc] -> Doc
PP.vcat [Doc]
partsTuples)
  partsTuples :: [PP.Doc]
  partsTuples :: [Doc]
partsTuples = [PartDesc]
parts [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
   where
    go :: PartDesc -> [Doc]
go = \case
      PartLiteral{}      -> []
      PartVariable{}     -> []
      PartOptional p :: PartDesc
p     -> PartDesc -> [Doc]
go PartDesc
p
      PartAlts     ps :: [PartDesc]
ps    -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartSeq      ps :: [PartDesc]
ps    -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartDefault    _ p :: PartDesc
p -> PartDesc -> [Doc]
go PartDesc
p
      PartSuggestion _ p :: PartDesc
p -> PartDesc -> [Doc]
go PartDesc
p
      PartRedirect s :: String
s p :: PartDesc
p ->
        [String -> Doc
PP.text String
s Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
PP.nest 20 (Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
Maybe.fromMaybe Doc
PP.empty (Maybe Doc -> Doc) -> Maybe Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PartDesc -> Maybe Doc
ppPartDescUsage PartDesc
p)]
          [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (Int -> Doc -> Doc
PP.nest 2 (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartDesc -> [Doc]
go PartDesc
p)
      PartReorder ps :: [PartDesc]
ps     -> [PartDesc]
ps [PartDesc] -> (PartDesc -> [Doc]) -> [Doc]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PartDesc -> [Doc]
go
      PartMany    p :: PartDesc
p      -> PartDesc -> [Doc]
go PartDesc
p
      PartWithHelp doc :: Doc
doc p :: PartDesc
p -> [PartDesc -> Doc
ppPartDescHeader PartDesc
p Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
PP.nest 20 Doc
doc] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ PartDesc -> [Doc]
go PartDesc
p
      PartHidden{}       -> []

-- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> Maybe PP.Doc
ppPartDescUsage :: PartDesc -> Maybe Doc
ppPartDescUsage = \case
  PartLiteral  s :: String
s -> Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
s
  PartVariable s :: String
s -> Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
s
  PartOptional p :: PartDesc
p -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartDesc -> Maybe Doc
rec PartDesc
p
  PartAlts ps :: [PartDesc]
ps ->
    [ [Doc] -> Doc
PP.fcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
PP.punctuate (String -> Doc
PP.text ",") [Doc]
ds
    | let ds :: [Doc]
ds = (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
rec [PartDesc]
ps
    , Bool -> Bool
not ([Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
ds)
    ]
  PartSeq ps :: [PartDesc]
ps -> [ [Doc] -> Doc
PP.fsep [Doc]
ds | let ds :: [Doc]
ds = (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
rec [PartDesc]
ps, Bool -> Bool
not ([Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
ds) ]
  PartDefault    _   p :: PartDesc
p -> Doc -> Doc
PP.brackets (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartDesc -> Maybe Doc
rec PartDesc
p
  PartSuggestion sgs :: [CompletionItem]
sgs p :: PartDesc
p -> PartDesc -> Maybe Doc
rec PartDesc
p Maybe Doc -> (Doc -> Doc) -> Maybe Doc
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \d :: Doc
d ->
    case [ String -> Doc
PP.text String
s | CompletionString s :: String
s <- [CompletionItem]
sgs ] of
      [] -> Doc
d
      sgsDocs :: [Doc]
sgsDocs ->
        Doc -> Doc
PP.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.fcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
PP.punctuate (String -> Doc
PP.text "|") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Doc]
sgsDocs [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
d]
  PartRedirect s :: String
s _ -> Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text String
s
  PartMany p :: PartDesc
p       -> PartDesc -> Maybe Doc
rec PartDesc
p Maybe Doc -> (Doc -> Doc) -> Maybe Doc
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Doc -> Doc -> Doc
PP.<> String -> Doc
PP.text "+")
  PartWithHelp _ p :: PartDesc
p -> PartDesc -> Maybe Doc
rec PartDesc
p
  PartReorder ps :: [PartDesc]
ps ->
    let flags :: [PartDesc]
flags  = [ PartDesc
d | PartMany d :: PartDesc
d <- [PartDesc]
ps ]
        params :: [PartDesc]
params = (PartDesc -> Bool) -> [PartDesc] -> [PartDesc]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (\case
            PartMany{} -> Bool
False
            _          -> Bool
True
          )
          [PartDesc]
ps
    in  Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.sep
          [ ([Doc] -> Doc
PP.fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
PP.brackets (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
rec [PartDesc]
flags)
          , [Doc] -> Doc
PP.fsep ((PartDesc -> Maybe Doc) -> [PartDesc] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe PartDesc -> Maybe Doc
rec [PartDesc]
params)
          ]
  PartHidden{} -> Maybe Doc
forall a. Maybe a
Nothing
  where rec :: PartDesc -> Maybe Doc
rec = PartDesc -> Maybe Doc
ppPartDescUsage

-- | Internal helper; users probably won't need this.
ppPartDescHeader :: PartDesc -> PP.Doc
ppPartDescHeader :: PartDesc -> Doc
ppPartDescHeader = \case
  PartLiteral  s :: String
s     -> String -> Doc
PP.text String
s
  PartVariable s :: String
s     -> String -> Doc
PP.text String
s
  PartOptional ds' :: PartDesc
ds'   -> PartDesc -> Doc
rec PartDesc
ds'
  PartAlts     alts :: [PartDesc]
alts  -> [Doc] -> Doc
PP.hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse (String -> Doc
PP.text ",") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ PartDesc -> Doc
rec (PartDesc -> Doc) -> [PartDesc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PartDesc]
alts
  PartDefault    _ d :: PartDesc
d -> PartDesc -> Doc
rec PartDesc
d
  PartSuggestion _ d :: PartDesc
d -> PartDesc -> Doc
rec PartDesc
d
  PartRedirect   s :: String
s _ -> String -> Doc
PP.text String
s
  PartMany ds :: PartDesc
ds        -> PartDesc -> Doc
rec PartDesc
ds
  PartWithHelp _ d :: PartDesc
d   -> PartDesc -> Doc
rec PartDesc
d
  PartSeq     ds :: [PartDesc]
ds     -> [Doc] -> Doc
PP.hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ PartDesc -> Doc
rec (PartDesc -> Doc) -> [PartDesc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PartDesc]
ds
  PartReorder ds :: [PartDesc]
ds     -> [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ PartDesc -> Doc
rec (PartDesc -> Doc) -> [PartDesc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PartDesc]
ds
  PartHidden  d :: PartDesc
d      -> PartDesc -> Doc
rec PartDesc
d
  where rec :: PartDesc -> Doc
rec = PartDesc -> Doc
ppPartDescHeader

-- | Simple conversion from 'ParsingError' to 'String'.
parsingErrorString :: ParsingError -> String
parsingErrorString :: ParsingError -> String
parsingErrorString (ParsingError mess :: [String]
mess remaining :: Input
remaining) =
  "error parsing arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
messStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remainingStr
 where
  messStr :: String
messStr = case [String]
mess of
    []      -> ""
    (m :: String
m : _) -> String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
  remainingStr :: String
remainingStr = case Input
remaining of
    InputString ""  -> "at the end of input."
    InputString str :: String
str -> case String -> String
forall a. Show a => a -> String
show String
str of
      s :: String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
      s :: String
s                 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."
    InputArgs [] -> "at the end of input"
    InputArgs xs :: [String]
xs -> case [String] -> String
List.unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs of
      s :: String
s | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 42 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
      s :: String
s                 -> "at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
take 40 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..\"."