console-program 0.3.2.0 → 0.4.0.0

raw patch · 6 files changed

+135/−59 lines, 6 filesdep +unixdep −fez-confPVP ok

version bump matches the API change (PVP)

Dependencies added: unix

Dependencies removed: fez-conf

API changes (from Hackage documentation)

Files

• console-program.cabal +25/−22
• src/System/Console/Argument.hs +2/−2
• src/System/Console/Command.hs +15/−4
• src/System/Console/ConfigFile.hs +12/−11
• src/System/Console/Internal.hs +28/−6
• src/System/Console/Program.hs +53/−14

@@ -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

@@ -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

@@ -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). -- 

@@ -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)

@@ -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

@@ -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