{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Usage
( usageInfo
, formatOptions
, getCommandHelp
, getCommandMiniHelp
, usage
, subusage
) where
import Prelude ()
import Darcs.Prelude
import Data.Functor.Compose
import System.Console.GetOpt( OptDescr(..), ArgDescr(..) )
import Darcs.UI.Options.All ( stdCmdActions )
import Darcs.UI.Commands
( CommandControl(..)
, DarcsCommand(..)
, wrappedCommandName
, wrappedCommandDescription
, getSubcommands
, commandAlloptions
)
import Darcs.UI.Options ( DarcsOptDescr, odesc )
import Darcs.Util.Printer
( Doc, text, vsep, ($$), vcat, hsep
, renderString
)
formatOptions :: [DarcsOptDescr a] -> [String]
formatOptions :: [DarcsOptDescr a] -> [String]
formatOptions optDescrs :: [DarcsOptDescr a]
optDescrs = [String]
table
where (ss :: [String]
ss,ls :: [[String]]
ls,ds :: [String]
ds) = ([(String, [String], String)] -> ([String], [[String]], [String])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(String, [String], String)] -> ([String], [[String]], [String]))
-> ([DarcsOptDescr a] -> [(String, [String], String)])
-> [DarcsOptDescr a]
-> ([String], [[String]], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DarcsOptDescr a -> [(String, [String], String)])
-> [DarcsOptDescr a] -> [(String, [String], String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DarcsOptDescr a -> [(String, [String], String)]
forall a. DarcsOptDescr a -> [(String, [String], String)]
fmtOpt) [DarcsOptDescr a]
optDescrs
table :: [String]
table = (String -> String -> String -> String)
-> [String] -> [String] -> [String] -> [String]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 String -> String -> String -> String
paste
[String]
shortPadded
((String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unlines' ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
init) [[String]]
ls)
([String] -> [String]
sameLen ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
forall a. [a] -> a
last [[String]]
ls))
[String]
ds
shortPadded :: [String]
shortPadded = [String] -> [String]
sameLen [String]
ss
prePad :: String
prePad = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> String
forall a. [a] -> a
head [String]
shortPadded)) ' '
unlines' :: [String] -> String
unlines' = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\x :: String
x -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ",\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prePad)
paste :: String -> String -> String -> String
paste x :: String
x y :: String
y z :: String
z = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
z
sameLen :: [String] -> [String]
sameLen xs :: [String]
xs = Int -> [String] -> [String]
flushLeft (([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([String] -> [Int]) -> [String] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [String]
xs) [String]
xs
flushLeft :: Int -> [String] -> [String]
flushLeft n :: Int
n xs :: [String]
xs = [ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat ' ') | String
x <- [String]
xs ]
usageInfo :: String
-> [DarcsOptDescr a]
-> String
usageInfo :: String -> [DarcsOptDescr a] -> String
usageInfo header :: String
header optDescrs :: [DarcsOptDescr a]
optDescrs = [String] -> String
unlines (String
headerString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[DarcsOptDescr a] -> [String]
forall a. [DarcsOptDescr a] -> [String]
formatOptions [DarcsOptDescr a]
optDescrs)
fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]
fmtOpt :: DarcsOptDescr a -> [(String, [String], String)]
fmtOpt (Compose (Option sos :: String
sos los :: [String]
los ad :: ArgDescr (AbsolutePath -> a)
ad descr :: String
descr)) =
case String -> [String]
lines String
descr of
[] -> [(String
sosFmt,[String]
losFmt,"")]
(d :: String
d:ds :: [String]
ds) -> (String
sosFmt,[String]
losFmt,String
d) (String, [String], String)
-> [(String, [String], String)] -> [(String, [String], String)]
forall a. a -> [a] -> [a]
: [ ("",[],String
d') | String
d' <- [String]
ds ]
where endBy :: Char -> [String] -> String
endBy _ [] = ""
endBy ch :: Char
ch [x :: String
x] = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
ch]
endBy ch :: Char
ch (x :: String
x:xs :: [String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> [String] -> String
endBy Char
ch [String]
xs
sosFmt :: String
sosFmt = Char -> [String] -> String
endBy ',' ((Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
fmtShort String
sos)
losFmt :: [String]
losFmt = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr (AbsolutePath -> a) -> String -> String
forall a. ArgDescr a -> String -> String
fmtLong ArgDescr (AbsolutePath -> a)
ad) [String]
los
fmtShort :: Char -> String
fmtShort :: Char -> String
fmtShort so :: Char
so = "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtLong :: ArgDescr a -> String -> String
fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg _ ) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg _ ad :: String
ad) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg _ ad :: String
ad) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ "[=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
usage :: [CommandControl] -> Doc
usage :: [CommandControl] -> Doc
usage cs :: [CommandControl]
cs = [Doc] -> Doc
vsep
[ "Usage: darcs COMMAND ..."
, "Commands:" Doc -> Doc -> Doc
$$ [CommandControl] -> Doc
usageHelper [CommandControl]
cs
, [Doc] -> Doc
vcat
[ "Use 'darcs COMMAND --help' for help on a single command."
, "Use 'darcs --version' to see the darcs version number."
, "Use 'darcs --exact-version' to see a detailed darcs version."
, "Use 'darcs help patterns' for help on patch matching."
, "Use 'darcs help environment' for help on environment variables."
, "Use 'darcs help manpage' to display help in the manpage format."
, "Use 'darcs help markdown' to display help in the markdown format."
]
, "Check bug reports at http://bugs.darcs.net/"
]
subusage :: DarcsCommand pf -> String
subusage :: DarcsCommand pf -> String
subusage super :: DarcsCommand pf
super = Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep
[ Doc
header
, Doc
subcommandsHelp
, [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [DarcsOptDescr Flag] -> [String]
forall a. [DarcsOptDescr a] -> [String]
formatOptions ([DarcsOptDescr Flag] -> [String])
-> [DarcsOptDescr Flag] -> [String]
forall a b. (a -> b) -> a -> b
$ OptSpec DarcsOptDescr Flag Any (Maybe StdCmdAction -> Any)
-> [DarcsOptDescr Flag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr Flag Any (Maybe StdCmdAction -> Any)
PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions
, String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandHelp DarcsCommand pf
super
]
where
usageHelp :: Doc
usageHelp = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[ "Usage:"
, DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf
super
, DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf
super
, "SUBCOMMAND ..."
]
header :: Doc
header = Doc
usageHelp Doc -> Doc -> Doc
$$ String -> Doc
text (DarcsCommand pf -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandDescription DarcsCommand pf
super)
subcommandsHelp :: Doc
subcommandsHelp = case DarcsCommand pf -> [CommandControl]
forall pf. DarcsCommand pf -> [CommandControl]
getSubcommands DarcsCommand pf
super of
[] -> Doc
forall a. Monoid a => a
mempty
subcommands :: [CommandControl]
subcommands -> [CommandControl] -> Doc
usageHelper [CommandControl]
subcommands
usageHelper :: [CommandControl] -> Doc
usageHelper :: [CommandControl] -> Doc
usageHelper xs :: [CommandControl]
xs = [Doc] -> Doc
vsep ([CommandControl] -> [Doc]
groups [CommandControl]
xs)
where
groups :: [CommandControl] -> [Doc]
groups [] = []
groups (HiddenCommand _:cs :: [CommandControl]
cs) = [CommandControl] -> [Doc]
groups [CommandControl]
cs
groups (GroupName n :: String
n:cs :: [CommandControl]
cs) =
Doc
forall a. Monoid a => a
mempty Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: case [CommandControl] -> [Doc]
groups [CommandControl]
cs of
[] -> [String -> Doc
text String
n]
(g :: Doc
g:gs :: [Doc]
gs) -> (String -> Doc
text String
n Doc -> Doc -> Doc
$$ Doc
g) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
gs
groups (CommandData c :: WrappedCommand
c:cs :: [CommandControl]
cs) =
case [CommandControl] -> [Doc]
groups [CommandControl]
cs of
[] -> [WrappedCommand -> Doc
cmdHelp WrappedCommand
c]
(g :: Doc
g:gs :: [Doc]
gs) -> (WrappedCommand -> Doc
cmdHelp WrappedCommand
c Doc -> Doc -> Doc
$$ Doc
g) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
gs
cmdHelp :: WrappedCommand -> Doc
cmdHelp c :: WrappedCommand
c = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Int -> String -> String
padSpaces Int
maxwidth (WrappedCommand -> String
wrappedCommandName WrappedCommand
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++
WrappedCommand -> String
wrappedCommandDescription WrappedCommand
c
padSpaces :: Int -> String -> String
padSpaces n :: Int
n s :: String
s = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) ' '
maxwidth :: Int
maxwidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ 15 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((CommandControl -> Int) -> [CommandControl] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CommandControl -> Int
cwidth [CommandControl]
xs)
cwidth :: CommandControl -> Int
cwidth (CommandData c :: WrappedCommand
c) = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (WrappedCommand -> String
wrappedCommandName WrappedCommand
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
cwidth _ = 0
getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
getCommandMiniHelp msuper :: Maybe (DarcsCommand pf1)
msuper cmd :: DarcsCommand pf2
cmd = Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep
[ Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
forall pf1 pf2. Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelpCore Maybe (DarcsCommand pf1)
msuper DarcsCommand pf2
cmd
, [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
[ "See"
, DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf2
cmd
, "help"
, String
-> (DarcsCommand pf1 -> String)
-> Maybe (DarcsCommand pf1)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ") (String -> String)
-> (DarcsCommand pf1 -> String) -> DarcsCommand pf1 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand pf1 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName) Maybe (DarcsCommand pf1)
msuper String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf2
cmd
, "for details."
]
]
getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelp msuper :: Maybe (DarcsCommand pf1)
msuper cmd :: DarcsCommand pf2
cmd = [Doc] -> Doc
vsep
[ Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
forall pf1 pf2. Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelpCore Maybe (DarcsCommand pf1)
msuper DarcsCommand pf2
cmd
, Doc
subcommandsHelp
, String -> [String] -> Doc
withHeading "Options:" [String]
basicOptionsHelp
, String -> [String] -> Doc
withHeading "Advanced options:" [String]
advancedOptionsHelp
, String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandHelp DarcsCommand pf2
cmd
]
where
withHeading :: String -> [String] -> Doc
withHeading _ [] = Doc
forall a. Monoid a => a
mempty
withHeading h :: String
h ls :: [String]
ls = [Doc] -> Doc
vcat (String -> Doc
text String
h Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
ls)
(basic :: [DarcsOptDescr Flag]
basic, advanced :: [DarcsOptDescr Flag]
advanced) = DarcsCommand pf2 -> ([DarcsOptDescr Flag], [DarcsOptDescr Flag])
forall pf.
DarcsCommand pf -> ([DarcsOptDescr Flag], [DarcsOptDescr Flag])
commandAlloptions DarcsCommand pf2
cmd
(basicOptionsHelp :: [String]
basicOptionsHelp, advancedOptionsHelp :: [String]
advancedOptionsHelp) =
Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt ([DarcsOptDescr Flag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DarcsOptDescr Flag]
basic) ([String] -> ([String], [String]))
-> [String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ [DarcsOptDescr Flag] -> [String]
forall a. [DarcsOptDescr a] -> [String]
formatOptions ([DarcsOptDescr Flag]
basic [DarcsOptDescr Flag]
-> [DarcsOptDescr Flag] -> [DarcsOptDescr Flag]
forall a. [a] -> [a] -> [a]
++ [DarcsOptDescr Flag]
advanced)
subcommandsHelp :: Doc
subcommandsHelp =
case Maybe (DarcsCommand pf1)
msuper of
Nothing ->
case DarcsCommand pf2 -> [CommandControl]
forall pf. DarcsCommand pf -> [CommandControl]
getSubcommands DarcsCommand pf2
cmd of
[] -> Doc
forall a. Monoid a => a
mempty
subcommands :: [CommandControl]
subcommands -> [CommandControl] -> Doc
usageHelper [CommandControl]
subcommands
Just _ -> Doc
forall a. Monoid a => a
mempty
getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelpCore msuper :: Maybe (DarcsCommand pf1)
msuper cmd :: DarcsCommand pf2
cmd = [Doc] -> Doc
vcat
[ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
[ "Usage:"
, String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandProgramName DarcsCommand pf2
cmd
, Doc -> (DarcsCommand pf1 -> Doc) -> Maybe (DarcsCommand pf1) -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty (String -> Doc
text (String -> Doc)
-> (DarcsCommand pf1 -> String) -> DarcsCommand pf1 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand pf1 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName) Maybe (DarcsCommand pf1)
msuper
, String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandName DarcsCommand pf2
cmd
, "[OPTION]..."
]
[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc]
args_help
, String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf2 -> String
forall parsedFlags. DarcsCommand parsedFlags -> String
commandDescription DarcsCommand pf2
cmd
]
where
args_help :: [Doc]
args_help = case DarcsCommand pf2
cmd of
(DarcsCommand {}) -> (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ DarcsCommand pf2 -> [String]
forall parsedFlags. DarcsCommand parsedFlags -> [String]
commandExtraArgHelp DarcsCommand pf2
cmd
_ -> []