diff --git a/console-program.cabal b/console-program.cabal --- a/console-program.cabal +++ b/console-program.cabal @@ -1,5 +1,5 @@ Name: console-program -Version: 0.3.0.1 +Version: 0.3.1.0 Cabal-Version: >= 1.6 License: BSD3 Author: Arie Peterson 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 @@ -43,11 +43,6 @@ , defaultValue :: Maybe a -- ^ The default value, when the option occurs without option argument. -- @Nothing@ means that an argument is required for this type of option. - -- - -- Note that this may be different from the corresponding value in the default - -- configuration (the first argument of 'System.Console.Command.execute'); - -- the latter is what you get when this option does not occur at all in the - -- configuration file or command line. } instance Functor Type where 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 @@ -16,13 +16,14 @@ , io , withNonOption , withOption + , ignoreOption ) where import System.Console.Internal ( Command(Command,name,description,action) - , Action(Action,run,options,nonOptions) + , Action(Action,run,options,nonOptions,ignoringOptions) , Option(Option) , Identifier ) @@ -41,7 +42,7 @@ -- | A simple action, taking no argument, and having no options. io :: IO () -> Action -io h = Action r [] [] where +io h = Action r [] [] [] where r [] _ = h r rest _ = putStrLn e >> exitFailure where e = "Error: unused non-option or unrecognised command: " ++ unwords rest @@ -64,6 +65,7 @@ (Argument.defaultValue at) , nonOptions = Argument.name at : nonOptions (f undefined) , options = options (f undefined) + , ignoringOptions = ignoringOptions (f undefined) } -- | Create an action that takes an option. @@ -78,4 +80,16 @@ Right a -> run (f a) nonOpts opts , nonOptions = nonOptions (f undefined) , options = optDescr : options (f undefined) + , ignoringOptions = ignoringOptions (f undefined) + } + +-- | Create an action that allows, but ignores, the given option. +-- +-- This is especially useful if this option is given in the configuration +-- file, but is meant for other commands; then this action will not give an +-- error message about an unrecognised option. +ignoreOption :: Option a -> Action -> Action +ignoreOption (Option _ g _ _) a = a + { + ignoringOptions = g : ignoringOptions a } 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 @@ -10,9 +10,10 @@ data Action = Action { - run :: [String] -> Map Identifier (Maybe String) -> IO () - , nonOptions :: [String] - , options :: [GetOpt.OptDescr (Identifier,Maybe String)] + run :: [String] -> Map Identifier (Maybe String) -> IO () + , nonOptions :: [String] + , options :: [GetOpt.OptDescr (Identifier,Maybe String)] + , ignoringOptions :: [GetOpt.OptDescr (Identifier,Maybe String)] } data Identifier = Short Char | Long String 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 @@ -18,11 +18,11 @@ import System.Console.Command (Commands,Command) import System.Console.ConfigFile (readFromFile) -import System.Console.Internal (run,options,nonOptions,action,description,name) +import System.Console.Internal (run,options,nonOptions,ignoringOptions,action,description,name) import Control.Applicative ((<|>),(*>)) import Control.Arrow ((&&&),second) -import Control.Monad (when) +import Control.Monad (when,void) import Control.Monad.Trans.Class (lift) import qualified Data.Map as Map import Data.Traversable (traverse) @@ -31,7 +31,7 @@ import qualified System.Console.GetOpt as GetOpt import qualified System.Console.Haskeline as Haskeline import System.Environment (getArgs) -import System.Exit (exitFailure,exitSuccess) +import System.Exit (exitSuccess) import System.IO (readFile) import qualified Text.Parsec as P import qualified Text.PrettyPrint.ANSI.Leijen as PP @@ -63,11 +63,13 @@ parse commands args = do let (commandString,command,restArgs) = select commands args fileArgs <- readFromFile commands commandString - let (opts,nonOpts,errors) = GetOpt.getOpt GetOpt.Permute (options $ action command) (fileArgs ++ restArgs) - let optsMap = Map.fromList opts - when (not $ null errors) $ - traverse putStrLn errors >> exitFailure - run (action command) nonOpts optsMap + let (opts,nonOpts,errors) = GetOpt.getOpt + GetOpt.Permute + (options (action command) ++ ignoringOptions (action command)) + (fileArgs ++ restArgs) + when (not $ null errors) . void $ + traverse putStrLn errors + run (action command) nonOpts $ Map.fromList opts -- Select the right command from the command tree, and return the rest of the command line. select :: Commands -> [String] -> ([String],Command,[String]) @@ -77,12 +79,10 @@ Just cs -> let (xs',c,rest) = select cs xs in (x : xs',c,rest) -- | Load the configuration file (if present), and run the command given on --- the command line. +-- the command line. Settings on the command line override the configuration +-- file. -- -- You may use this function, applied to your tree of available commands, as your @main@ function. --- --- Settings in the configuration file override the default configuration; --- settings on the command line override both. single :: Commands -> IO () single commands = parse commands =<< getArgs @@ -93,14 +93,12 @@ interactive commands = do Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one where - one = do - lift $ ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity] - lift $ putStr $ name (Tree.rootLabel commands) - lift $ ANSI.setSGR [ANSI.Reset] - line <- maybe (lift exitSuccess) return =<< Haskeline.getInputLine ": " - case words' line of - Left e -> lift $ putStrLn e - Right ws -> lift $ parse commands ws + one = getLine' >>= \ line -> case words' line of + Left e -> lift $ putStrLn e + Right ws -> lift $ parse commands ws + getLine' = do + lift . putStrBold $ name (Tree.rootLabel commands) + maybe (lift exitSuccess) return =<< Haskeline.getInputLine ": " words' :: String -> Either String [String] words' = either (Left . show) Right . P.parse p "" where @@ -112,6 +110,12 @@ quote = P.char '"' escape = P.char '\\' escaped x = escape *> x + +putStrBold :: String -> IO () +putStrBold x = do + ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + putStr x + ANSI.setSGR [ANSI.Reset] -- | Print usage info for the program to stdout. showUsage :: Commands -> IO ()