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