{-# 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 :: forall a. [DarcsOptDescr a] -> [String]
formatOptions [DarcsOptDescr a]
optDescrs = [String]
table
   where ([String]
ss,[[String]]
ls,[String]
ds)     = (forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. DarcsOptDescr a -> [(String, [String], String)]
fmtOpt) [DarcsOptDescr a]
optDescrs
         table :: [String]
table          = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 String -> String -> String -> String
paste
                            [String]
shortPadded
                            (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unlines' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init) [[String]]
ls)
                                          ([String] -> [String]
sameLen forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
last [[String]]
ls))
                            [String]
ds
         shortPadded :: [String]
shortPadded    = [String] -> [String]
sameLen [String]
ss
         prePad :: String
prePad         = forall a. Int -> a -> [a]
replicate (Int
3 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. [a] -> a
head [String]
shortPadded)) Char
' '
         -- Similar to unlines (additional ',' and padding):
         unlines' :: [String] -> String
unlines'       = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> String
x forall a. [a] -> [a] -> [a]
++ String
",\n" forall a. [a] -> [a] -> [a]
++ String
prePad)
         -- Unchanged:
         paste :: String -> String -> String -> String
paste String
x String
y String
z    = String
"  " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
y forall a. [a] -> [a] -> [a]
++ String
"  " forall a. [a] -> [a] -> [a]
++ String
z
         sameLen :: [String] -> [String]
sameLen [String]
xs     = Int -> [String] -> [String]
flushLeft ((forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length) [String]
xs) [String]
xs
         flushLeft :: Int -> [String] -> [String]
flushLeft Int
n [String]
xs = [ forall a. Int -> [a] -> [a]
take Int
n (String
x forall a. [a] -> [a] -> [a]
++ 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 :: forall a. 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) 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 forall a. [a] -> [a] -> [a]
++ [Char
ch]
         endBy Char
ch (String
x:[String]
xs) = String
x forall a. [a] -> [a] -> [a]
++ Char
chforall a. a -> [a] -> [a]
:Char
' 'forall a. a -> [a] -> [a]
:Char -> [String] -> String
endBy Char
ch [String]
xs
         sosFmt :: String
sosFmt = Char -> [String] -> String
endBy Char
',' (forall a b. (a -> b) -> [a] -> [b]
map Char -> String
fmtShort String
sos)
         losFmt :: [String]
losFmt = forall a b. (a -> b) -> [a] -> [b]
map (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
"-" forall a. [a] -> [a] -> [a]
++ [Char
so]

fmtLong :: ArgDescr a -> String -> String
fmtLong :: forall a. ArgDescr a -> String -> String
fmtLong (NoArg  a
_   ) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg String -> a
_ String
ad) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg Maybe String -> a
_ String
ad) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo forall a. [a] -> [a] -> [a]
++ String
"[=" forall a. [a] -> [a] -> [a]
++ String
ad 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text forall a b. (a -> b) -> a -> b
$ forall a. [DarcsOptDescr a] -> [String]
formatOptions forall a b. (a -> b) -> a -> b
$ forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc PrimDarcsOption (Maybe StdCmdAction)
stdCmdActions
    , DarcsCommand -> Doc
commandHelp DarcsCommand
super
    ]

superUsage :: DarcsCommand -> Doc
superUsage :: DarcsCommand -> Doc
superUsage DarcsCommand
super = [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ 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) =
      forall a. Monoid a => a
mempty 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) 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) forall a. a -> [a] -> [a]
: [Doc]
gs

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

    padSpaces :: Int -> String -> String
padSpaces Int
n String
s = String
s forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
n forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' '

    maxwidth :: Int
maxwidth = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Int
15 forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map CommandControl -> Int
cwidth [CommandControl]
xs)

    cwidth :: CommandControl -> Int
cwidth (CommandData DarcsCommand
c) = forall (t :: * -> *) a. Foldable t => t a -> Int
length (DarcsCommand -> String
commandName DarcsCommand
c) 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 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vsep
    [ Maybe DarcsCommand -> DarcsCommand -> Doc
getCommandHelpCore Maybe DarcsCommand
msuper DarcsCommand
cmd
    , [Doc] -> Doc
hsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
        [ String
"See"
        , DarcsCommand -> String
commandProgramName DarcsCommand
cmd
        , String
"help"
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((forall a. [a] -> [a] -> [a]
++ String
" ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand -> String
commandName) Maybe DarcsCommand
msuper 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
_ [] = forall a. Monoid a => a
mempty
    withHeading String
h [String]
ls = [Doc] -> Doc
vcat (String -> Doc
text String
h forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
ls)

    ([DarcsOptDescr DarcsFlag]
basic, [DarcsOptDescr DarcsFlag]
advanced) = DarcsCommand
-> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand
cmd
    -- call formatOptions with combined options so that
    -- both get the same formatting
    ([String]
basicOptionsHelp, [String]
advancedOptionsHelp) =
        forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DarcsOptDescr DarcsFlag]
basic) forall a b. (a -> b) -> a -> b
$ forall a. [DarcsOptDescr a] -> [String]
formatOptions ([DarcsOptDescr DarcsFlag]
basic forall a. [a] -> [a] -> [a]
++ [DarcsOptDescr DarcsFlag]
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
_ -> 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 forall a b. (a -> b) -> a -> b
$
        [ Doc
"Usage:"
        , String -> Doc
text forall a b. (a -> b) -> a -> b
$ DarcsCommand -> String
commandProgramName DarcsCommand
cmd
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. DarcsCommand -> String
commandName) Maybe DarcsCommand
msuper
        , String -> Doc
text forall a b. (a -> b) -> a -> b
$ DarcsCommand -> String
commandName DarcsCommand
cmd
        , Doc
"[OPTION]..."
        ]
        forall a. [a] -> [a] -> [a]
++ [Doc]
args_help
    , String -> Doc
text forall a b. (a -> b) -> a -> b
$ DarcsCommand -> String
commandDescription DarcsCommand
cmd
    ]
  where
    args_help :: [Doc]
args_help = case DarcsCommand
cmd of
                    (DarcsCommand {}) -> forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text forall a b. (a -> b) -> a -> b
$ DarcsCommand -> [String]
commandExtraArgHelp DarcsCommand
cmd
                    DarcsCommand
_ -> []