cmdlib 0.1 → 0.2

raw patch · 11 files changed

+136/−90 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• System/Console/CmdLib.hs +17/−6
• System/Console/CmdLib/ADTs.hs +1/−0
• System/Console/CmdLib/Attribute.hs +2/−3
• System/Console/CmdLib/Command.hs +48/−20
• System/Console/CmdLib/Flag.hs +1/−0
• System/Console/CmdLib/Record.hs +6/−3
• cmdlib.cabal +6/−2
• rectest.sh +0/−41
• testcmd.hs +9/−9
• testrec.hs +5/−6
• testrec.sh +41/−0

@@ -42,8 +42,18 @@ -- >     --again[=yes|no]  Say hello twice. (default: no)  module System.Console.CmdLib (-  -- * Attributes.+  -- * News+  --+  -- | Since version 0.2: The Positional arguments are no longer required to be+  -- strings. A default (fallback) command may be provided to+  -- "dispatch"/"dispatchR" (this has also incompatibly changed their+  -- signature, sorry about that! I have tried to make this extensible+  -- though...). The "help" command can now be disabled (dispatch [noHelp]+  -- ...). Commands can now specify how to process options: permuted,+  -- non-permuted or no options at all. See "optionStyle". +  -- * Attributes+  --   -- | To each flag, a number of attributes can be attached. Many reasonable   -- defaults are provided by the library. The attributes are described by the   -- "Attribute" type and are attached to flags using @"%>"@ and the related@@ -52,7 +62,7 @@   Attribute(..), enable, disable, long, short, simple   , (%%), (%>), (<%), (%+), (+%), everywhere, group -  -- * Flags.+  -- * Flags    -- | Flags (commandline options) can be represented in two basic styles,   -- either as a plain ADT (algebraic data type) or as a record type. These two@@ -65,16 +75,17 @@    , ADT, Record, Attributes(..) -  -- * Commands.+  -- * Commands   , (%:), commandGroup, Command(..), dispatch, execute, helpCommands, helpOptions+  , noHelp, defaultCommand, OptionStyle(..) -  -- * Record-based commands.+  -- * Record-based commands   , RecordCommand(..), RecordMode(..), recordCommands, dispatchR, executeR -  -- * Utilities.+  -- * Utilities   , globalFlag, readCommon, (<+<), HelpCommand(..), die -  -- * Convenience re-exports.+  -- * Convenience re-exports   , Data, Typeable, getArgs ) where 

@@ -41,6 +41,7 @@                           defaults    flag_set (ADT flag) v = (fromConstrB ((error "flag_set" `extB` v) ()) (toConstr flag) :)+  flag_parse (ADT flag) str = (fromConstrB (readFlag (undefined :: adt) str) (toConstr flag) :)    flag_args (ADT flag) attr = case flag_type (ADT flag) attr of     BooleanOption -> OptArg addoptional ""

@@ -40,9 +40,8 @@    -- | When set, this option will not show up on help and won't create a flag   -- (similar to Extra), but instead it will contain the n-th non-option-  -- argument. The argument used up by such positional option will not show up-  -- in the list of non-option arguments. (Currently) only works with-  -- String-typed flags.+  -- argument. The argument used up by such a positional option will not show+  -- up in the list of non-option arguments.   | Positional Int    -- | Set the help string for an argument, the @FOO@ in @--wibblify=FOO@.

@@ -9,10 +9,14 @@ import Data.Typeable import Data.List( sort ) import Data.Char( toLower )+import Data.Maybe( fromJust, isNothing ) import Control.Monad( when ) import System.IO( hPutStrLn, stderr ) import System.Exit +-- | How to process options for a command. See "optionStyle" for details.+data OptionStyle = Permuted | NonPermuted | NoOptions deriving Eq+ -- | A class that describes a single (sub)command. The @cmd@ type parameter is -- just for dispatch (and the default command name is derived from this type's -- name, but this can be overriden). It could be an empty data decl as far as@@ -51,10 +55,21 @@   supercommand :: cmd -> Bool   supercommand _ = False +  -- | How to process options for this command. "NoOptions" disables option+  -- processing completely and all arguments are passed in the [String]+  -- parameter to "run". "Permuted" collects everything that looks like an+  -- option (starts with a dash) and processes it. The non-option arguments are+  -- filtered and passed to run like above. Finally, "NonPermuted" only+  -- processes options until a first non-option argument is encountered. The+  -- remaining arguments are passed unchanged to run.+  optionStyle :: cmd -> OptionStyle+  optionStyle _ = Permuted+   -- | The handler that actually runs the command. Gets the @setup@ value as   -- folded from the processed options (see "Combine") and a list of non-option   -- arguments.   run :: cmd -> Folded flag -> [String] -> IO ()+  run cmd _ _ = die $ "BUG: Command " ++ cmdname cmd ++ " not implemented."    -- | Provides the commands' short synopsis.   synopsis :: cmd -> String@@ -94,28 +109,29 @@           opts' = [ (grp ++ ":", getopt) |                     (grp, getopt@(_:_)) <- helpDescr MergeSuffix $ attrFun (cmd_attrs %% flag_attrs) ] -helpCommands x = unlines $ map one x-  where one (CommandWrap c) = "    " ++ pad (cmdname c) ++ "  " ++ summary c-        one (CommandGroup name l) = name ++ ":\n" ++ helpCommands l+helpCommands x = concat $ map one x+  where one (CommandWrap c) = "    " ++ pad (cmdname c) ++ "  " ++ summary c ++ "\n"+        one (CommandGroup name l) = "\n" ++ name ++ ":\n" ++ helpCommands l         pad str = (take 15 $ str ++ replicate 15 ' ') ++ " "  execute' :: forall cmd f. (Command cmd f) => cmd -> [String] -> IO (Maybe (Folded f, [String])) execute' cmd opts   | "--help" `elem` opts && not (supercommand cmd) = printHelp cmd >> return Nothing   | ("--help":_) <- opts = printHelp cmd >> return Nothing+  | NoOptions <- optionStyle cmd = return $ Just (foldr ($) (cmd_flag_empty cmd) defaults, opts)   | otherwise = do case errs of                      [] -> do sequence_ [ setglobal (attrs f) (flag_value f flags') | f <- flag_list ]                               return $ Just (flags', opts'filtered)                      _ -> die (concat errs) >> return Nothing   where getopts = optDescr attrs-        order = if supercommand cmd then RequireOrder else Permute+        order = if supercommand cmd || (optionStyle cmd == NonPermuted) then RequireOrder else Permute         (flags, opts', errs) = getOpt order getopts opts         flags' = foldr ($) (cmd_flag_empty cmd) (positions' ++ extras ++ reverse flags ++ defaults)         extras :: [Folded f -> Folded f]         extras = [ if extra (attrs f) then flag_set f opts'filtered else id                  | f :: f <- flag_list, enabled $ attrs f ]         positions = [ (f, n) | f <- flag_list, enabled $ attrs f, Just n <- [positional $ attrs f] ]-        positions' = [ if (length opts' > n) then flag_set f (opts' !! n) else id+        positions' = [ if (length opts' > n) then flag_parse f (opts' !! n) else id                      | (f, n) <- positions ]         opts'filtered = removemany opts' (reverse $ sort $ map snd positions)         removemany l (n:ns) = removemany (remove l n) ns@@ -175,25 +191,33 @@ printHelp c = putStr $ helpOptions c printCommands comms = putStr $ helpCommands comms -dispatch' :: [CommandWrap] -> [String] -> IO (Maybe (CommandWrap, [String]))-dispatch' comms [] = printCommands comms >> die "Command required." >> return Nothing-dispatch' comms ["help"] = printCommands comms >> return Nothing-dispatch' comms ("help":cmd:_) =-  case findCommand cmd comms of-    Nothing -> printCommands comms >> die ("No such command " ++ cmd) >> return Nothing-    Just (CommandWrap comm) -> printHelp comm >> return Nothing+dispatch' :: [DispatchOpt] -> [CommandWrap] -> [String] -> IO (Maybe (CommandWrap, [String]))+dispatch' dopt comms' args = case args of+  [] | isNothing def -> dieHelp "Command required."+     | otherwise -> return $ Just (fromJust def, [])+  ("--help":_) -> printCommands comms >> return Nothing+  (cmd:args') -> case findCommand cmd comms of+    Nothing -> case def of+      Nothing -> dieHelp $ "No such command " ++ cmd+      Just x -> return $ Just (x, args)+    Just x -> return $ Just (x, args')+  where comms | null [ () | NoHelp <- dopt ] = HelpCommand comms %: comms'+              | otherwise = comms'+        dieHelp msg = printCommands comms >> die msg >> return Nothing+        def | (DefaultCommand n:_) <- [ o | o@(DefaultCommand _) <- dopt ] = Just n+            | otherwise = Nothing -dispatch' comms (cmd:opts) =-  case findCommand cmd comms of-    Nothing -> printCommands comms >> die ("No such command " ++ cmd) >> return Nothing-    Just x -> return $ Just (x, opts)+data DispatchOpt = NoHelp | DefaultCommand CommandWrap+noHelp = NoHelp+defaultCommand :: (Command f x, Typeable (Folded x)) => f -> DispatchOpt+defaultCommand = DefaultCommand . CommandWrap  -- | Given a list of commands (see @"%:"@) and a list of commandline arguments, -- dispatch on the command name, parse the commandline options (see "execute") -- and transfer control to the command.  This function also implements the -- @help@ pseudocommand.-dispatch :: [CommandWrap] -> [String] -> IO ()-dispatch comms opts = dispatch' comms opts >>= \c -> case c of+dispatch :: [DispatchOpt] -> [CommandWrap] -> [String] -> IO ()+dispatch dopt comms opts = dispatch' dopt comms opts >>= \c -> case c of   Nothing -> return ()   Just (CommandWrap c, opts') -> execute c opts' @@ -206,10 +230,14 @@   where trim msg | last msg == '\n' = trim $ init msg                  | otherwise = msg -data HelpCommand = HelpCommand deriving Typeable+data HelpCommand = HelpCommand [CommandWrap] deriving Typeable  instance Command HelpCommand () where   cmdname   _ = "help"   synopsis  _ = "help [command]"   summary   _ = "show help for a command or commands overview"-  run   _ _ _ = die "BUG: Help should never run!"+  run (HelpCommand comms) _ args = case args of+    [] -> printCommands comms+    (cmd:_) -> case findCommand cmd comms of+      Nothing -> printCommands comms >> die ("No such command " ++ cmd)+      Just (CommandWrap comm) -> printHelp comm

@@ -38,6 +38,7 @@    flag_args :: flag -> [Attribute] -> ArgDescr (Folded flag -> Folded flag)   flag_set :: (Typeable a) => flag -> a -> (Folded flag -> Folded flag)+  flag_parse :: flag -> String -> (Folded flag -> Folded flag)   flag_value :: (Typeable a) => flag -> Folded flag -> a   flag_type :: flag -> [Attribute] -> OptionType   flag_list :: [flag]

@@ -72,6 +72,8 @@                            Just x -> x                            Nothing -> error "BUG: flag_set in Record used with wrong value type" +  flag_parse f@(Record _ field) str v = setField field v (readFlag (undefined :: rec) str)+   flag_args f@(Record flag field) attr = case flag_type (Record flag field) attr of     BooleanOption -> OptArg setoptional ""     OptionalArgument -> OptArg setoptional ""@@ -164,9 +166,10 @@           errcast :: forall a b. (Typeable a, Typeable b) => a -> b           errcast = fromMaybe (error $ "BUG: getField used with wrong type on " ++ field) . cast -dispatchR :: forall cmd f. (Eq (Record cmd), Attributes cmd, RecordCommand cmd, Command (RecordMode cmd) f,-                            Folded f ~ cmd) => cmd -> [String] -> IO cmd-dispatchR _ opts = dispatch' (recordCommands (undefined :: cmd)) opts >>= \c -> case c of+dispatchR :: forall cmd f. (Eq (Record cmd), Attributes cmd, RecordCommand cmd,+                            Command (RecordMode cmd) f,+                            Folded f ~ cmd) => [DispatchOpt] -> cmd -> [String] -> IO cmd+dispatchR dopt _ opts = dispatch' dopt (recordCommands (undefined :: cmd)) opts >>= \c -> case c of   Nothing -> exitWith ExitSuccess >> return undefined   Just (CommandWrap x, opts') -> execute' x opts' >>= \c -> case c of     Just (command, _) -> return $ fromMaybe (error "bla") (cast command)

@@ -1,5 +1,5 @@ name:                cmdlib-version:             0.1+version:             0.2 synopsis:            a library for command line parsing & online help  description: An alternative to cmdargs, based on getopt. Comes with a powerful@@ -18,10 +18,14 @@ category:            System build-type:          Simple -extra-source-files: rectest.sh+extra-source-files: testrec.sh  -- Constraint on the version of Cabal needed to build this package. cabal-version:       >=1.6++source-repository head+  type:     darcs+  location: http://repos.mornfall.net/cmdlib  Library   exposed-modules: System.Console.CmdLib

@@ -1,41 +0,0 @@-#!/bin/bash--attrib() {-    key=$1-    shift-    echo -n ">> "-    grep "$key" rectest.out | grep "$*"-}--run() {-    ./dist/build/cmdlib-rectest/cmdlib-rectest "$@" > rectest.out-}--set -ev--run pull --intersection-attrib httpPipelining True-attrib intersection True-attrib sshCm False--run pull --ssh-cm=yes-attrib sshCm True--run pull --ssh-cm-attrib sshCm True--run pull --no-http-pipelining-attrib httpPipelining False--run record --author "Au" -A "Author"-attrib author Author-run record -A "Author" --author 'TehAuthor!'-attrib author TehAuthor--run record foo bar-attrib non-options foo bar-run record foo bar --author me blah-attrib non-options foo bar blah-attrib author me--rm rectest.out

@@ -69,7 +69,7 @@   cmdname      _ = "show" -- override   supercommand _ = True -  run _ f opts = dispatch show_subcommands opts+  run _ f opts = dispatch [] show_subcommands opts  instance Command Record (ADT Flag) where   options _ =  enable <% Name +% Author +% Test +% RemoveTestDirectory +% All +% Pipe +%@@ -100,12 +100,12 @@   summary      _ = "Outputs a specific version of a file."   run _          = ann "show contents" -commands =  commandGroup "Commands" HelpCommand-        %: commandGroup "Copying changes between the working copy and the repository"-                   Record-        %: commandGroup "Copying patches between repositories with working copy update"-                   (Pull %: Push)-        %: commandGroup "Querying the repository:"-                   ShowCmd+commands =+  commandGroup "Copying changes between the working copy and the repository"+  Record+  %: commandGroup "Copying patches between repositories with working copy update"+  (Pull %: Push)+  %: commandGroup "Querying the repository:"+  ShowCmd -main = getArgs >>= dispatch commands+main = getArgs >>= dispatch [] commands

@@ -215,7 +215,7 @@   cmdname      _ = "show" -- override   supercommand _ = True -  run _ f opts = dispatch show_subcommands opts+  run _ f opts = dispatch [] show_subcommands opts  instance Command Record (Cmd.Record Flag) where   options _ =  enable <% name +% author +% test +% removeTestDirectory +% all +% pipe@@ -257,12 +257,11 @@   summary      _ = "Outputs a specific version of a file."   run _          = ann "show contents" -commands =  commandGroup "Commands" HelpCommand-        %: commandGroup "Copying changes between the working copy and the repository"-                   Record+commands = commandGroup "Copying changes between the working copy and the repository"+           Record         %: commandGroup "Copying patches between repositories with working copy update"                    (Pull %: Push %: Apply)-        %: commandGroup "Querying the repository:"+        %: commandGroup "Querying the repository"                    (Changes %: ShowCmd) -main = getArgs >>= dispatch commands+main = getArgs >>= dispatch [] commands

@@ -0,0 +1,41 @@+#!/bin/bash++attrib() {+    key=$1+    shift+    echo -n ">> "+    grep "$key" rectest.out | grep "$*"+}++run() {+    ./dist/build/cmdlib-rectest/cmdlib-rectest "$@" > rectest.out+}++set -ev++run pull --intersection+attrib httpPipelining True+attrib intersection True+attrib sshCm False++run pull --ssh-cm=yes+attrib sshCm True++run pull --ssh-cm+attrib sshCm True++run pull --no-http-pipelining+attrib httpPipelining False++run record --author "Au" -A "Author"+attrib author Author+run record -A "Author" --author 'TehAuthor!'+attrib author TehAuthor++run record foo bar+attrib non-options foo bar+run record foo bar --author me blah+attrib non-options foo bar blah+attrib author me++rm rectest.out