module Options.Help
( addHelpFlags
, checkHelpFlag
, helpFor
, HelpFlag(..)
) where
import Control.Monad.Writer
import Data.List (intercalate, partition, stripPrefix)
import Data.Maybe (isNothing, listToMaybe, maybeToList)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Language.Haskell.TH (location, loc_package, loc_module)
import Options.Types
data HelpFlag = HelpSummary | HelpAll | HelpGroup String
deriving (Eq, Show)
addHelpFlags :: OptionDefinitions a -> OptionDefinitions a
addHelpFlags (OptionDefinitions opts subcmds) = OptionDefinitions withHelp subcmdsWithHelp where
shortFlags = Set.fromList $ do
opt <- opts
optionInfoShortFlags opt
longFlags = Set.fromList $ do
opt <- opts
optionInfoLongFlags opt
withHelp = optHelpSummary ++ optsGroupHelp ++ opts
groupHelp = GroupInfo
{ groupInfoName = "all"
, groupInfoTitle = "Help Options"
, groupInfoDescription = "Show all help options."
}
optSummary = OptionInfo
{ optionInfoKey = keyFor "optHelpSummary"
, optionInfoShortFlags = []
, optionInfoLongFlags = []
, optionInfoDefault = "false"
, optionInfoUnary = True
, optionInfoDescription = "Show option summary."
, optionInfoGroup = Just groupHelp
}
optGroupHelp group flag = OptionInfo
{ optionInfoKey = keyFor "optHelpGroup" ++ ":" ++ groupInfoName group
, optionInfoShortFlags = []
, optionInfoLongFlags = [flag]
, optionInfoDefault = "false"
, optionInfoUnary = True
, optionInfoDescription = groupInfoDescription group
, optionInfoGroup = Just groupHelp
}
optHelpSummary = if Set.member 'h' shortFlags
then if Set.member "help" longFlags
then []
else [optSummary
{ optionInfoLongFlags = ["help"]
}]
else if Set.member "help" longFlags
then [optSummary
{ optionInfoShortFlags = ['h']
}]
else [optSummary
{ optionInfoShortFlags = ['h']
, optionInfoLongFlags = ["help"]
}]
optsGroupHelp = do
let (groupsAndOpts, _) = uniqueGroupInfos opts
let groups = [g | (g, _) <- groupsAndOpts]
group <- (groupHelp : groups)
let flag = "help-" ++ groupInfoName group
if Set.member flag longFlags
then []
else [optGroupHelp group flag]
subcmdsWithHelp = do
(subcmdName, subcmdOpts) <- subcmds
let subcmdLongFlags = Set.fromList $ do
opt <- subcmdOpts ++ optsGroupHelp
optionInfoLongFlags opt
let (groupsAndOpts, _) = uniqueGroupInfos subcmdOpts
let groups = [g | (g, _) <- groupsAndOpts]
let newOpts = do
group <- groups
let flag = "help-" ++ groupInfoName group
if Set.member flag (Set.union longFlags subcmdLongFlags)
then []
else [optGroupHelp group flag]
return (subcmdName, newOpts ++ subcmdOpts)
checkHelpFlag :: TokensFor a -> Maybe HelpFlag
checkHelpFlag (TokensFor tokens _) = flag where
flag = listToMaybe helpKeys
helpKeys = do
(k, _) <- tokens
if k == keySummary
then return HelpSummary
else if k == keyAll
then return HelpAll
else do
groupName <- maybeToList (stripPrefix keyGroupPrefix k)
return (HelpGroup groupName)
keySummary = keyFor "optHelpSummary"
keyAll = keyFor "optHelpGroup:all"
keyGroupPrefix = keyFor "optHelpGroup:"
helpFor :: HelpFlag -> OptionDefinitions a -> Maybe String -> String
helpFor flag defs subcmd = case flag of
HelpSummary -> execWriter (showHelpSummary defs subcmd)
HelpAll -> execWriter (showHelpAll defs subcmd)
HelpGroup groupName -> execWriter (showHelpOneGroup defs groupName subcmd)
showOptionHelp :: OptionInfo -> Writer String ()
showOptionHelp info = do
let safeHead xs = case xs of
[] -> []
(x:_) -> [x]
let shorts = optionInfoShortFlags info
let longs = optionInfoLongFlags info
let optStrings = map (\x -> ['-', x]) (safeHead shorts) ++ map (\x -> "--" ++ x) (safeHead longs)
unless (null optStrings) $ do
let optStringCsv = intercalate ", " optStrings
tell " "
tell optStringCsv
let desc = optionInfoDescription info
unless (null desc) $ do
if length optStringCsv > 27
then do
tell "\n"
tell " "
tell (optionInfoDescription info)
else do
tell (replicate (28 length optStringCsv) ' ')
tell (optionInfoDescription info)
tell "\n"
showHelpSummary :: OptionDefinitions a -> Maybe String -> Writer String ()
showHelpSummary (OptionDefinitions mainOpts subcmds) subcmd = do
let subcmdOptions = do
subcmdName <- subcmd
opts <- lookup subcmdName subcmds
return (subcmdName, opts)
let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts
let hasHelp = filter (\(g,_) -> groupInfoName g == "all") groupInfos
forM_ hasHelp showHelpGroup
tell "Application Options:\n"
forM_ ungroupedMainOptions showOptionHelp
unless (null subcmds) (tell "\n")
case subcmdOptions of
Nothing -> unless (null subcmds) $ do
tell "Subcommands:\n"
forM_ subcmds $ \(subcmdName, _) -> do
tell " "
tell subcmdName
tell "\n"
tell "\n"
Just (n, subOpts) -> do
tell ("Options for subcommand " ++ show n ++ ":\n")
forM_ subOpts showOptionHelp
tell "\n"
showHelpAll :: OptionDefinitions a -> Maybe String -> Writer String ()
showHelpAll (OptionDefinitions mainOpts subcmds) subcmd = do
let subcmdOptions = do
subcmdName <- subcmd
opts <- lookup subcmdName subcmds
return (subcmdName, opts)
let (groupInfos, ungroupedMainOptions) = uniqueGroupInfos mainOpts
let (hasHelp, noHelp) = partition (\(g,_) -> groupInfoName g == "all") groupInfos
forM_ hasHelp showHelpGroup
forM_ noHelp showHelpGroup
tell "Application Options:\n"
forM_ ungroupedMainOptions showOptionHelp
unless (null subcmds) (tell "\n")
case subcmdOptions of
Nothing -> forM_ subcmds $ \(subcmdName, subcmdOpts) -> do
tell ("Options for subcommand " ++ show subcmdName ++ ":\n")
forM_ subcmdOpts showOptionHelp
tell "\n"
Just (n, subOpts) -> do
tell ("Options for subcommand " ++ show n ++ ":\n")
forM_ subOpts showOptionHelp
tell "\n"
showHelpGroup :: (GroupInfo, [OptionInfo]) -> Writer String ()
showHelpGroup (groupInfo, opts) = do
tell (groupInfoTitle groupInfo ++ ":\n")
forM_ opts showOptionHelp
tell "\n"
showHelpOneGroup :: OptionDefinitions a -> String -> Maybe String -> Writer String ()
showHelpOneGroup (OptionDefinitions mainOpts subcmds) groupName subcmd = do
let opts = case subcmd of
Nothing -> mainOpts
Just n -> case lookup n subcmds of
Just infos -> mainOpts ++ infos
Nothing -> mainOpts
let (groupInfos, _) = uniqueGroupInfos opts
let group = filter (\(g,_) -> groupInfoName g == groupName) groupInfos
forM_ group showHelpGroup
keyFor :: String -> String
keyFor fieldName = this_pkg ++ ":" ++ this_mod ++ ":" ++ fieldName where
(this_pkg, this_mod) = $(do
loc <- location
let pkg = loc_package loc
let mod' = loc_module loc
[| (pkg, mod') |])
uniqueGroupInfos :: [OptionInfo] -> ([(GroupInfo, [OptionInfo])], [OptionInfo])
uniqueGroupInfos allOptions = (Map.elems infoMap, ungroupedOptions) where
infoMap = Map.fromListWith merge $ do
opt <- allOptions
case optionInfoGroup opt of
Nothing -> []
Just g -> [(groupInfoName g, (g, [opt]))]
merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1)
ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)]