-- |
-- 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
	
	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)]