diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Conrad Parker 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMain diff --git a/UI/Command.hs b/UI/Command.hs new file mode 100644 --- /dev/null +++ b/UI/Command.hs @@ -0,0 +1,15 @@ +module UI.Command ( + App, + appArgs, + appConfig, + Application (..), + Command (..), + defCmd, + appMain, + appMainWithOptions +) where + +import UI.Command.App +import UI.Command.Application +import UI.Command.Command +import UI.Command.Main (appMain, appMainWithOptions) diff --git a/UI/Command/App.hs b/UI/Command/App.hs new file mode 100644 --- /dev/null +++ b/UI/Command/App.hs @@ -0,0 +1,36 @@ +module UI.Command.App ( + App, + appArgs, + appConfig, + + AppContext(..) +) where + +import Data.Default + +import Control.Monad.Reader +import System.Console.GetOpt + +import Control.Monad (when) + +import System.Environment (getArgs) +import System.Exit + +------------------------------------------------------------ +-- App +-- + +data (Default config) => AppContext config = AppContext { + appContextConfig :: config, + appContextArgs :: [String] +} + +type App config = ReaderT (AppContext config) IO + +-- | Get the application arguments +appArgs :: (Default config) => App config [String] +appArgs = asks appContextArgs + +-- | Get the application config +appConfig :: (Default config) => App config config +appConfig = asks appContextConfig diff --git a/UI/Command/Application.hs b/UI/Command/Application.hs new file mode 100644 --- /dev/null +++ b/UI/Command/Application.hs @@ -0,0 +1,76 @@ +module UI.Command.Application ( + Application (..), +) where + +import Data.Default + +import System.Console.GetOpt (OptDescr) + +import UI.Command.Command + +------------------------------------------------------------ +-- Application class +-- + +-- | It is often simpler to use the default implementation of Application, and +-- override it with the details you choose to use. +-- For example, an implementation of the ''hello'' command: +-- +-- > hello = def { +-- > appName = "hello", +-- > appVersion = "0.1", +-- > appAuthors = ["Joe R. Hacker"], +-- > appBugEmail = "bugs@example.com", +-- > appShortDesc = "UI.Command example program", +-- > appLongDesc = longDesc, +-- > appCategories = ["Greetings", "Cat Math"], +-- > appSeeAlso = ["tractorgen"], +-- > appProject = "Haskell", +-- > appCmds = [world, times] +-- > } +-- > +-- > longDesc = "a demonstration program for the UI.Command framework." +-- +data (Default opts, Default config) => Application opts config = Application { + -- | Name of the program + appName :: String, + + -- | Software version + appVersion :: String, + + -- | Email address to report bugs to + appBugEmail :: String, + + -- | Names of authors + appAuthors :: [String], + + -- | One-line description of the command + appShortDesc :: String, + + -- | Long description of the command + appLongDesc :: String, + + -- | Categories to show in help text, in order of appearance + appCategories :: [String], + + -- | Project that this command is part of + appProject :: String, + + -- | Related commands + appSeeAlso :: [String], + + -- | The actual commands + appCmds :: [Command config], + + -- | Union of all options accepted by the application's commands. + -- Note that options '-h', '-?', '--help', '-V', '--version' will + -- be automatically added and handled by UI.Command + appOptions :: [OptDescr opts], + + -- | Function to process options + appProcessConfig :: config -> [opts] -> IO config +} + +instance (Default opts, Default config) => Default (Application opts config) where + def = Application "" "0.0" def def def def def def def def def def + diff --git a/UI/Command/Command.hs b/UI/Command/Command.hs new file mode 100644 --- /dev/null +++ b/UI/Command/Command.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module UI.Command.Command ( + Command (..), + defCmd +) where + +import Data.Default + +import Control.Monad.Trans (liftIO) + +import UI.Command.App (App) + +------------------------------------------------------------ +-- Command class +-- + +-- | It is often simpler to use the default implementation of Command, and +-- override it with the details you choose to use. +-- For example, an implementation of the ''hello world'' command: +-- +-- > world = def { +-- > cmdName = "world", +-- > cmdHandler = worldHandler, +-- > cmdCategory = "Greetings", +-- > cmdShortDesc = "An implementation of the standard software greeting." +-- > } +-- > +-- > worldHandler = liftIO $ putStrLn "Hello world!" +-- +data (Default config) => Command config = Command { + -- | Name of the cmdcommand + cmdName :: String, + + -- | Handler + cmdHandler :: App config (), + + -- | Category in this program's documentation + cmdCategory :: String, + + -- | Synopsis + cmdSynopsis :: String, + + -- | Short description + cmdShortDesc :: String, + + -- | [(example description, args)] + cmdExamples :: [(String, String)] +} + +instance (Default config) => Default (App config ()) where + def = liftIO $ putStrLn "Unimplemented command" + +instance (Default config) => Default (Command config) where + def = Command "" def def def def def + +defCmd :: Command () +defCmd = Command "" def def def def def diff --git a/UI/Command/Doc.hs b/UI/Command/Doc.hs new file mode 100644 --- /dev/null +++ b/UI/Command/Doc.hs @@ -0,0 +1,187 @@ +module UI.Command.Doc ( + helpCmd, manCmd, + help, man +)where + +import Data.Default +import Data.Char (toUpper) + +import System.Locale (defaultTimeLocale) +import Data.Time.Format (formatTime) +import Data.Time.Clock (getCurrentTime) + +import Text.Printf (printf) + +import Control.Monad.Trans (liftIO) + +import UI.Command.App (App, appArgs) +import UI.Command.Application +import UI.Command.Command +import UI.Command.Render + +------------------------------------------------------------ +-- internal cmdcommands +-- + +internalCmds :: [Command ()] +internalCmds = [helpCmd, manCmd] + +------------------------------------------------------------ +-- Help +-- + +-- helpCmd :: (Default config) => Command config +helpCmd = def { + cmdName = "help", + cmdShortDesc = "Display help for a specific cmdcommand" +} + +--help :: (Default opts, Default config) => Application opts config -> [String] -> IO () +-- help :: (Default opts, Default config) => Application opts config -> App config () +help app = do + args <- appArgs + liftIO $ mapM_ putStr $ longHelp app args + +longHelp :: (Default opts, Default config) => Application opts config -> [String] -> [String] +-- | "app help" with no arguments: Give a list of all cmdcommands +longHelp app [] = + [appShortDesc app ++ "\n"] ++ + ["Usage: " ++ (appName app) ++ " [--version] [--help] command [args]\n\n"] ++ + [indent 2 (appLongDesc app), "\n"] ++ + map (categoryHelp app) (appCategories app) ++ + [internalHelp app] ++ + ["\nPlease report bugs to <" ++ appBugEmail app ++ ">\n"] + +-- | "app help command": Give command-specific help +longHelp app (command:_) = contextHelp app command m + where m = filter (\x -> cmdName x == command) (appCmds app) + +-- | Provide synopses for a specific category of commands +categoryHelp :: (Default opts, Default config) => Application opts config -> String -> String +categoryHelp app c = c ++ ":\n" ++ unlines (map itemHelp items) ++ "\n" + where + items = filter (\x -> cmdCategory x == c) (appCmds app) + +-- | Provide synopses for internal commands +internalHelp :: (Default opts, Default config) => Application opts config -> String +internalHelp app = unlines $ "Miscellaneous:" : map itemHelp internalCmds + +-- | One-line format for a command +itemHelp i = printf " %-14s%s" (cmdName i) (cmdShortDesc i) + +-- | Provide detailed help for a specific command +contextHelp :: (Default opts, Default config) => Application opts config -> [Char] -> [Command config] -> [String] +contextHelp app command [] = longHelp app [] ++ contextError + where contextError = ["\n*** \"" ++ command ++ "\": Unknown command.\n"] +contextHelp app command (item:_) = synopsis ++ usage ++ description ++ examples + where usage = ["Usage: " ++ appName app ++ " " ++ command ++ hasOpts command ++ "\n"] + hasOpts "help" = " command" + hasOpts _ = " [options]" + synopsis = [(appName app) ++ " " ++ command ++ ": " ++ cmdSynopsis item ++ "\n"] + description = case (cmdShortDesc item) of + "" -> [] + _ -> ["\n" ++ indent 2 (cmdShortDesc item)] + examples = case (cmdExamples item) of + [] -> [] + _ -> ["\nExamples:"] ++ + flip map (cmdExamples item) (\(desc,opts) -> + "\n " ++ desc ++ ":\n " ++ (appName app) ++ " " ++ command ++ + " " ++ opts ++ "\n") + +------------------------------------------------------------ +-- man +-- + +manCmd :: (Default config) => Command config +manCmd = def { + cmdName = "man", + cmdShortDesc = "Generate Unix man page for specific cmdcommand" +} + +-- man :: (Default opts, Default config) => Application opts config -> [String] -> IO () +man app = do + args <- appArgs + currentTime <- liftIO $ getCurrentTime + let dateStamp = formatTime defaultTimeLocale "%B %Y" currentTime + liftIO $ putStrLn . concat $ longMan app dateStamp args + +manSH :: String -> String +manSH s = "\n.SH " ++ s ++ "\n\n" + +headerMan :: (Default opts, Default config) => Application opts config -> String -> [String] +headerMan app dateStamp = [unwords [".TH", u, "1", quote dateStamp, quote (appName app), project, "\n"]] + where + u = map toUpper (appName app) + project | appProject app == def = "" + | otherwise = quote $ appProject app + +synopsisMan :: (Default opts, Default config) => Application opts config -> String -> [Command config] -> [String] +synopsisMan app _ [] = + [manSH "SYNOPSIS", ".B ", appName app, "\n.RI COMMAND\n[\n.I OPTIONS\n]\n.I filename ...\n\n"] +synopsisMan app command (item:_) = + [manSH "SYNOPSIS", ".B ", appName app, "\n.RI ", command, "\n", hasOpts command, "\n"] + where hasOpts "help" = ".I \n" + hasOpts "man" = ".I \n" + hasOpts _ = "[\n.I OPTIONS\n]\n" + +authorsMan :: (Default opts, Default config) => Application opts config -> String -> [String] +authorsMan app command = manSH "AUTHORS" : a ++ g ++ e + where + n = appName app + a | appAuthors app == [] = [] + | otherwise = [n ++ " was written by ", englishList $ appAuthors app, "\n\n"] + g = ["This manual page was autogenerated by\n.B " ++ n ++ " man" ++ space command ++ ".\n\n"] + e | appBugEmail app == "" = [] + | otherwise = ["Please report bugs to <" ++ appBugEmail app ++ ">\n"] + space "" = "" + space c = ' ':c + +descMan :: String -> [String] +descMan desc = [manSH "DESCRIPTION", desc, "\n"] + +longMan :: (Default opts, Default config) => Application opts config -> String -> [String] -> [String] +longMan app dateStamp [] = + headerMan app dateStamp ++ + [manSH "NAME"] ++ + [appName app, " \\- ", appShortDesc app, "\n\n"] ++ + synopsisMan app "COMMAND" [] ++ + descMan (".B " ++ appName app ++ "\n" ++ appLongDesc app) ++ + map (categoryMan app) (appCategories app) ++ + authorsMan app "" ++ + seeAlsoMan app + +longMan app dateStamp (command:_) = contextMan app dateStamp command m + where + m = filter (\x -> cmdName x == command) (appCmds app) + +-- | Provide a list of related commands +seeAlsoMan :: (Default opts, Default config) => Application opts config -> [String] +seeAlsoMan app + | appSeeAlso app == def = [] + | otherwise = [manSH "SEE ALSO" ++ ".PP\n"] ++ + map (\x -> "\\fB"++x++"\\fR(1)\n") (appSeeAlso app) + +-- | Provide synopses for a specific category of commands +categoryMan :: (Default opts, Default config) => Application opts config -> String -> String +categoryMan app c = manSH (map toUpper c) ++ concat (map itemMan items) ++ "\n" + where items = filter (\x -> cmdCategory x == c) (appCmds app) + itemMan i = printf ".IP %s\n%s\n" (cmdName i) (cmdShortDesc i) + +contextMan :: (Default opts, Default config) => Application opts config -> String -> [Char] -> [Command config] -> [String] +contextMan app dateStamp _ [] = longMan app dateStamp [] +contextMan app dateStamp command i@(item:_) = + headerMan app dateStamp ++ + synopsisMan app command i ++ + descMan (cmdSynopsis item) ++ + description ++ + examples ++ + authorsMan app command + where + description | cmdShortDesc item == "" = [] + | otherwise = ["\n" ++ cmdShortDesc item] + examples | cmdExamples item == [] = [] + | otherwise = manSH "EXAMPLES" : + flip map (cmdExamples item) (\(desc, opts) -> + ".PP\n" ++ desc ++ ":\n.PP\n.RS\n\\f(CW" ++ + appName app ++ " " ++ command ++ " " ++ + opts ++ "\\fP\n.RE\n") diff --git a/UI/Command/Main.hs b/UI/Command/Main.hs new file mode 100644 --- /dev/null +++ b/UI/Command/Main.hs @@ -0,0 +1,98 @@ +module UI.Command.Main ( + appMain, + appMainWithOptions +) where + +import Data.Default + +import Control.Monad.Reader +import System.Console.GetOpt + +import Control.Monad (when) + +import System.Environment (getArgs) +import System.Exit + +import UI.Command.App (AppContext(..)) +import UI.Command.Application +import UI.Command.Command (Command, cmdName, cmdHandler) +import UI.Command.Doc + +------------------------------------------------------------ +-- +-- + +initApp :: (Default opts, Default config) => Application opts config -> [String] -> IO (AppContext config) +initApp app args = do + (config, args) <- processArgs app args + return $ AppContext config args + +processArgs :: (Default opts, Default config) => Application opts config -> [String] -> IO (config, [String]) +processArgs app args = do + case getOpt RequireOrder (appOptions app) args of + (opts, args' , [] ) -> do + config <- (appProcessConfig app) def opts + return (config, args') + (_, _, _ : _) -> return (def, args) + +------------------------------------------------------------ +-- appMain +-- + +-- | Main wrapper +-- +-- > main = appMain hello +-- +appMain :: Application () () -> IO () +appMain app = do + allArgs <- getArgs + when (any isHelp allArgs) $ showHelp app allArgs + when (any isVersion allArgs) $ showVersion app + handleCommand app allArgs + +appMainWithOptions :: (Default opts, Default config) => Application opts config -> IO () +appMainWithOptions app = do + allArgs <- getArgs + when (any isHelp allArgs) $ showHelp app allArgs + when (any isVersion allArgs) $ showVersion app + handleCommand app allArgs + +helpStrings :: [[Char]] +helpStrings = ["--help", "-h", "-?"] + +versionStrings :: [[Char]] +versionStrings = ["--version", "-V"] + +isHelp :: String -> Bool +isHelp x = elem x helpStrings + +isVersion :: String -> Bool +isVersion x = elem x versionStrings + +showHelp :: (Default opts, Default config) => Application opts config -> [String] -> IO () +showHelp app args = do + (initApp app args) >>= runReaderT (help app) + exitWith ExitSuccess + +showVersion :: (Default opts, Default config) => Application opts config -> IO () +showVersion app = do + putStrLn $ appName app ++ " " ++ appVersion app + exitWith ExitSuccess + +handleCommand :: (Default opts, Default config) => Application opts config -> [String] -> IO () +handleCommand app [] = showHelp app [] +-- handleCommand app [_] = showHelp app [""] + +handleCommand app (command:args) + | command == "help" = showHelp app args + | command == "man" = showMan + | otherwise = (initApp app args) >>= loop1 + where + showMan = (initApp app args) >>= loopMan + loopMan st = runReaderT (man app) st + loop1 st = runReaderT run st + -- docCmds :: (Default config1) => [Command config1] + -- docCmds = [helpCmd{cmdHandler = help app}, manCmd{cmdHandler = man app}] + run = act $ filter (\x -> cmdName x == command) (appCmds app) + act [] = help app + act (s:_) = cmdHandler s diff --git a/UI/Command/Render.hs b/UI/Command/Render.hs new file mode 100644 --- /dev/null +++ b/UI/Command/Render.hs @@ -0,0 +1,41 @@ +module UI.Command.Render ( + para, indent, quote, breakLines, englishList +)where + +import Data.Char (isSpace) +import Data.List (intersperse) + +------------------------------------------------------------ +-- Paragraph rendering +-- + +para :: [String] -> String +para ss = concat $ intersperse "\n" (map (\s -> breakLines 76 s) ss) + +indent :: Int -> String -> String +indent i s = unlines $ map (\x -> indentation ++ x) (lines s) + where + indentation = take i $ repeat ' ' + +quote :: String -> String +quote = surround "\"" + +surround :: [a] -> [a] -> [a] +surround c s = concat [c, s, c] + +-- breakLines leftIndent columnWidth text +breakLines :: Int -> String -> String +breakLines n s + | length s < n = s ++ "\n" + | otherwise = line' ++ "\n" ++ breakLines n rest' + where + (line, rest) = splitAt n s + (rSpill, rLine) = break isSpace (reverse line) + line' = reverse rLine + rest' = reverse rSpill ++ rest + +englishList :: [String] -> String +englishList [] = [] +englishList [a] = a +englishList [a,b] = a ++ " and " ++ b +englishList (a:as) = a ++ ", " ++ englishList as diff --git a/examples/ui-cmd-hello.hs b/examples/ui-cmd-hello.hs new file mode 100644 --- /dev/null +++ b/examples/ui-cmd-hello.hs @@ -0,0 +1,68 @@ +module Main where + +import Control.Monad (liftM, when) +import Control.Monad.Trans (liftIO) + +import Data.Default +import Data.List (intersperse) + +import UI.Command + +------------------------------------------------------------ +-- world +-- + +world :: Command () + +world = defCmd { + cmdName = "world", + cmdHandler = worldHandler, + cmdCategory = "Greetings", + cmdShortDesc = "An implementation of the standard software greeting." + } + +worldHandler = liftIO $ putStrLn "Hello world!" + +------------------------------------------------------------ +-- times +-- + +times = defCmd { + cmdName = "times", + cmdHandler = timesHandler, + cmdCategory = "Cat Math", + cmdShortDesc = "A repetition of salutation", + cmdExamples = [("Say hello 7 times", "7"), ("Say hello 3 times", "3")] + } + +timesHandler = do + args <- appArgs + when (args == []) $ return () + liftIO $ putStrLn $ concat . intersperse " " $ take (read $ head args) (repeat "hello") + +------------------------------------------------------------ +-- The Application +-- + +hello :: Application () () +hello = def { + appName = "hello", + appVersion = "0.1", + appAuthors = ["Joe R. Hacker"], + appBugEmail = "bugs@example.com", + appShortDesc = "UI.Command example program", + appLongDesc = longDesc, + appCategories = ["Greetings", "Cat Math"], + appSeeAlso = ["tractorgen"], + appProject = "Haskell", + appCmds = [world, times] + } + +longDesc = "a demonstration program for the UI.Command framework." + +------------------------------------------------------------ +-- Main +-- + +main :: IO () +main = appMain hello diff --git a/ui-command.cabal b/ui-command.cabal new file mode 100644 --- /dev/null +++ b/ui-command.cabal @@ -0,0 +1,44 @@ +Name: ui-command +Version: 0.5.0 +License: BSD3 +License-file: LICENSE +Author: Conrad Parker +Maintainer: Conrad Parker +Category: Development +Synopsis: A framework for friendly commandline programs +Description: This is a framework for creating commandline applications. It + provides various features which give a polished feel to your + application. + . + It is designed to encourage you to provide clear documentation + and working examples. It implements default ''help'' + and ''man'' commands for your application, which will layout help + text and generate Unix-style man pages. + . + It provides special handling for applications of the form + ''program command args'', the style of interaction common in revision + control systems. It will dispatch to handler functions that you + provide for each command, and also provide command-specific + help to the user. +Stability: experimental +Build-Type: Simple +Cabal-Version: >= 1.2 + +------------------------------------------------------------ +library + Build-Depends: base < 5, transformers, monads-fd, time, old-locale, data-default + Exposed-modules: UI.Command + Other-modules: UI.Command.App + UI.Command.Application + UI.Command.Command + UI.Command.Doc + UI.Command.Main + UI.Command.Render + +------------------------------------------------------------ +-- hello example +-- + +Executable ui-cmd-hello + Main-Is: ui-cmd-hello.hs + Hs-Source-Dirs: ., examples