-- | This module provides a variant of 'System.Console.GetOpt.usageInfo'.
--
--  Unlike the standard @usageInfo@ function, lists of long switches are broken
--  across multiple lines to economise on columns. For example,
--
--  @
--    -r  --recursive           add contents of subdirectories
--        --not-recursive,
--        --no-recursive        don't add contents of subdirectories
--  @

{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Usage
    ( usageInfo
    , formatOptions
    , getCommandHelp
    , getCommandMiniHelp
    , usage
    , subusage
    ) where

import Prelude ()
import Darcs.Prelude

import Data.Functor.Compose
import System.Console.GetOpt( OptDescr(..), ArgDescr(..) )
import Darcs.UI.Options.All ( stdCmdActions )
import Darcs.UI.Commands
    ( CommandControl(..)
    , DarcsCommand(..)
    , wrappedCommandName
    , wrappedCommandDescription
    , getSubcommands
    , commandAlloptions
    )
import Darcs.UI.Options ( DarcsOptDescr, odesc )
import Darcs.Util.Printer
    ( Doc, text, vsep, ($$), vcat, hsep
    , renderString
    )

formatOptions :: [DarcsOptDescr a] -> [String]
formatOptions optDescrs = table
   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescrs
         table          = zipWith3 paste
                            shortPadded
                            (zipWith (++) (map (unlines' . init) ls)
                                          (sameLen $ map last ls))
                            ds
         shortPadded    = sameLen ss
         prePad         = replicate (3 + length (head shortPadded)) ' '
         -- Similar to unlines (additional ',' and padding):
         unlines'       = concatMap (\x -> x ++ ",\n" ++ prePad)
         -- Unchanged:
         paste x y z    = "  " ++ x ++ " " ++ y ++ "  " ++ z
         sameLen xs     = flushLeft ((maximum . map length) xs) xs
         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]

-- | Variant of 'System.Console.GetOpt.usageInfo'.
-- Return a string describing the usage of a command, derived from the header
-- (first argument) and the options described by the second argument.
--
-- Sequences of long switches are presented on separate lines.
usageInfo :: String         -- header
          -> [DarcsOptDescr a]    -- option descriptors
          -> String          -- nicely formatted decription of options
usageInfo header optDescrs = unlines (header:formatOptions optDescrs)

-- Mild variant of the standard definition: 'losFmt' is a list rather than a
-- comma separated string.
fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]
fmtOpt (Compose (Option sos los ad descr)) =
   case lines descr of
     []     -> [(sosFmt,losFmt,"")]
     (d:ds) ->  (sosFmt,losFmt,d) : [ ("",[],d') | d' <- ds ]
   where endBy _  []     = ""
         endBy ch [x]    = x ++ [ch]
         endBy ch (x:xs) = x ++ ch:' ':endBy ch xs
         sosFmt = endBy ',' (map fmtShort sos)
         losFmt = map (fmtLong ad) los

--------------------------------------------------------------------------------
-- Verbatim copies: these definitions aren't exported by System.Console.GetOpt
--------------------------------------------------------------------------------

fmtShort :: Char -> String
fmtShort so = "-" ++ [so]

fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg  _   ) lo = "--" ++ lo
fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
--------------------------------------------------------------------------------

usage :: [CommandControl] -> Doc
usage cs = vsep 
    [ "Usage: darcs COMMAND ..."
    , "Commands:" $$ usageHelper cs
    , vcat
      [ "Use 'darcs COMMAND --help' for help on a single command."
      , "Use 'darcs --version' to see the darcs version number."
      , "Use 'darcs --exact-version' to see a detailed darcs version."
      , "Use 'darcs help patterns' for help on patch matching."
      , "Use 'darcs help environment' for help on environment variables."
      , "Use 'darcs help manpage' to display help in the manpage format."
      , "Use 'darcs help markdown' to display help in the markdown format."
      ]
    , "Check bug reports at http://bugs.darcs.net/"
    ]

subusage :: DarcsCommand pf -> String
subusage super = renderString $ vsep
    [ header
    , subcommandsHelp
    , vcat $ map text $ formatOptions $ odesc stdCmdActions
    , text $ commandHelp super
    ]
  where
    usageHelp = hsep $ map text
        [ "Usage:"
        , commandProgramName super
        , commandName super
        , "SUBCOMMAND ..."
        ]
    header = usageHelp $$ text (commandDescription super)
    subcommandsHelp = case getSubcommands super of
        [] -> mempty
        subcommands -> usageHelper subcommands

usageHelper :: [CommandControl] -> Doc
usageHelper xs = vsep (groups xs)
  where
    groups [] = []
    groups (HiddenCommand _:cs) = groups cs
    groups (GroupName n:cs) =
      mempty : case groups cs of
        [] -> [text n]
        (g:gs) -> (text n $$ g) : gs
    groups (CommandData c:cs) =
      case groups cs of
        [] -> [cmdHelp c]
        (g:gs) -> (cmdHelp c $$ g) : gs

    cmdHelp c = text $ "  " ++
      padSpaces maxwidth (wrappedCommandName c) ++
      wrappedCommandDescription c

    padSpaces n s = s ++ replicate (n - length s) ' '

    maxwidth = maximum $ 15 : (map cwidth xs)

    cwidth (CommandData c) = length (wrappedCommandName c) + 2
    cwidth _               = 0

getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
getCommandMiniHelp msuper cmd = renderString $ vsep
    [ getCommandHelpCore msuper cmd
    , hsep $ map text
        [ "See"
        , commandProgramName cmd
        , "help"
        , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd
        , "for details."
        ]
    ]

getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelp msuper cmd = vsep
    [ getCommandHelpCore msuper cmd
    , subcommandsHelp
    , withHeading "Options:" basicOptionsHelp
    , withHeading "Advanced options:" advancedOptionsHelp
    , text $ commandHelp cmd
    ]
  where
    withHeading _ [] = mempty
    withHeading h ls = vcat (text h : map text ls)

    (basic, advanced) = commandAlloptions cmd
    -- call formatOptions with combined options so that
    -- both get the same formatting
    (basicOptionsHelp, advancedOptionsHelp) =
        splitAt (length basic) $ formatOptions (basic ++ advanced)

    subcommandsHelp =
      case msuper of
        Nothing ->
          case getSubcommands cmd of
            [] -> mempty
            subcommands -> usageHelper subcommands
        -- we don't want to list subcommands if we're already specifying them
        Just _ -> mempty

getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> Doc
getCommandHelpCore msuper cmd = vcat
    [ hsep $
        [ "Usage:"
        , text $ commandProgramName cmd
        , maybe mempty (text . commandName) msuper
        , text $ commandName cmd
        , "[OPTION]..."
        ]
        ++ args_help
    , text $ commandDescription cmd
    ]
  where
    args_help = case cmd of
                    (DarcsCommand {}) -> map text $ commandExtraArgHelp cmd
                    _ -> []