console-program 0.3.2.0 → 0.4.2.3
raw patch · 9 files changed
Files
- CHANGELOG.md +34/−0
- Examples/Full.hs +9/−15
- Examples/Simple.hs +4/−4
- console-program.cabal +38/−30
- src/System/Console/Argument.hs +26/−12
- src/System/Console/Command.hs +36/−12
- src/System/Console/ConfigFile.hs +21/−15
- src/System/Console/Internal.hs +45/−8
- src/System/Console/Program.hs +80/−22
+ CHANGELOG.md view
@@ -0,0 +1,34 @@+# Changelog++### 0.4.2.3++* Update dependencies on containers and ansi-terminal.+* Fix cabal warning on category field.++### 0.4.2.2++* Update dependency on directory package.++### 0.4.2.1++* Update Examples/Full.hs to work with new API++### 0.4.2.0++* Add `withNonOptions` function to consume any number of non-option arguments.++### 0.4.1.0++* Add the possibility to customize the prompt in interactive mode.+* Eliminate dependency on unix package on Win32.++## 0.4.0.0++* API change: the `Command` constructor now takes an extra argument+ (specifying whether the command can be abbreviated on the command line).+ The function `command` can be used instead of the old constructor.+* Better handling of exceptions in interactive mode.++### 0.3.2++* Generalise actions to allow any instance of MonadIO.
Examples/Full.hs view
@@ -3,7 +3,7 @@ import System.Console.Command (- Commands,Tree(Node),Command(..),withOption,withNonOption,io+ Commands,Tree(Node),Command,command,withOption,withNonOption,io ) import System.Console.Program (single,showUsage) import qualified System.Console.Argument as Argument@@ -14,7 +14,7 @@ myCommands :: Commands IO myCommands = Node- (Command "count" "A program for counting" . io $ putStrLn "No command given; try \"count help\".")+ (command "count" "A program for counting" . io $ putStrLn "No command given; try \"count help\".") [ Node countUp [] , Node countDown []@@ -22,21 +22,15 @@ ] countUp,countDown,help :: Command IO-countUp = Command- {- name = "up"- , description = "Count up"- , action = withOption verboseOpt $ \ v -> io $ if v == Quiet+countUp = command "up" "Count up" $+ withOption verboseOpt $ \ v -> io $+ if v == Quiet then putStrLn "Counting quietly!" else mapM_ print [1 ..]- }-countDown = Command- {- name = "down"- , description = "Count down from INT."- , action = withNonOption Argument.natural $ \ upperBound -> io $ mapM_ print [upperBound, pred upperBound .. 1]- }-help = Command "help" "Show usage info" $ io (showUsage myCommands)+countDown = command "down" "Count down from INT." $+ withNonOption Argument.natural $ \ upperBound -> io $+ mapM_ print [upperBound, pred upperBound .. 1]+help = command "help" "Show usage info" $ io (showUsage myCommands) -- Custom data type to describe a verbosity level.
Examples/Simple.hs view
@@ -1,19 +1,19 @@ module Simple where -import System.Console.Command (Commands,Tree(Node),Command(..),io)+import System.Console.Command (Commands,Tree(Node),command,io) import System.Console.Program (single) myCommands :: Commands IO myCommands = Node- (Command "say" "" . io $ putStrLn "No command given.")+ (command "say" "" . io $ putStrLn "No command given.") [ Node- (Command "yes" "" . io $ putStrLn "Yes!")+ (command "yes" "" . io $ putStrLn "Yes!") [] , Node- (Command "no" "" . io $ putStrLn "No!")+ (command "no" "" . io $ putStrLn "No!") [] ]
console-program.cabal view
@@ -1,21 +1,23 @@-Name: console-program-Version: 0.3.2.0-Cabal-Version: >= 1.6-License: BSD3-Author: Arie Peterson-Maintainer: ariep@xs4all.nl-Category: Console-Synopsis: Interpret the command line and contents of a config file as commands and options-Description:- This library provides an infrastructure to build command line programs. It provides the following features:+name: console-program+version: 0.4.2.3+cabal-Version: >= 1.6+license: BSD3+author: Arie Peterson+maintainer: ariep@xs4all.nl+synopsis: Interpret the command line and a config file as commands and options+description:+ This library provides a framework to build command line programs. .- - declare any number of \"commands\" (modes of operation) of the program; .- - declare options of these commands;+ The constructed program can have several \"commands\" that provide different modes of operation.+ Options can be declared to allow fine-tuning of the behaviour of the program.+ These options are read from the command line when running the program+ and from a simple configuration file. .- - collect options from a configuration file and the command line, and execute the proper command. .+ Additionally, there is an interactive mode that reads and executes commands from standard input. .+ . Examples of using this library may be found in the Examples directory in the package tarball. . .@@ -26,35 +28,41 @@ - it allows a full tree of commands, instead of a list, so a command can have subcommands; . - it parses a configuration file, in addition to the command line arguments.-Category: System,Console-Build-Type: Simple-Extra-Source-Files:+category: System,Console+build-type: Simple+extra-source-files:+ CHANGELOG.md Examples/Simple.hs Examples/Full.hs -Source-repository head- Type: darcs- Location: http://hub.darcs.net/AriePeterson/console-program+source-repository head+ type: darcs+ location: http://hub.darcs.net/AriePeterson/console-program -Library- Build-Depends:+library+ build-depends: base == 4.*,- containers >= 0.1 && < 0.6,- directory >= 1.0 && < 1.3,- fez-conf == 1.0.*,+ containers >= 0.1 && < 0.7,+ directory >= 1.0 && < 1.4, ansi-wl-pprint >= 0.5 && < 0.7,- ansi-terminal >= 0.5 && < 0.7,+ ansi-terminal >= 0.5 && < 0.10, haskeline == 0.7.*,- transformers >= 0.2 && < 0.5,+ transformers >= 0.2 && < 0.6, utility-ht == 0.0.*, split == 0.2.*, parsec == 3.1.*,- parsec-extra == 0.1.*- Exposed-Modules:+ parsec-extra == 0.2.*+ if !os(windows)+ build-depends:+ unix >= 2.7 && < 2.8+ exposed-modules: System.Console.Argument, System.Console.Command, System.Console.Program- Other-Modules:+ other-modules: System.Console.ConfigFile, System.Console.Internal- Hs-Source-Dirs: src+ hs-source-dirs: src+ other-extensions:+ DeriveDataTypeable,+ ScopedTypeVariables
src/System/Console/Argument.hs view
@@ -6,7 +6,7 @@ Option , option - , Type (Type,parser,name,defaultValue)+ , Type(Type,parser,name,defaultValue) -- * Argument types , optional@@ -20,12 +20,13 @@ ) where -import System.Console.Internal (Option(Option),Identifier(Short,Long))+import System.Console.Internal hiding (name) -import Data.Char (toLower)-import Data.List.HT (viewR)+import Data.Char (toLower)+import Data.List.HT (viewR) import qualified Data.Map as Map import qualified System.Console.GetOpt as GetOpt+import Text.Parsec.String (Parser) import qualified Text.Parsec.Extra as P @@ -41,7 +42,7 @@ , name :: String -- ^ A name for this type of option argument (for usage info). , defaultValue :: Maybe a- -- ^ The default value, when the option occurs without option argument.+ -- ^ The default value when the option occurs without option argument. -- @Nothing@ means that an argument is required for this type of option. } @@ -57,13 +58,14 @@ :: [Char] -- ^ List of short option characters. -> [String] -- ^ List of long option strings. -> Type a -- ^ Type of option argument.- -> a -- ^ Default value.+ -> a -- ^ Default value when the option is not specified by the user. -> String -- ^ Description. -> Option a -- ^ The resulting option description. option short long t def description = let- identifier = if null short then Long (head long) else Short (head short)+ names = map Short short ++ map Long long+ identifier = identify names in Option- identifier+ names (GetOpt.Option short long@@ -90,8 +92,7 @@ -- | A boolean. Argument can be \"1\",\"0\",\"true\",\"false\",\"on\",\"off\",\"yes\",\"no\". boolean :: Type Bool boolean = Type- {- name = "BOOL"+ { name = "BOOL" , parser = \ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y , defaultValue = Just True }@@ -101,11 +102,19 @@ -- | A natural number (in decimal). natural :: Type Integer-natural = Type { name = "INT (natural)", parser = P.parseM P.natural "", defaultValue = Nothing }+natural = Type+ { name = "INT (nonnegative)"+ , parser = parseEither P.natural ""+ , defaultValue = Nothing+ } -- | An integer number (in decimal). integer :: Type Integer-integer = Type { name = "INT", parser = P.parseM P.integer "", defaultValue = Nothing }+integer = Type+ { name = "INT"+ , parser = parseEither P.integer ""+ , defaultValue = Nothing+ } -- | A directory path. A trailing slash is stripped, if present. directory :: Type FilePath@@ -124,3 +133,8 @@ -- | A device path. device :: Type FilePath device = string { name = "DEVICE" }++-- Helper functions++parseEither :: Parser a -> String -> String -> Either String a+parseEither = P.parseM show
src/System/Console/Command.hs view
@@ -10,25 +10,22 @@ module System.Console.Command ( Commands,Tree.Tree(Tree.Node)- , Command(Command,name,description,action)+ , Command(Command,name,description,action,shorten)+ , command , Action , io , withNonOption+ , withNonOptions , withOption , ignoreOption ) where import System.Console.Internal- (- Command(Command,name,description,action)- , Action(Action,run,options,nonOptions,ignoringOptions)- , Option(Option)- , Identifier- ) import qualified System.Console.Argument as Argument +import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO,liftIO) import qualified Data.Map as Map import qualified Data.Tree as Tree@@ -40,13 +37,21 @@ type Commands m = Tree.Tree (Command m) +-- | Create a new command having a given name and action.+command :: String -> String -> Action m -> Command m+command n d a = Command { name = n, description = d, action = a, shorten = True } +-- | Specify whether abbreviated subcommands are allowed.+-- If not, (sub)commands that do not match exactly are interpreted as+-- non-option arguments.+allowShort :: Bool -> Command m -> Command m+allowShort b c = c { shorten = b }+ -- | A simple action, taking no argument, and having no options. io :: (MonadIO m) => m () -> Action m io h = Action r [] [] [] where r [] _ = h- r rest _ = liftIO $ putStrLn e >> exitFailure where- e = "Error: unused non-option or unrecognised command: " ++ unwords rest+ r rest _ = liftIO . throwIO . UnknownCommand $ unwords rest -- | Create an action that takes an argument (non-option). -- @@ -71,18 +76,37 @@ , ignoringOptions = ignoringOptions (f undefined) } +-- | Create an action that takes all remaining non-option arguments.+--+-- The type of arguments is specified by the first parameter; such values can+-- be obtained from the module "System.Console.Argument".+withNonOptions :: (MonadIO m) => Argument.Type x -> ([x] -> Action m) -> Action m+withNonOptions argumentType f = Action+ {+ run = \ nonOpts opts -> let runWithArgs args [] = run (f $ reverse args) [] opts+ runWithArgs args (x:xs) = case Argument.parser argumentType x of+ Left e -> liftIO $ do+ putStrLn e+ exitFailure+ Right y -> runWithArgs (y:args) xs+ in runWithArgs [] nonOpts+ , nonOptions = ("[" ++ Argument.name argumentType ++ "...]") : nonOptions (f [])+ , options = options (f [])+ , ignoringOptions = ignoringOptions (f [])+ }+ -- | Create an action that takes an option. -- -- The first parameter is a description of the option; such a value can be -- constructed using 'System.Console.Argument.option'. withOption :: (MonadIO m) => Option a -> (a -> Action m) -> Action m-withOption (Option identifier optDescr def p) f = Action+withOption (Option names optDescr def p) f = Action {- run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup identifier opts of+ run = \ nonOpts opts -> case maybe (Right def) p $ Map.lookup (identify names) opts of Left e -> liftIO $ putStrLn e >> exitFailure Right a -> run (f a) nonOpts opts , nonOptions = nonOptions (f undefined)- , options = optDescr : options (f undefined)+ , options = ((identify names,names),optDescr) : options (f undefined) , ignoringOptions = ignoringOptions (f undefined) }
src/System/Console/ConfigFile.hs view
@@ -5,45 +5,51 @@ import System.Console.Command-import System.Console.Internal (name)+import System.Console.Internal import Control.Applicative ((<$>)) import Control.Exception (tryJust) import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO,liftIO)-import Data.List (isPrefixOf,concat)-import Data.List.Split (Splitter,split,whenElt,keepDelimsR)-import qualified Data.Map as Map+import Data.List (isPrefixOf,concat,break)+import qualified Data.List.Split as Split+import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (isJust)-import qualified Data.Tree as Tree-import qualified Fez.Data.Conf as Fez+import qualified Data.Tree as Tree import System.Directory (getAppUserDataDirectory) import System.IO.Error (isDoesNotExistError) -type UserCommand = [String]--readFromFile :: (MonadIO m) => Commands m -> UserCommand -> m [String]+readFromFile :: (MonadIO m) => Commands m -> UserCommand -> m [Setting] readFromFile commands command = liftIO $ do dataDir <- getAppUserDataDirectory $ name (Tree.rootLabel commands) let configFile = dataDir ++ "/" ++ "config" fileContents <- either (const "") id <$> tryJust (guard . isDoesNotExistError) (readFile configFile)- return $ Fez.parseToArgs . unlines $ filterSections command fileContents+ return . map parseSetting $ relevantLines command fileContents -filterSections :: UserCommand -> String -> [String]-filterSections c = concat . map snd . filter (flip isPrefixOf c . fst) . map parseSection . s . lines+relevantLines :: UserCommand -> String -> [String]+relevantLines c = concat . map snd . filter (flip isPrefixOf c . fst) . map parseSection . s . lines where s :: [String] -> [[String]]- s = split $ keepDelimsR $ whenElt (isJust . header) + s = Split.split . Split.keepDelimsL $ Split.whenElt (isJust . header) - header :: String -> Maybe [String]+ header :: String -> Maybe UserCommand header ('[' : xs) = Just . words . takeWhile (/= ']') $ xs header _ = Nothing - parseSection :: [String] -> ([String],[String])+ parseSection :: [String] -> (UserCommand,[String]) parseSection (h : rest) = case header h of Just c -> (c,rest) Nothing -> ([],h : rest) parseSection [] = ([],[])++parseSetting :: String -> Setting+parseSetting s = let (i,v) = break (== '=') s in+ (+ Long i+ , case v of+ [] -> Nothing+ '=' : rest -> Just rest+ )
src/System/Console/Internal.hs view
@@ -1,33 +1,61 @@+{-# LANGUAGE DeriveDataTypeable #-} module System.Console.Internal where -import Data.Map (Map)+import Control.Exception (Exception)+import Data.Map (Map)+import Data.Typeable (Typeable) import qualified System.Console.GetOpt as GetOpt +type UserCommand = [String]+ -- | An @Action m@ is an action (in the monad @m@), which may take arguments -- (\"non-options\") and options from the command line. data Action m = Action {- run :: [String] -> Map Identifier (Maybe String) -> m ()+ run :: [String] -> Settings -> m () , nonOptions :: [String]- , options :: [GetOpt.OptDescr (Identifier,Maybe String)]- , ignoringOptions :: [GetOpt.OptDescr (Identifier,Maybe String)]+ , options :: [((Identifier,[OptionName]),GetOpt.OptDescr CanonicalSetting)]+ , ignoringOptions :: [GetOpt.OptDescr CanonicalSetting] } -data Identifier = Short Char | Long String- deriving (Eq,Ord)- -- | A value of type @Option a@ describes an option, that delivers a value -- to the program of type @a@. data Option a = Option- Identifier+ [OptionName] (GetOpt.OptDescr (Identifier,Maybe String)) a (Maybe String -> Either String a) +data OptionName+ = Short Char+ | Long String+ deriving (Eq,Ord)+instance Show OptionName where+ show (Short c) = '-' : c : []+ show (Long i) = "--" ++ i +-- The @Identifier@ of an option should identify it uniquely.+newtype Identifier+ = Id OptionName+ deriving (Eq,Ord)++type Setting+ = (OptionName,Maybe String)++type CanonicalSetting+ = (Identifier,Maybe String)++type Settings+ = Map Identifier (Maybe String)++identify :: [OptionName] -> Identifier+identify (n : _) = Id n+identify _ = error "System.Console.Internal.identify: option without option names."++ -- | A @Command m@ is an action (in the monad @m@), together with some -- descriptive information. data Command m@@ -39,4 +67,13 @@ , description :: String -- | The actual action performed by this command. , action :: Action m+ -- | Prefer shortened subcommands over non-option arguments.+ , shorten :: Bool }++data ConsoleProgramException+ = UnknownCommand String+ deriving (Typeable)+instance Show ConsoleProgramException where+ show (UnknownCommand c) = "Error: unused non-option or unrecognised command: " ++ c+instance Exception ConsoleProgramException
src/System/Console/Program.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | This module contains functions to build a console program, that parses -- the command line (and a configuration file), divides it into commands, -- options and non-options, and executes the corresponding action from a tree@@ -9,6 +11,7 @@ -- * Using a command tree to construct a program single , interactive+ , interactiveWithPrompt , showUsage -- * Configuration file@@ -16,15 +19,29 @@ ) where -import System.Console.Command (Commands,Command)+import System.Console.Command (Commands,Command,shorten) import System.Console.ConfigFile (readFromFile)-import System.Console.Internal (run,options,nonOptions,ignoringOptions,action,description,name)+import System.Console.Internal + (+ run+ , UserCommand+ , options+ , nonOptions+ , ignoringOptions+ , action+ , description+ , name+ , ConsoleProgramException(UnknownCommand)+ ) import Control.Applicative (Applicative,(<|>),(*>))-import Control.Arrow ((&&&),second)+import Control.Arrow ((&&&),first)+import Control.Concurrent (myThreadId)+import Control.Exception (throwTo,AsyncException(UserInterrupt)) import Control.Monad (when,void) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Trans.Class (lift)+import Data.List (isPrefixOf,concatMap) import qualified Data.Map as Map import Data.Traversable (traverse) import qualified Data.Tree as Tree@@ -34,6 +51,9 @@ import System.Environment (getArgs) import System.Exit (exitSuccess) import System.IO (readFile)+#ifndef mingw32_HOST_OS+import qualified System.Posix.Signals as Sig+#endif import qualified Text.Parsec as P import qualified Text.PrettyPrint.ANSI.Leijen as PP @@ -47,9 +67,8 @@ -- @ -- option-name=option-value -- @--- , see the documentation of the package fez-conf for details. The format of--- the \"option-value\" part depends on the type of the option argument; see--- "System.Console.Argument".+-- The format of the \"option-value\" part depends on the type of the option+-- argument; see "System.Console.Argument". -- -- Sections can be defined for settings applying to a single command, -- using the name of a command, enclosed in square brackets, as section header:@@ -63,21 +82,41 @@ parse :: (MonadIO m,Applicative m) => Commands m -> [String] -> m () parse commands args = do let (commandString,command,restArgs) = select commands args- fileArgs <- readFromFile commands commandString+ fileSettings <- readFromFile commands commandString let (opts,nonOpts,errors) = GetOpt.getOpt GetOpt.Permute- (options (action command) ++ ignoringOptions (action command))- (fileArgs ++ restArgs)+ (map snd (options $ action command) ++ ignoringOptions (action command))+ restArgs when (not $ null errors) . void $ traverse (liftIO . putStrLn) errors- run (action command) nonOpts $ Map.fromList opts+ let commandLineSettings = Map.fromList opts+ optionIndex = Map.fromList .+ concatMap (\ ((i,names),_) -> map (flip (,) i) names) .+ options $ action command+ lookupSetting i = maybe+ (error $ "Unknown option: " ++ show i)+ id+ $ Map.lookup i optionIndex+ identifiedFileSettings = Map.fromList $ map (first lookupSetting) fileSettings+ settings = commandLineSettings `Map.union` identifiedFileSettings+ run (action command) nonOpts settings -- Select the right command from the command tree, and return the rest of the command line.-select :: Commands m -> [String] -> ([String],Command m,[String])-select (Tree.Node root _ ) [] = ([],root,[])-select (Tree.Node root subs) (x : xs) = case lookup x $ map (name . Tree.rootLabel &&& id) subs of- Nothing -> ([],root,x : xs)- Just cs -> let (xs',c,rest) = select cs xs in (x : xs',c,rest)+select :: Commands m -> [String] -> (UserCommand,Command m,[String])+select (Tree.Node root _ ) [] = ([],root,[])+select (Tree.Node root subs) (x : xs) = case lookup x subcommands of+ -- There is an exactly matching subcommand.+ Just cs -> descend cs+ -- There is no exactly matching subcommand.+ Nothing -> case shorten root of+ True -> case filter (isPrefixOf x . fst) subcommands of+ [(_,cs)] -> descend cs+ _ -> commit+ False -> commit+ where+ subcommands = map (name . Tree.rootLabel &&& id) subs+ descend cs = let (xs',c,rest) = select cs xs in (x : xs',c,rest)+ commit = ([],root,x : xs) -- | Load the configuration file (if present), and run the command given on -- the command line. Settings on the command line override the configuration@@ -92,14 +131,28 @@ -- instead, the user may repeatedly enter a command, possibly with options, -- which will be executed. interactive :: (MonadIO m,Haskeline.MonadException m,Applicative m) => Commands m -> m ()-interactive commands = do+interactive commands = interactiveWithPrompt (return $ name $ Tree.rootLabel commands) commands++-- | Same as 'interactive', but with a custom monadic function specifying the+-- text of the prompt.+interactiveWithPrompt :: (MonadIO m,Haskeline.MonadException m,Applicative m)+ => m String -> Commands m -> m ()+interactiveWithPrompt prompt commands = do+ tid <- liftIO myThreadId+#ifndef mingw32_HOST_OS+ liftIO $ Sig.installHandler Sig.keyboardSignal (Sig.Catch $ throwTo tid UserInterrupt) Nothing+#endif Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one where one = getLine' >>= \ line -> case words' line of Left e -> liftIO $ putStrLn e- Right ws -> lift $ parse commands ws+ Right ws -> lift (parse commands ws)+ `Haskeline.catch` (\ (e :: ConsoleProgramException) -> liftIO $ print e)+ `Haskeline.catch` (\ (e :: AsyncException) -> if e == UserInterrupt+ then liftIO $ print e+ else Haskeline.throwIO e) getLine' = do- putStrBold $ name (Tree.rootLabel commands)+ putStrBold =<< lift prompt maybe (liftIO exitSuccess) return =<< Haskeline.getInputLine ": " words' :: String -> Either String [String]@@ -121,16 +174,21 @@ -- | Print usage info for the program to stdout. showUsage :: (MonadIO m) => Commands n -> m ()-showUsage = liftIO . PP.putDoc . usage+showUsage = liftIO . PP.putDoc . (PP.<> PP.line) . usage where- usage (Tree.Node c ns) = (PP.<> PP.line) . subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $ PP.bold (PP.text $ name c)- descr c = flip (PP.<$>) $ PP.string (description c)+ usage (Tree.Node c ns) = subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $+ PP.bold (PP.text $ name c)+ descr c+ | null d = id+ | otherwise = flip (PP.<$>) $ PP.string d+ where+ d = description c nonOpts c = let n = nonOptions $ action c in if null n then id else flip (PP.<+>) $ PP.cat . PP.punctuate PP.space . map PP.text $ n opts c = let o = options $ action c in if null o then id- else flip (PP.<$>) . PP.indent 2 . PP.vsep . map opt $ o+ else flip (PP.<$>) . PP.indent 2 . PP.vsep . map (opt . snd) $ o opt (GetOpt.Option short long a descr) = list 5 "-" (arg id) (map (: []) short) PP.<+> list 20 "--" (arg (PP.equals PP.<>)) long PP.<+> PP.string descr where arg maybeEq = case a of