1{-# OPTIONS_GHC -fno-warn-orphans #-} -- Not good reasons, but shouldn't be too fatal
2{-
3Sample renderings:
4
5-- ONE MODE
6Program description
7
8programname [OPTIONS] FILE1 FILE2 [FILES]
9  Program to perform some action
10
11  -f --flag     description
12Flag grouping:
13  -a --another  description
14
15
16-- MANY MODES WITH ONE SHOWN
17Program description
18
19programname [COMMAND] [OPTIONS] ...
20  Program to perform some action
21
22Commands:
23  [build]  Build action here
24  test     Test action here
25
26Flags:
27  -s --special  Special for the root only
28Common flags:
29  -? --help     Build action here
30
31
32-- MANY MODES WITH ALL SHOWN
33Program description
34
35programname [COMMAND] [OPTIONS] ...
36  Program to perform some action
37
38  -s --special  Special for the root only
39Common flags:
40  -? --help     Build action here
41
42programname [build] [OPTIONS] [FILES}
43  Action to perform here
44-}
45
46module System.Console.CmdArgs.Explicit.Help(HelpFormat(..), helpText) where
47
48import System.Console.CmdArgs.Explicit.Type
49import System.Console.CmdArgs.Explicit.Complete
50import System.Console.CmdArgs.Text
51import System.Console.CmdArgs.Default
52import Data.List
53import Data.Maybe
54
55
56-- | Specify the format to output the help.
57data HelpFormat
58    = HelpFormatDefault -- ^ Equivalent to 'HelpFormatAll' if there is not too much text, otherwise 'HelpFormatOne'.
59    | HelpFormatOne -- ^ Display only the first mode.
60    | HelpFormatAll -- ^ Display all modes.
61    | HelpFormatBash -- ^ Bash completion information
62    | HelpFormatZsh -- ^ Z shell completion information
63      deriving (Read,Show,Enum,Bounded,Eq,Ord)
64
65instance Default HelpFormat where def = HelpFormatDefault
66
67
68instance Show (Mode a) where
69    show = show . helpTextDefault
70
71instance Show (Flag a) where
72    show = show . helpFlag
73
74instance Show (Arg a) where
75    show = show . argType
76
77-- | Generate a help message from a mode.  The first argument is a prefix,
78--   which is prepended when not using 'HelpFormatBash' or 'HelpFormatZsh'.
79helpText :: [String] -> HelpFormat -> Mode a -> [Text]
80helpText pre HelpFormatDefault x = helpPrefix pre ++ helpTextDefault x
81helpText pre HelpFormatOne x = helpPrefix pre ++ helpTextOne x
82helpText pre HelpFormatAll x = helpPrefix pre ++ helpTextAll x
83helpText pre HelpFormatBash x = map Line $ completeBash $ head $ modeNames x ++ ["unknown"]
84helpText pre HelpFormatZsh x = map Line $ completeZsh $ head $ modeNames x ++ ["unknown"]
85
86
87helpPrefix :: [String] -> [Text]
88helpPrefix xs = map Line xs ++ [Line "" | not $ null xs]
89
90
91helpTextDefault x = if length all > 40 then one else all
92    where all = helpTextAll x
93          one = helpTextOne x
94
95
96-- | Help text for all modes
97--
98-- > <program> [OPTIONS] <file_args>
99-- > <options>
100-- > <program> MODE [SUBMODE] [OPTIONS] [FLAG]
101helpTextAll :: Mode a -> [Text]
102helpTextAll = disp . push ""
103    where
104        disp m = uncurry (++) (helpTextMode m) ++ concatMap (\x -> Line "" : disp x) (modeModes m)
105        push s m = m{modeNames = map (s++) $ modeNames m
106                    ,modeGroupModes = fmap (push s2) $ modeGroupModes m}
107            where s2 = s ++ concat (take 1 $ modeNames m) ++ " "
108
109
110-- | Help text for only this mode
111--
112-- > <program> [OPTIONS] <file_args>
113-- > <options>
114-- > <program> MODE [FLAGS]
115-- > <options>
116helpTextOne :: Mode a -> [Text]
117helpTextOne m = pre ++ ms ++ suf
118    where
119        (pre,suf) = helpTextMode m
120        ms = space $ [Line "Commands:" | not $ null $ groupUnnamed $ modeGroupModes m] ++ helpGroup f (modeGroupModes m)
121        f m = return $ cols [concat $ take 1 $ modeNames m, ' ' : modeHelp m]
122
123
124helpTextMode :: Mode a -> ([Text], [Text])
125helpTextMode x@Mode{modeGroupFlags=flags,modeGroupModes=modes} = (pre,suf)
126    where
127        pre = [Line $ unwords $ take 1 (modeNames x) ++
128                  ["[COMMAND] ..." | notNullGroup modes] ++
129                  ["[OPTIONS]" | not $ null $ fromGroup flags] ++
130                  helpArgs (modeArgs x)] ++
131              [Line $ "  " ++ modeHelp x | not $ null $ modeHelp x]
132        suf = space
133                  ([Line "Flags:" | mixedGroup flags] ++
134                   helpGroup helpFlag (modeGroupFlags x)) ++
135              space (map Line $ modeHelpSuffix x)
136
137
138helpGroup :: (a -> [Text]) -> Group a -> [Text]
139helpGroup f xs = concatMap f (groupUnnamed xs) ++ concatMap g (groupNamed xs)
140    where g (a,b) = Line (a ++ ":") : concatMap f b
141
142
143helpArgs :: ([Arg a], Maybe (Arg a)) -> [String]
144helpArgs (ys,y) = [['['|o] ++ argType x ++ [']'|o] | (i,x) <- zip [0..] xs, let o = False && req <= i]
145    where xs = ys ++ maybeToList y
146          req = maximum $ 0 : [i | (i,x) <- zip [1..] xs, argRequire x]
147
148
149helpFlag :: Flag a -> [Text]
150helpFlag x = [cols [unwords $ map ("-"++) a2, unwords $ map ("--"++) b2, ' ' : flagHelp x]]
151        where
152            (a,b) = partition ((==) 1 . length) $ flagNames x
153            (a2,b2) = if null b then (add a opt, b) else (a, add b opt)
154            add x y = if null x then x else (head x ++ y) : tail x
155            hlp = if null (flagType x) then "ITEM" else flagType x
156            opt = case flagInfo x of
157                FlagReq -> '=' : hlp
158                FlagOpt x -> "[=" ++ hlp ++ "]"
159                _ -> ""
160
161cols (x:xs) = Cols $ ("  "++x) : map (' ':) xs
162space xs = [Line "" | not $ null xs] ++ xs
163
164
165nullGroup x = null (groupUnnamed x) && null (groupNamed x)
166notNullGroup = not . nullGroup
167mixedGroup x = not $ null (groupUnnamed x) || null (groupNamed x) -- has both unnamed and named
168