{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Usage
    ( getCommandHelp
    , getSuperCommandHelp
    , getCommandMiniHelp
    , usage
    , subusage
    ) where

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(..)
    , commandName
    , commandDescription
    , 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 [DarcsOptDescr a]
optDescrs = [String]
table
   where ([String]
ss,[[String]]
ls,[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 (Int
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)) Char
' '
         -- Similar to unlines (additional ',' and padding):
         unlines' :: [String] -> String
unlines'       = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prePad)
         -- Unchanged:
         paste :: String -> String -> String -> String
paste String
x String
y String
z    = String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
z
         sameLen :: [String] -> [String]
sameLen [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 Int
n [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 Char
' ') | String
x <- [String]
xs ]

-- Mild variant of the standard definition: 'losFmt' is a list rather than a
-- comma separated string.
fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]
fmtOpt :: DarcsOptDescr a -> [(String, [String], String)]
fmtOpt (Compose (Option String
sos [String]
los ArgDescr (AbsolutePath -> a)
ad String
descr)) =
   case String -> [String]
lines String
descr of
     []     -> [(String
sosFmt,[String]
losFmt,String
"")]
     (String
d:[String]
ds) ->  (String
sosFmt,[String]
losFmt,String
d) (String, [String], String)
-> [(String, [String], String)] -> [(String, [String], String)]
forall a. a -> [a] -> [a]
: [ (String
"",[],String
d') | String
d' <- [String]
ds ]
   where endBy :: Char -> [String] -> String
endBy Char
_  []     = String
""
         endBy Char
ch [String
x]    = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
ch]
         endBy Char
ch (String
x:[String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> [String] -> String
endBy Char
ch [String]
xs
         sosFmt :: String
sosFmt = Char -> [String] -> String
endBy Char
',' ((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

--------------------------------------------------------------------------------
-- Verbatim copies: these definitions aren't exported by System.Console.GetOpt
--------------------------------------------------------------------------------

fmtShort :: Char -> String
fmtShort :: Char -> String
fmtShort Char
so = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so]

fmtLong :: ArgDescr a -> String -> String
fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg  a
_   ) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg String -> a
_ String
ad) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg Maybe String -> a
_ String
ad) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
--------------------------------------------------------------------------------

usage :: [CommandControl] -> Doc
usage :: [CommandControl] -> Doc
usage [CommandControl]
cs = [Doc] -> Doc
vsep 
    [ Doc
"Usage: darcs COMMAND ..."
    , Doc
"Commands:" Doc -> Doc -> Doc
$$ [CommandControl] -> Doc
usageHelper [CommandControl]
cs
    , [Doc] -> Doc
vcat
      [ Doc
"Use 'darcs help COMMAND' or 'darcs COMMAND --help' for help on a single command."
      , Doc
"Use 'darcs help patterns' for help on patch matching."
      , Doc
"Use 'darcs help environment' for help on environment variables."
      , Doc
"Use 'darcs help manpage' to display help in the manpage format."
      , Doc
"Use 'darcs help markdown' to display help in the markdown format."
      , Doc
"Use 'darcs --version' to see the darcs version number."
      , Doc
"Use 'darcs --exact-version' to see a detailed darcs version."
      ]
    , Doc
"Check bug reports at http://bugs.darcs.net/"
    ]

subusage :: DarcsCommand -> Doc
subusage :: DarcsCommand -> Doc
subusage DarcsCommand
super = [Doc] -> Doc
vsep
    [ DarcsCommand -> Doc
superUsage DarcsCommand
super Doc -> Doc -> Doc
$$ String -> Doc
text (DarcsCommand -> String
commandDescription DarcsCommand
super)
    , [CommandControl] -> Doc
usageHelper (DarcsCommand -> [CommandControl]
getSubcommands DarcsCommand
super)
    , Doc
"Options:"
    , [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
    , DarcsCommand -> Doc
commandHelp DarcsCommand
super
    ]

superUsage :: DarcsCommand -> Doc
superUsage :: DarcsCommand -> Doc
superUsage DarcsCommand
super = [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
    [ String
"Usage:"
    , DarcsCommand -> String
commandProgramName DarcsCommand
super
    , DarcsCommand -> String
commandName DarcsCommand
super
    , String
"SUBCOMMAND [OPTION]..."
    ]

usageHelper :: [CommandControl] -> Doc
usageHelper :: [CommandControl] -> Doc
usageHelper [CommandControl]
xs = [Doc] -> Doc
vsep ([CommandControl] -> [Doc]
groups [CommandControl]
xs)
  where
    groups :: [CommandControl] -> [Doc]
groups [] = []
    groups (HiddenCommand DarcsCommand
_:[CommandControl]
cs) = [CommandControl] -> [Doc]
groups [CommandControl]
cs
    groups (GroupName String
n:[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]
        (Doc
g:[Doc]
gs) -> (String -> Doc
text String
n Doc -> Doc -> Doc
$$ Doc
g) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
gs
    groups (CommandData DarcsCommand
c:[CommandControl]
cs) =
      case [CommandControl] -> [Doc]
groups [CommandControl]
cs of
        [] -> [DarcsCommand -> Doc
cmdHelp DarcsCommand
c]
        (Doc
g:[Doc]
gs) -> (DarcsCommand -> Doc
cmdHelp DarcsCommand
c Doc -> Doc -> Doc
$$ Doc
g) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
gs

    cmdHelp :: DarcsCommand -> Doc
cmdHelp DarcsCommand
c = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      Int -> String -> String
padSpaces Int
maxwidth (DarcsCommand -> String
commandName DarcsCommand
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++
      DarcsCommand -> String
commandDescription DarcsCommand
c

    padSpaces :: Int -> String -> String
padSpaces Int
n 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) Char
' '

    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
$ Int
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 DarcsCommand
c) = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DarcsCommand -> String
commandName DarcsCommand
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
    cwidth CommandControl
_               = Int
0

getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String
getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String
getCommandMiniHelp Maybe DarcsCommand
msuper DarcsCommand
cmd = Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep
    [ Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelpCore Maybe DarcsCommand
msuper DarcsCommand
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
        [ String
"See"
        , DarcsCommand -> String
commandProgramName DarcsCommand
cmd
        , String
"help"
        , String -> (DarcsCommand -> String) -> Maybe DarcsCommand -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") (String -> String)
-> (DarcsCommand -> String) -> DarcsCommand -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand -> String
commandName) Maybe DarcsCommand
msuper String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand -> String
commandName DarcsCommand
cmd
        , String
"for details."
        ]
    ]

getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelp Maybe DarcsCommand
msuper DarcsCommand
cmd = [Doc] -> Doc
vsep
    [ Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelpCore Maybe DarcsCommand
msuper DarcsCommand
cmd
    , Doc
subcommandsHelp
    , String -> [String] -> Doc
withHeading String
"Options:" [String]
basicOptionsHelp
    , String -> [String] -> Doc
withHeading String
"Advanced options:" [String]
advancedOptionsHelp
    , DarcsCommand -> Doc
commandHelp DarcsCommand
cmd
    ]
  where
    withHeading :: String -> [String] -> Doc
withHeading String
_ [] = Doc
forall a. Monoid a => a
mempty
    withHeading String
h [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)

    ([DarcsOptDescr Flag]
basic, [DarcsOptDescr Flag]
advanced) = DarcsCommand -> ([DarcsOptDescr Flag], [DarcsOptDescr Flag])
commandAlloptions DarcsCommand
cmd
    -- call formatOptions with combined options so that
    -- both get the same formatting
    ([String]
basicOptionsHelp, [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
msuper of
        Maybe DarcsCommand
Nothing -> [CommandControl] -> Doc
usageHelper (DarcsCommand -> [CommandControl]
getSubcommands DarcsCommand
cmd)
        -- we don't want to list subcommands if we're already specifying them
        Just DarcsCommand
_ -> Doc
forall a. Monoid a => a
mempty

getSuperCommandHelp :: DarcsCommand -> Doc
getSuperCommandHelp :: DarcsCommand -> Doc
getSuperCommandHelp DarcsCommand
super =
  [Doc] -> Doc
vsep [DarcsCommand -> Doc
superUsage DarcsCommand
super, [CommandControl] -> Doc
usageHelper (DarcsCommand -> [CommandControl]
getSubcommands DarcsCommand
super), DarcsCommand -> Doc
commandHelp DarcsCommand
super]

getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelpCore Maybe DarcsCommand
msuper DarcsCommand
cmd = [Doc] -> Doc
vcat
    [ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
        [ Doc
"Usage:"
        , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand -> String
commandProgramName DarcsCommand
cmd
        , Doc -> (DarcsCommand -> Doc) -> Maybe DarcsCommand -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty (String -> Doc
text (String -> Doc) -> (DarcsCommand -> String) -> DarcsCommand -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand -> String
commandName) Maybe DarcsCommand
msuper
        , String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ DarcsCommand -> String
commandName DarcsCommand
cmd
        , Doc
"[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 -> String
commandDescription DarcsCommand
cmd
    ]
  where
    args_help :: [Doc]
args_help = case DarcsCommand
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 -> [String]
commandExtraArgHelp DarcsCommand
cmd
                    DarcsCommand
_ -> []