    -- |
    -- Module: Options.Help
    -- License: MIT
    module Options.Help
    	( addHelpFlags
    	, checkHelpFlag
    	, helpFor
    	, HelpFlag(..)
    	) where

    import           Control.Monad.Writer
    import           Data.Char (isSpace)
    import           Data.List (intercalate, partition)
    import           Data.Maybe (isNothing, listToMaybe)
    import qualified Data.Set as Set
    import qualified Data.Map as Map

    import           Options.Tokenize
    import           Options.Types

    data HelpFlag = HelpSummary | HelpAll | HelpGroup String
    	deriving (Eq, Show)

    addHelpFlags :: OptionDefinitions -> OptionDefinitions
    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 = Group
    		{ groupName = "all"
    		, groupTitle = "Help Options"
    		, groupDescription = "Show all help options."
    		}

    	optSummary = OptionInfo
    		{ optionInfoKey = OptionKeyHelpSummary
    		, optionInfoShortFlags = []
    		, optionInfoLongFlags = []
    		, optionInfoDefault = ""
    		, optionInfoUnary = True
    		, optionInfoUnaryOnly = True
    		, optionInfoDescription = "Show option summary."
    		, optionInfoGroup = Just groupHelp
    		, optionInfoLocation = Nothing
    		, optionInfoTypeName = ""
    		}

    	optGroupHelp group flag = OptionInfo
    		{ optionInfoKey = OptionKeyHelpGroup (groupName group)
    		, optionInfoShortFlags = []
    		, optionInfoLongFlags = [flag]
    		, optionInfoDefault = ""
    		, optionInfoUnary = True
    		, optionInfoUnaryOnly = True
    		, optionInfoDescription = groupDescription group
    		, optionInfoGroup = Just groupHelp
    		, optionInfoLocation = Nothing
    		, optionInfoTypeName = ""
    		}

    	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, _) = uniqueGroups opts
    		let groups = [g | (g, _) <- groupsAndOpts]
    		group <- (groupHelp : groups)
    		let flag = "help-" ++ groupName 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, _) = uniqueGroups subcmdOpts
    		let groups = [g | (g, _) <- groupsAndOpts]
    		let newOpts = do
    			group <- groups
    			let flag = "help-" ++ groupName group
    			if Set.member flag (Set.union longFlags subcmdLongFlags)
    				then []
    				else [optGroupHelp group flag]
    		return (subcmdName, newOpts ++ subcmdOpts)

    checkHelpFlag :: Tokens -> Maybe HelpFlag
    checkHelpFlag tokens = flag where
    	flag = listToMaybe helpKeys
    	helpKeys = do
    		(k, _) <- tokensList tokens
    		case k of
    			[OptionKeyHelpSummary] -> return HelpSummary
    			[OptionKeyHelpGroup "all"] -> return HelpAll
    			[OptionKeyHelpGroup name] -> return (HelpGroup name)
    			_ -> []

    helpFor :: HelpFlag -> OptionDefinitions -> Maybe String -> String
    helpFor flag defs subcmd = case flag of
    	HelpSummary -> execWriter (showHelpSummary defs subcmd)
    	HelpAll -> execWriter (showHelpAll defs subcmd)
    	HelpGroup name -> execWriter (showHelpOneGroup defs name 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
    		unless (null (optionInfoTypeName info)) $ do
    			tell " :: "
    			tell (optionInfoTypeName info)
    		tell "\n"
    		unless (null (optionInfoDescription info)) $ do
    			forM_ (wrapWords 76 (optionInfoDescription info)) $ \line -> do
    				tell "    "
    				tell line
    				tell "\n"
    		unless (null (optionInfoDefault info)) $ do
    			tell "    default: "
    			tell (optionInfoDefault info)
    			tell "\n"

    -- A simple greedy word-wrapper for fixed-width terminals, permitting overruns
    -- and ragged edges.
    wrapWords :: Int -> String -> [String]
    wrapWords breakWidth = wrap where
    	wrap line = if length line <= breakWidth
    		then [line]
    		else if any isBreak line
    			then case splitAt breakWidth line of
    				(beforeBreak, afterBreak) -> case reverseBreak isBreak beforeBreak of
    					(beforeWrap, afterWrap) -> beforeWrap : wrap (afterWrap ++ afterBreak)
    			else [line]
    	isBreak c = case c of
    		'\xA0' -> False -- NO-BREAK SPACE
    		'\x202F' -> False -- NARROW NO-BREAK SPACE
    		'\x2011' -> False -- NON-BREAKING HYPHEN
    		'-' -> True
    		_ -> isSpace c
    	reverseBreak :: (a -> Bool) -> [a] -> ([a], [a])
    	reverseBreak f xs = case break f (reverse xs) of
    		(after, before) -> (reverse before, reverse after)

    showHelpSummary :: OptionDefinitions -> 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) = uniqueGroups mainOpts

    	-- Always print --help group
    	let hasHelp = filter (\(g,_) -> groupName g == "all") groupInfos
    	forM_ hasHelp showHelpGroup

    	unless (null ungroupedMainOptions) $ do
    		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
    				-- TODO: subcommand help description
    				tell "\n"
    			tell "\n"
    		Just (n, subOpts) -> do
    			-- TODO: subcommand description
    			-- TODO: handle grouped options in subcommands?
    			tell ("Options for subcommand " ++ show n ++ ":\n")
    			forM_ subOpts showOptionHelp
    			tell "\n"

    showHelpAll :: OptionDefinitions -> 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) = uniqueGroups mainOpts

    	-- Always print --help group first, if present
    	let (hasHelp, noHelp) = partition (\(g,_) -> groupName 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
    			-- no subcommand description
    			tell ("Options for subcommand " ++ show subcmdName ++ ":\n")
    			forM_ subcmdOpts showOptionHelp
    			tell "\n"
    		Just (n, subOpts) -> do
    			-- TODO: subcommand description
    			-- TODO: handle grouped options in subcommands?
    			tell ("Options for subcommand " ++ show n ++ ":\n")
    			forM_ subOpts showOptionHelp
    			tell "\n"

    showHelpGroup :: (Group, [OptionInfo]) -> Writer String ()
    showHelpGroup (groupInfo, opts) = do
    	tell (groupTitle groupInfo ++ ":\n")
    	forM_ opts showOptionHelp
    	tell "\n"

    showHelpOneGroup :: OptionDefinitions -> String -> Maybe String -> Writer String ()
    showHelpOneGroup (OptionDefinitions mainOpts subcmds) name subcmd = do
    	let opts = case subcmd of
    		Nothing -> mainOpts
    		Just n -> case lookup n subcmds of
    			Just infos -> mainOpts ++ infos -- both
    			Nothing -> mainOpts
    	let (groupInfos, _) = uniqueGroups opts

    	-- Always print --help group
    	let group = filter (\(g,_) -> groupName g == name) groupInfos
    	forM_ group showHelpGroup

    uniqueGroups :: [OptionInfo] -> ([(Group, [OptionInfo])], [OptionInfo])
    uniqueGroups allOptions = (Map.elems infoMap, ungroupedOptions) where
    	infoMap = Map.fromListWith merge $ do
    		opt <- allOptions
    		case optionInfoGroup opt of
    			Nothing -> []
    			Just g -> [(groupName g, (g, [opt]))]
    	merge (g, opts1) (_, opts2) = (g, opts2 ++ opts1)
    	ungroupedOptions = [o | o <- allOptions, isNothing (optionInfoGroup o)]