ui-command (empty) → 0.5.0
raw patch · 11 files changed
+654/−0 lines, 11 filesdep +basedep +data-defaultdep +monads-fdsetup-changed
Dependencies added: base, data-default, monads-fd, old-locale, time, transformers
Files
- LICENSE +27/−0
- Setup.hs +5/−0
- UI/Command.hs +15/−0
- UI/Command/App.hs +36/−0
- UI/Command/Application.hs +76/−0
- UI/Command/Command.hs +57/−0
- UI/Command/Doc.hs +187/−0
- UI/Command/Main.hs +98/−0
- UI/Command/Render.hs +41/−0
- examples/ui-cmd-hello.hs +68/−0
- ui-command.cabal +44/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMain
+ UI/Command.hs view
@@ -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)
+ UI/Command/App.hs view
@@ -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
+ UI/Command/Application.hs view
@@ -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 "<undocumented command>" "0.0" def def def def def def def def def def+
+ UI/Command/Command.hs view
@@ -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 "<Anonymous command>" def def def def def++defCmd :: Command ()+defCmd = Command "<Anonymous command>" def def def def def
+ UI/Command/Doc.hs view
@@ -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 <cmdcommand>\n"+ hasOpts "man" = ".I <cmdcommand>\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")
+ UI/Command/Main.hs view
@@ -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
+ UI/Command/Render.hs view
@@ -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
+ examples/ui-cmd-hello.hs view
@@ -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
+ ui-command.cabal view
@@ -0,0 +1,44 @@+Name: ui-command+Version: 0.5.0+License: BSD3+License-file: LICENSE+Author: Conrad Parker <conrad@metadecks.org>+Maintainer: Conrad Parker <conrad@metadecks.org>+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