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