Usage.hs

module Util.Args.Usage (usage) where

import Util.Args.ArgDescr (ArgDescr(..), DefaultValue(..))
import Data.Function (on)
import Util.WordWrap (wordWrap)
import Data.List(sortBy)
import Util.Args.ArgArrow (ArgArrow, getKnownArgs)
import Util.String (padTo)
import System.Environment (getProgName)

-- pretty prints cli arg description for usage
-- left column contains cli arg header (e.g. '--verbose', or '--binary=PATH')
-- right column contains info messages for that argument
-- returns list of lines
showFlagDescr :: ArgDescr -> [String]
showFlagDescr argDescr = zipWith makeLine lefts helpLines
    where lefts    = argLine : repeat ""
          argLine  = case argDescr of
                       SwitchDescr name _ Nothing -> "--" ++ name
                       SwitchDescr name _ (Just c) ->
                           concat ["-", [c], " ", "--", name]
                       ValArg name tmpl _ _ -> concat ["--", name, "=", tmpl]
          msgLines = wordWrap 60 $ case argDescr of
                                     SwitchDescr _ hlp _ -> hlp
                                     ValArg _ _ default' help ->
                                         concat [help, "\n", defaultsLine default']
          helpLines = if length argLine < 18 then
                          msgLines
                      else
                          "" : msgLines -- line with argument is too long
                                        -- make more room for it
          defaultsLine (ConstValue s) = concat ["(defaults to '", s, "')"]
          defaultsLine (DynValue s)   = concat ["(defaults to ", s, ")"]
          makeLine infoLine descrLine = (infoLine `padTo` 20) ++ descrLine

-- returns string with formatted cli arg usage help message
-- argument descriptions are extracted from arg parsing computation
-- adds simple header and appends provided footer
usage :: ArgArrow a b -> String -> IO String
usage arrow outro = do
  self <- getProgName
  let intro = "usage: " ++ self ++ " [FLAGS]"
  return $ unlines $ [intro, "", "Flags:"] ++ flagsDescr ++ [""] ++  outro'
      where flagsDescr = concatMap showFlagDescr $ argDescrSort $ getKnownArgs arrow
            argDescrSort = sortBy (compare `on` argName)
            outro' = wordWrap 80 outro