packages feed

console-program 0.3.0.1 → 0.3.1.0

raw patch · 5 files changed

+45/−31 lines, 5 files

Files

console-program.cabal view
@@ -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
src/System/Console/Argument.hs view
@@ -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
src/System/Console/Command.hs view
@@ -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   }
src/System/Console/Internal.hs view
@@ -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
src/System/Console/Program.hs view
@@ -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 ()