diff --git a/console-program.cabal b/console-program.cabal --- a/console-program.cabal +++ b/console-program.cabal @@ -1,12 +1,12 @@ -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: +name: console-program +version: 0.4.0.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: . - declare any number of \"commands\" (modes of operation) of the program; @@ -26,22 +26,21 @@ - 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: 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.*, ansi-wl-pprint >= 0.5 && < 0.7, ansi-terminal >= 0.5 && < 0.7, haskeline == 0.7.*, @@ -49,12 +48,16 @@ utility-ht == 0.0.*, split == 0.2.*, parsec == 3.1.*, - parsec-extra == 0.1.* - Exposed-Modules: + parsec-extra == 0.1.*, + 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 diff --git a/src/System/Console/Argument.hs b/src/System/Console/Argument.hs --- a/src/System/Console/Argument.hs +++ b/src/System/Console/Argument.hs @@ -41,7 +41,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,7 +57,7 @@ :: [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 diff --git a/src/System/Console/Command.hs b/src/System/Console/Command.hs --- a/src/System/Console/Command.hs +++ b/src/System/Console/Command.hs @@ -10,7 +10,8 @@ module System.Console.Command ( Commands,Tree.Tree(Tree.Node) - , Command(Command,name,description,action) + , Command(Command,name,description,action,shorten) + , command , Action , io @@ -22,13 +23,15 @@ import System.Console.Internal ( - Command(Command,name,description,action) + Command(Command,name,description,action,shorten) , Action(Action,run,options,nonOptions,ignoringOptions) , Option(Option) , Identifier + , ConsoleProgramException(UnknownCommand) ) 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 +43,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). -- diff --git a/src/System/Console/ConfigFile.hs b/src/System/Console/ConfigFile.hs --- a/src/System/Console/ConfigFile.hs +++ b/src/System/Console/ConfigFile.hs @@ -5,45 +5,46 @@ 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 (isPrefixOf,concat,break) import Data.List.Split (Splitter,split,whenElt,keepDelimsR) 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 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 Settings 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.fromList . 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) - 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,if null v then Nothing else Just v) diff --git a/src/System/Console/Internal.hs b/src/System/Console/Internal.hs --- a/src/System/Console/Internal.hs +++ b/src/System/Console/Internal.hs @@ -1,29 +1,42 @@ +{-# 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 :: [GetOpt.OptDescr Setting] + , ignoringOptions :: [GetOpt.OptDescr Setting] } -data Identifier = Short Char | Long String +data Identifier + = Short Char + | Long String deriving (Eq,Ord) +type Setting + = (Identifier,Maybe String) + +type Settings + = Map Identifier (Maybe String) + -- | A value of type @Option a@ describes an option, that delivers a value -- to the program of type @a@. data Option a = Option Identifier - (GetOpt.OptDescr (Identifier,Maybe String)) + (GetOpt.OptDescr Setting) a (Maybe String -> Either String a) @@ -39,4 +52,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 diff --git a/src/System/Console/Program.hs b/src/System/Console/Program.hs --- a/src/System/Console/Program.hs +++ b/src/System/Console/Program.hs @@ -1,3 +1,4 @@ +{-# 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 @@ -16,15 +17,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.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) import qualified Data.Map as Map import Data.Traversable (traverse) import qualified Data.Tree as Tree @@ -34,6 +49,7 @@ import System.Environment (getArgs) import System.Exit (exitSuccess) import System.IO (readFile) +import qualified System.Posix.Signals as Sig import qualified Text.Parsec as P import qualified Text.PrettyPrint.ANSI.Leijen as PP @@ -63,21 +79,33 @@ 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) + restArgs when (not $ null errors) . void $ traverse (liftIO . putStrLn) errors - run (action command) nonOpts $ Map.fromList opts + let commandLineSettings = Map.fromList opts + settings = commandLineSettings `Map.union` fileSettings + 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 @@ -93,11 +121,17 @@ -- which will be executed. interactive :: (MonadIO m,Haskeline.MonadException m,Applicative m) => Commands m -> m () interactive commands = do + tid <- liftIO myThreadId + liftIO $ Sig.installHandler Sig.keyboardSignal (Sig.Catch $ throwTo tid UserInterrupt) Nothing 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) maybe (liftIO exitSuccess) return =<< Haskeline.getInputLine ": " @@ -121,10 +155,15 @@ -- | 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