packages feed

cmdlib (empty) → 0.1

raw patch · 12 files changed

+1493/−0 lines, 12 filesdep +basedep +mtldep +splitsetup-changed

Dependencies added: base, mtl, split, syb

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010 Petr Rockai <me@mornfall.net>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Petr Rockai nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Console/CmdLib.hs view
@@ -0,0 +1,109 @@+-- | A library for setting up a commandline parser and help generator for an+-- application. It aims for conciseness, flexibility and composability. It+-- supports both non-modal and modal (with subcommands -- like darcs, cabal and+-- the like) applications.+--+-- The library supports two main styles of representing flags and+-- commands. These are called "Record" and "ADT", respectively, by the+-- library. The Record representation is more straightforward and easier to use+-- in most instances. The ADT interface is suitable for applications that+-- require exact correspondence between the commandline and its runtime+-- representation, or when an existing application is being ported to cmdlib+-- that is using this style to represent flags.+--+-- Using the Record-based interface, a simple Hello World application could+-- look like this:+--+-- > {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}+-- > import System.Console.CmdLib+-- > import Control.Monad+-- >+-- > data Main = Main { greeting :: String, again :: Bool }+-- >     deriving (Typeable, Data, Eq)+-- >+-- > instance Attributes Main where+-- >     attributes _ = group "Options" [+-- >         greeting %> [ Help "The text of the greeting.", ArgHelp "TEXT"+-- >                     , Default "Hello world!" ],+-- >         again    %> Help "Say hello twice." ]+-- >+-- > instance RecordCommand Main where+-- >     mode_summary _ = "Hello world with argument parsing."+-- >+-- > main = getArgs >>= executeR Main {} >>= \opts -> do+-- >   putStrLn (greeting opts)+--+-- Then, saying ./hello --help will give us:+--+-- > Hello world with argument parsing.+-- >+-- > Options:+-- >     --greeting=TEXT   The text of the greeting. (default: Hello world!)+-- >     --again[=yes|no]  Say hello twice. (default: no)++module System.Console.CmdLib (+  -- * 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+  -- operators (all described in this section).++  Attribute(..), enable, disable, long, short, simple+  , (%%), (%>), (<%), (%+), (+%), everywhere, group++  -- * 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+  -- styles are implemented using "ADTFlag" and "ADT" for the former and+  -- "RecordFlag" and "Record" for the latter. The *Flag classes can be used to+  -- attach attributes to flags and to override the parser for option+  -- arguments. However, an empty instance is valid for both cases. The "ADT"+  -- and "Record" newtype wrappers are then used in a "Command" or+  -- "RecordCommand" instance declaration.++  , ADT, Record, Attributes(..)++  -- * Commands.+  , (%:), commandGroup, Command(..), dispatch, execute, helpCommands, helpOptions++  -- * Record-based commands.+  , RecordCommand(..), RecordMode(..), recordCommands, dispatchR, executeR++  -- * Utilities.+  , globalFlag, readCommon, (<+<), HelpCommand(..), die++  -- * Convenience re-exports.+  , Data, Typeable, getArgs+) where++import System.Console.CmdLib.Attribute+import System.Console.CmdLib.Flag+import System.Console.CmdLib.Command+import System.Console.CmdLib.ADTs+import System.Console.CmdLib.Record++import Data.Data+import Data.Typeable++import Data.IORef+import System.IO.Unsafe+import System.Environment++-- | Create a global setter/getter pair for a flag. The setter can be then+-- passed to the "Global" attribute and the getter used globally to query value+-- of that flag. Example:+--+-- > data Flag = Wibblify Int | Verbose Bool+-- > (setVerbose, isVerbose) = globalFlag False+-- >+-- > instance ADTFlag Flag where+-- >     adt_attrs _ = Verbose %> Global setVerbose+-- >+-- > putVerbose str = isVerbose >>= flip when (putStrLn str)+globalFlag :: a -> (a -> IO (), IO a)+globalFlag def = unsafePerformIO $ do ref <- newIORef def+                                      return (writeIORef ref, readIORef ref)+{-# NOINLINE globalFlag #-}+
+ System/Console/CmdLib/ADTs.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, UndecidableInstances #-}+module System.Console.CmdLib.ADTs where++import System.Console.CmdLib.Attribute+import System.Console.CmdLib.Flag+import System.Console.GetOpt+import Data.Data+import Data.Generics.Aliases( extB )+import Data.Maybe( fromMaybe )++-- | The ADT wrapper type allows use of classic ADTs (algebraic data types) for+-- flag representation. The flags are then passed to the command as a list of+-- values of this type. However, you need to make the type an instance of the+-- Attributes first (if you do not wish to attach any attributes, you may keep+-- the instance body empty). E.g.:+--+-- > data Flag = Simplify | Wibblify Int+-- > instance Attributes where+-- >     attributes _ = Wibblify %> Help "Add a wibblification pass." %+ ArgHelp "intensity" %%+-- >                    Simplify %> Help "Enable a two-pass simplifier."+--+-- The "Command" instances should then use @(ADT Flag)@ for their second type+-- parameter (the flag type).+newtype (Attributes adt) => ADT adt = ADT adt deriving Eq++instance (Eq (ADT adt), Attributes adt, Data adt) => FlagType (ADT adt) where+  type Folded (ADT adt) = [adt]++  flag_attrkey (ADT x) = KeyC $ toConstr x+  flag_empty _ = []+  flag_type (ADT flag) _ = optionType (gmapQ dataTypeOf flag) (gmapQ typeOf flag)++  flag_list = [ ADT $ fromConstr x | x <- dataTypeConstrs $ dataTypeOf (undefined :: adt) ]+  flag_defaults attr = [ (setdef f:) | ADT f <- flag_list, length (gmapQ typeOf f) == 1,+                                       enabled (attr $ ADT f) ]+    where setdef :: adt -> adt+          setdef f = fromConstrB (defvalue $ attrs (ADT f) attr) (toConstr f)++  flag_attrs (ADT flag) = (attrFun $ attributes flag) (KeyC $ toConstr flag) %++                          long (nameFromConstr $ toConstr flag) %++                          defaults++  flag_set (ADT flag) v = (fromConstrB ((error "flag_set" `extB` v) ()) (toConstr flag) :)++  flag_args (ADT flag) attr = case flag_type (ADT flag) attr of+    BooleanOption -> OptArg addoptional ""+    OptionalArgument -> OptArg addoptional ""+    RequiredArgument -> ReqArg add ""+    SimpleOption -> NoArg $ (flag:)++    where reify :: Data a => String -> a+          reify y = fromConstrB (readFlag (undefined :: adt) y) (toConstr flag)+          add x = (reify x :)+          addoptional x = (reify (fromMaybe "" x) :)
+ System/Console/CmdLib/Attribute.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, GADTs, FlexibleInstances,+             PatternGuards, FunctionalDependencies, UndecidableInstances,+             TypeSynonymInstances, OverlappingInstances, Rank2Types #-}+module System.Console.CmdLib.Attribute where++import Prelude hiding ( catch )+import Control.Exception+import Data.Maybe( catMaybes, fromMaybe, listToMaybe )+import Data.List( elemIndex )+import Data.Data+import Data.Generics.Text( gshow )+import Control.Monad.State( evalState, State, get, put )+import System.IO.Unsafe++-- Attributes.++data Attribute =+  -- | Set a list of short flags (single character per flag, like in @-c@,+  -- @-h@) for an option. Without the leading @-@.+  Short [Char]+  -- | Set a list of long flags for an option.+  | Long [String]+  -- | Set a list of long flags for an inversion of the option. Only used for+  -- boolean invertible options. See also "long".+  | InvLong [String]++  -- | Whether this option is invertible. Only applies to boolean options and+  -- defaults to True. (Invertible means that for --foo, there are --no-foo and+  -- --foo=no alternatives. A non-invertible option will only create --foo.)+  | Invertible Bool++  -- | Set help string (one-line summary) for an option. Displayed in help.+  | Help String++  -- | When True, this option will contain the list of non-option arguments+  -- passed to the command. Only applicable to [String]-typed options. Options+  -- marked extra will not show up in help and neither will they be recognized+  -- by their name on commandline.+  | Extra Bool++  -- | 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.+  | Positional Int++  -- | Set the help string for an argument, the @FOO@ in @--wibblify=FOO@.+  | ArgHelp String++  -- | Set default value for this option. The default is only applied when its+  -- type matches the option's parameter type, otherwise it is ignored.+  | forall a. Data a => Default a++  -- | When this attribute is given, the flag's value will be passed to the+  -- provided IO action (which would presumably record the flag's value in a+  -- global IORef for later use). Like with Default, the attribute is only+  -- effective if the parameter type of the provided function matches the+  -- parameter type of the option to which the attribute is applied.+  | forall a. Data a => Global (a -> IO ())++  -- | Whether the option is enabled. Disabled options are not recognized and+  -- are not shown in help (effectively, they do not exist). Used to enable a+  -- subset of all available options for a given command. For Record-based+  -- commands (see "RecordCommand"), this is handled automatically based on+  -- fields available in the command's constructor. Otherwise, constructs like+  --+  -- > enable <% option1 +% option2 +% option3 %% disable <% option4+  --+  -- may be quite useful.+  | Enabled Bool++  -- | Set the group name for this option. The groups are used to section the+  -- help output (the options of a given group are shown together, under the+  -- heading of the group). The ordering of the groups is given by the first+  -- flag of each group. Flags themselves are in the order in which they are+  -- given in the ADT or Record in question.+  | Group String++instance Show Attribute where+  show (Short x) = "Short " ++ show x+  show (Long x) = "Long " ++ show x+  show (InvLong x) = "Long " ++ show x+  show (Invertible x) = "Invertible " ++ show x+  show (Help x) = "Help " ++ show x++  show (ArgHelp x) = "ArgHelp " ++ show x+  show (Default x) = "Default " ++ gshow x++  show (Enabled x) = "Enabled " ++ show x+  show (Group x) = "Group " ++ show x++class (Eq k) => AttributeMapLike k a | a -> k where+  attrFun :: a -> (k -> [Attribute])+  attrKeys :: a -> [k]++data AttributeMap k where+  (:%%) :: (AttributeMapLike k a, AttributeMapLike k b) => a -> b -> AttributeMap k+  SingletonMap :: (AttributeMapLike k a) => a -> AttributeMap k+  EmptyMap :: AttributeMap k++-- | Join attribute mappings. E.g. @Key1 %> Attr1 %+ Attr2 %% Key2 %> Attr3 %++-- Attr4@. Also possible is @[ Key1 %> Attr1, Key2 %> Attr2 ] %% Key3 %>+-- Attr3@, or many other variations.+(%%) :: (AttributeMapLike k a, AttributeMapLike k b) => a -> b -> AttributeMap k+(%%) = (:%%)++instance (Eq k) => AttributeMapLike k [(k, [Attribute])] where+  attrKeys = map fst+  attrFun pairs = foldl pair (const []) [ \x -> if x == k then a else [] | (k, a) <- pairs ]+    where pair f g k = f k ++ g k++instance (Eq k) => AttributeMapLike k (k -> [Attribute]) where+  attrKeys _ = [] -- can't extract...+  attrFun = id++instance (AttributeMapLike k x) => AttributeMapLike k [x] where+  attrKeys l = concatMap attrKeys l+  attrFun l = \k -> concat $ zipWith ($) (map attrFun l) (repeat k)++instance (Eq k) => AttributeMapLike k (AttributeMap k) where+  attrKeys (a :%% b) = attrKeys a ++ attrKeys b+  attrKeys (SingletonMap x) = attrKeys x+  attrKeys EmptyMap = []+  attrFun (a :%% b) = \k -> attrFun a k ++ attrFun b k+  attrFun (SingletonMap x) = attrFun x+  attrFun EmptyMap = const []++getattr :: a -> (Attribute -> Maybe a) -> [Attribute] -> a+getattr def proj a = fromMaybe def $ go a+  where go (x:xs) | Just k <- proj x = Just k+                  | otherwise = go xs+        go [] = Nothing++enabled    = getattr False       $ \k -> case k of    Enabled j -> Just j ; _ -> Nothing+extra      = getattr False       $ \k -> case k of      Extra j -> Just j ; _ -> Nothing+longs      = getattr []          $ \k -> case k of       Long j -> Just j ; _ -> Nothing+shorts     = getattr []          $ \k -> case k of      Short j -> Just j ; _ -> Nothing+invlongs   = getattr []          $ \k -> case k of    InvLong j -> Just j ; _ -> Nothing+invertible = getattr True        $ \k -> case k of Invertible j -> Just j ; _ -> Nothing+helpattr   = getattr "(no help)" $ \k -> case k of       Help j -> Just j ; _ -> Nothing+arghelp    = getattr "X"         $ \k -> case k of    ArgHelp j -> Just j ; _ -> Nothing+getgroup   = getattr "Options"   $ \k -> case k of      Group j -> Just j ; _ -> Nothing+positional = getattr Nothing     $ \k -> case k of Positional j -> Just (Just j) ; _ -> Nothing++defvalue :: (Typeable a, Data a) => [Attribute] -> a+defvalue attr+  | (Default v:rem) <- [ x | x@(Default _) <- attr ] = case cast v of+    Nothing -> defvalue rem+    Just v' -> v'+  | otherwise = error "No default value."++setglobal :: [Attribute] -> (forall a. (Typeable a, Data a) => a) -> IO ()+setglobal (Global set:rem) value = set value >> setglobal rem value+setglobal (_:rem) value = setglobal rem value+setglobal [] _ = return ()++-- | Create a group. This extracts all the keys that are (explicitly) mentioned+-- in the body of the group and assigns the corresponding Group attribute to+-- them. Normally used like this:+--+-- > group "Group name" [ option %> Help "some help"+-- >                    , another %> Help "some other help" ]+--+-- Do not let the type confuse you too much. :)+group :: forall k a. (AttributeMapLike k a) => String -> a -> AttributeMap k+group name amap = foldl (%%) (SingletonMap amap) (map addgrp $ attrKeys amap)+  where addgrp :: k -> AttributeMap k+        addgrp key = SingletonMap [(key, [Group name])]++-- | For convenience. Same as "Enabled" True.+enable :: Attribute+enable = Enabled True++-- | For convenience. Same as "Enabled" False.+disable :: Attribute+disable = Enabled False++simple :: [Attribute]+simple = Invertible False %+ Default False++-- | For convenience. Same as "Long" ["foo"] %+ "InvLong" ["no-foo"]+long :: String -> [Attribute]+long n = Long [n] %+ InvLong ["no-" ++ n]++-- | For convenience. Same as "Short" ['x']+short :: Char -> Attribute+short n = Short [n]++class AttributeList a where+  toAttributes :: a -> [Attribute]++instance AttributeList Attribute where+  toAttributes = (:[])++instance AttributeList [Attribute] where+  toAttributes = id++-- | Join multiple attributes into a list. Available for convenience (using+-- [Attribute] directly works just as well if preferred, although this is not+-- the case with keys, see @"+%"@).+(%+) :: (AttributeList a, AttributeList b) => a -> b -> [Attribute]+a %+ b = toAttributes a ++ toAttributes b+infixl 9 %+++attrs :: k -> (k -> [Attribute]) -> [Attribute]+attrs = flip ($)++data Key = KeyC Constr | KeyF TypeRep String+         deriving (Eq, Show)++class ToKey a where+  toKey :: a -> Key++instance (Data a) => ToKey a where+  toKey = KeyC . toConstr++-- | Attach a (list of) attributes to a key. The key is usually either an ADT+-- constructor (for use with "ADTFlag"-style flags) or a record selector (for+-- use with "RecordFlag"s).+--+-- > data RFlags = Flags { wibblify :: Int, simplify :: Bool }+-- > data AFlag = Simplify | Wibblify Int+-- > rattr = wibblify %> Help "Add a wibblification pass." (%% ...)+-- > aattr = Wibblify %> Help "Add a wibblification pass." (%% ...)+--+-- @"%+"@ can be used to chain multiple attributes:+--+-- > attrs = wibblify %> Help "some help" %+ Default (3 :: Int) %+ ArgHelp "intensity"+--+-- But lists work just as fine:+--+-- > attrs = wibblify %> [ Help "some help", Default (3 :: Int), ArgHelp "intensity" ]+(%>) :: (ToKey k, AttributeList attr) => k -> attr -> AttributeMap Key+key %> attr = SingletonMap [(toKey key, toAttributes attr)]++class Keys a where+  toKeys :: a -> [Key]++instance (ToKey a) => Keys a where+  toKeys x = [toKey x]++instance Keys [Key] where+  toKeys = id++-- | Attach an attribute to multiple keys: written from right to left,+-- i.e. @Attribute <% Key1 +% Key2@. Useful for setting up option groups+-- (although using "group" may be more convenient in this case) and option+-- enablement.+(<%) :: forall keys. (Keys keys) => Attribute -> keys -> AttributeMap Key+attr <% keys = SingletonMap $ zip (toKeys keys) (repeat [attr])++-- | Join multiple keys into a list, e.g. @Key1 +% Key2@. Useful with @"<%"@ to+-- list multiple (possibly heterogenously-typed) keys.+(+%) :: forall a b. (Keys a, Keys b) => a -> b -> [Key]+a +% b = toKeys a ++ toKeys b++infixl 8 %>+infixl 8 <%+infixl 7 %%++-- | Set an attribute on all keys.+everywhere :: (Eq k) => Attribute -> AttributeMap k+everywhere attr = SingletonMap $ const [attr]++instance (Data a, Data b) => ToKey (a -> b) where+  toKey f | Just field <- fieldname = KeyF (typeOf (undefined :: a)) field+          | Just constr <- constructor = KeyC constr+          | otherwise = error $ "ToKey: " +++                                show (typeOf (undefined :: a)) ++ " -> " +++                                show (typeOf (undefined :: b))+    where constrs = dataTypeConstrs $ dataTypeOf (undefined :: a)+          fieldname = listToMaybe $ catMaybes [ nameIn c | c <- constrs ]+          isup a = unsafePerformIO $+                         (undefined `fmap` evaluate a)+                          `catch` (\(e :: SomeException) -> case show e of+                             "up" -> return True+                             _ -> return False)+          {-# NOINLINE isup #-}+          iospoon a = unsafePerformIO $+                         (Just `fmap` evaluate a) `catch` (\(e :: SomeException) -> return Nothing)+          {-# NOINLINE iospoon #-}+          spooned c = [ isup (f $ (test c i)) | i <- [0..(length (constrFields c) - 1)] ]+          nameIn c = elemIndex True (spooned c) >>= \i -> return (constrFields c !! i)+          test :: forall b. (Data b) => Constr -> Int -> b+          test c i = evalState (gmapM (subst i) (fromConstr c)) 0+          subst :: forall x. Data x => Int -> x -> State Int x+          subst i _ = do x <- get+                         res <- if x == i then return $ error "up" else return $ error "down"+                         put $ x + 1+                         return res+          constructor = iospoon $ toConstr (f undefined)+
+ System/Console/CmdLib/Command.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE ScopedTypeVariables, GADTs, MultiParamTypeClasses, FunctionalDependencies,+             FlexibleInstances, UndecidableInstances, OverlappingInstances, DeriveDataTypeable,+             FlexibleContexts #-}+module System.Console.CmdLib.Command where++import System.Console.CmdLib.Attribute+import System.Console.CmdLib.Flag+import System.Console.GetOpt+import Data.Typeable+import Data.List( sort )+import Data.Char( toLower )+import Control.Monad( when )+import System.IO( hPutStrLn, stderr )+import System.Exit++-- | 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+-- this library is concerned, although you may choose to store information in+-- it.+--+-- To parse the commandline for a given command, see "execute". The basic usage+-- can look something like this:+--+-- > data Flag = Summary | Unified Bool | LookForAdds Bool+-- > instance ADTFlag Flag+-- >+-- > [...]+-- >+-- > data Whatsnew = Whatsnew deriving Typeable+-- >+-- > instance Command Whatsnew (ADT Flag) where+-- >  options _ =  enable <% Summary +% Unified +% LookForAdds+-- >  summary _ = "Create a patch from unrecorded changes."+-- >+-- >  run _ f opts = do putStrLn $ "Record."+-- >                    putStrLn $ "Options: " ++ show f+-- >                    putStrLn $ "Non-options: " ++ show opts++class (Typeable cmd, FlagType flag) => Command cmd flag | cmd -> flag where+  -- | An "Attribute" mapping for flags provided by the @flag@ type parameter.+  options :: cmd -> AttributeMap Key+  options _ = EmptyMap++  -- | Set this to True if the command is a supercommand (i.e. expects another+  -- subcommand). Defaults to False. Supercommands can come with their own+  -- options, which need to appear between the supercommand and its+  -- subcommand. Any later options go to the subcommand. The "run" (and+  -- "description") method of a supercommand should use "dispatch" and+  -- "helpCommands" respectively (on its list of subcommands) itself.+  supercommand :: cmd -> Bool+  supercommand _ = False++  -- | 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 ()++  -- | Provides the commands' short synopsis.+  synopsis :: cmd -> String+  synopsis _ = ""++  -- | Provides a short (one-line) description of the command. Used in help+  -- output.+  summary :: cmd -> String+  summary _ = ""++  help :: cmd -> String+  help _ = ""++  -- | The name of the command. Normally derived automatically from @cmd@, but+  -- may be overriden.+  cmdname :: cmd -> String+  cmdname c = map toLower $ reverse . takeWhile (/= '.') . reverse . show $ typeOf c++  -- | A convenience "undefined" of the command, for use with "Commands".+  cmd :: cmd+  cmd = undefined++  cmd_flag_empty :: cmd -> Folded flag+  cmd_flag_empty _ = flag_empty (undefined :: flag)++cmdoptions :: (Command cmd flag) => cmd -> (Key -> [Attribute])+cmdoptions = attrFun . options++helpOptions :: forall cmd f. Command cmd f => cmd -> String+helpOptions cmd = unlines $ [ x | x <- [summary cmd, syn cmd, help cmd], not $ null x ] ++ opts+    where cmd_attrs :: f -> [Attribute]+          cmd_attrs = cmdoptions cmd . flag_attrkey+          syn c | null (synopsis c) = ""+                | otherwise = "Usage: " ++ synopsis c+          opts | null opts' = []+               | otherwise = "" : map (uncurry usageInfo) opts'+          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+        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+  | 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+        (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+                     | (f, n) <- positions ]+        opts'filtered = removemany opts' (reverse $ sort $ map snd positions)+        removemany l (n:ns) = removemany (remove l n) ns+        removemany l [] = l+        remove l n = let (a, b) = splitAt n l in (a ++ drop 1 b)+        defaults :: [Folded f -> Folded f]+        defaults = flag_defaults attrs+        cmd_attrs :: f -> [Attribute]+        cmd_attrs = cmdoptions cmd . flag_attrkey+        attrs :: f -> [Attribute]+        attrs = attrFun (cmd_attrs %% flag_attrs)++-- | Parse options for and execute a single command (see "Command"). May be+-- useful for programs that do not need command-based "dispatch", but still+-- make use of the "Command" class to describe themselves. Handles @--help@+-- internally. You can use this as the entrypoint if your application is+-- non-modal (i.e. it has no subcommands).+execute :: forall cmd f. (Command cmd f) => cmd -> [String] -> IO ()+execute cmd opts = execute' cmd opts >>= \f -> case f of+  Just (flags, opts') -> run cmd flags opts'+  Nothing -> return ()++class Commands a where+  toCommands :: a -> [CommandWrap]++data CommandWrap where+  CommandWrap :: (Command a f, Typeable (Folded f)) => a -> CommandWrap+  CommandGroup :: String -> [CommandWrap] -> CommandWrap++instance Commands CommandWrap where+  toCommands = (:[])++instance Commands [CommandWrap] where+  toCommands = id++instance (Command c f, Typeable (Folded f)) => Commands c where+  toCommands c = [CommandWrap c]++-- | Chain commands into a list suitable for "dispatch" and "helpCommands". E.g.:+--+-- > dispatch (Command1 %: Command2 %: Command3) opts+(%:) :: (Commands a, Commands b) => a -> b -> [CommandWrap]+a %: b = toCommands a ++ toCommands b++commandGroup :: (Commands a) => String -> a -> [CommandWrap]+commandGroup s l = [CommandGroup s (toCommands l)]++-- TODO: disambiguation, hidden commands (aliases)+findCommand :: String -> [CommandWrap] -> Maybe CommandWrap+findCommand key (c@(CommandWrap cmd):comms) | key == cmdname cmd = Just c+                                             | otherwise = findCommand key comms+findCommand key (CommandGroup _ comms:comms')+  | Just c <- findCommand key comms = Just c+  | otherwise = findCommand key comms'+findCommand _ [] = Nothing++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' comms (cmd:opts) =+  case findCommand cmd comms of+    Nothing -> printCommands comms >> die ("No such command " ++ cmd) >> return Nothing+    Just x -> return $ Just (x, opts)++-- | 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+  Nothing -> return ()+  Just (CommandWrap c, opts') -> execute c opts'++-- | Helper for dying with an error message (nicely, at least compared to+-- "fail" in IO).+die :: String -> IO a+die msg = do hPutStrLn stderr ("FATAL: " ++ trim msg)+             exitWith (ExitFailure 1)+             return (error "unreachable")+  where trim msg | last msg == '\n' = trim $ init msg+                 | otherwise = msg++data HelpCommand = HelpCommand 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!"
+ System/Console/CmdLib/Flag.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}+module System.Console.CmdLib.Flag where++import System.Console.CmdLib.Attribute+import System.Console.GetOpt+import Data.Typeable+import Data.Data++import Data.List.Split( splitOn )+import Data.List( nub, intercalate, isSuffixOf )+import Data.Char( isUpper, toLower )+import Data.Generics.Aliases( extR )+import Data.Generics.Text( gshow )++newtype PathF = PathF String deriving (Typeable, Data)++defaults = [ Default ""+           , Default (0 :: Int)+           , Default False+           , Default ([] :: [Int])+           , Default ([] :: [String])+           , Enabled True ]++data OptionType = SimpleOption | BooleanOption | OptionalArgument | RequiredArgument | BadOption+                deriving Eq++class Attributes a where+  attributes :: a -> AttributeMap Key+  attributes _ = EmptyMap+  readFlag :: Data b => a -> String -> b+  readFlag _ = readCommon++class (Eq flag) => FlagType flag where+  type Folded flag :: *++  flag_attrkey :: flag -> Key+  flag_attrs :: flag -> [Attribute]++  flag_args :: flag -> [Attribute] -> ArgDescr (Folded flag -> Folded flag)+  flag_set :: (Typeable a) => flag -> a -> (Folded flag -> Folded flag)+  flag_value :: (Typeable a) => flag -> Folded flag -> a+  flag_type :: flag -> [Attribute] -> OptionType+  flag_list :: [flag]+  flag_defaults :: (flag -> [Attribute]) -> [Folded flag -> Folded flag]+  flag_defaults _ = []+  flag_empty :: flag -> Folded flag++instance FlagType () where+  type Folded () = ()+  flag_list = []++optionType :: [DataType] -> [TypeRep] -> OptionType+optionType dt t = case (dt, t) of+    ([], []) -> SimpleOption+    ([_], [t]) | typeRepTyCon t == typeRepTyCon (typeOf True) -> BooleanOption+    ([_], [t]) | typeRepTyCon t == typeRepTyCon (typeOf (Just ())) -> OptionalArgument+    ([_], _) -> RequiredArgument+    _ -> BadOption++nonoption attr x+  | True <- extra (attr x) = True+  | Just _ <- positional (attr x) = True+  | otherwise = False++optDescr :: FlagType flag => (flag -> [Attribute]) -> [OptDescr (Folded flag -> Folded flag)]+optDescr attr = concat [ one x | x <- flag_list, enabled $ attr x ]+  where one x = case flag_type x (attr x) of+          BooleanOption -> [ Option [] (invlongs $ attr x) (NoArg $ flag_set x False) ""+                           , Option (shorts $ attr x) (longs $ attr x) (flag_args x (attr x)) ""]+          _ | nonoption attr x -> []+          _ -> [Option (shorts $ attr x) (longs $ attr x) (flag_args x (attr x)) ""]++-- | Controls how to display boolean options in help output: MergePrefix shows+-- --[no-]foo, MergeSuffix shows --foo[=yes|no] and NoMerge shows two lines,+-- first with --foo and help, second with --no-foo (and no further help).+data HelpStyle = MergePrefix | MergeSuffix | NoMerge deriving Eq++helpDescr :: FlagType flag => HelpStyle -> (flag -> [Attribute]) -> [(String, [OptDescr ()])]+helpDescr style attr = [ grp g | g <- nub $ map getgroup+                                      [ attr f | f <- flag_list, enabled $ attr f ] ]+  where one x | BooleanOption <- flag_type x (attr x), NoMerge <- style =+                  [ Option (shorts $ attr x) (longs $ attr x) (args x) (help x)+                  , Option [] (invlongs $ attr x) (NoArg ()) "" ]+              | BooleanOption <- flag_type x (attr x), MergePrefix <- style =+                  [ Option (shorts $ attr x) (ziplongs (longs $ attr x) (invlongs $ attr x))+                           (NoArg ()) (help x) ]+              | nonoption attr x = []+              | otherwise = [Option (shorts $ attr x) (longs $ attr x) (args x) (help x)]+        merge p ns =+             "[" ++ intercalate "/" [ take (length n - length p) n | n <- ns ] ++ "]" ++ p+        ziplongs [] [] = []+        ziplongs (p:ps) ns = merge p (takeWhile (p `isSuffixOf`) ns)+                               : ziplongs ps (dropWhile (p `isSuffixOf`) ns)+        grp g = (g, concat [ one x | x <- flag_list, enabled $ attr x, getgroup (attr x) == g ])+        help x | BooleanOption <- flag_type x (attr x) = summary ++ " (default: " ++ booldef ++ ")"+               | (defvalue $ attr x) /= "" && flag_type x (attr x) /= SimpleOption =+                   summary ++ " (default: " ++ (defvalue $ attr x) ++ ")"+               | otherwise = summary+          where summary = helpattr $ attr x+                booldef = if defvalue $ attr x then "yes" else "no"+        args x = case flag_type x (attr x) of+            BooleanOption | MergeSuffix <- style -> OptArg (const ()) "yes|no"+                          | otherwise -> NoArg ()+            OptionalArgument -> OptArg (const ()) (arghelp $ attr x)+            RequiredArgument -> ReqArg (const ()) (arghelp $ attr x)+            SimpleOption -> NoArg ()++-- | The default parser for option arguments. Handles strings, string lists+-- (always produces single-element list), integers, booleans (@yes|true|1@ vs+-- @no|false|0@), PathF and integer lists (@--foo=1,2,3@).+readCommon :: (Data a) => String -> a+readCommon = (\x -> error $ "readflag: " ++ gshow x)+             <+< string <+< optional string+             <+< int <+< optional int+             <+< bool <+< optional bool+             <+< path <+< optional path+             <+< strlist <+< optional strlist+             <+< list int <+< optional (list int)+    where string = id+          int = read :: String -> Int+          bool b | b `elem` ["yes", "true", "1", ""] = True+                 | b `elem` ["no", "false", "0"] = False+          path = PathF+          strlist = (:[])+          list w str = map w (splitOn "," str)++(<+<) :: (Typeable a, Typeable b, Monad m) => m a -> m b -> m a+(<+<) = extR+infixl 8 <+<++optional _ "" = Nothing+optional f x = Just $ f x++hyphenate (x:xs) | isUpper x = '-' : toLower x : hyphenate xs+                 | otherwise = x : hyphenate xs+hyphenate [] = []++-- | Extract a long option name from an ADT constructor using its name. For+-- @Foo@, you will get @foo@ and on @FooBar@ will get @foo-bar@.+nameFromConstr :: Constr -> String+nameFromConstr ctor = map toLower (take 1 name) ++ hyphenate (drop 1 name)+  where name = showConstr ctor+
+ System/Console/CmdLib/Record.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, MultiParamTypeClasses, DeriveDataTypeable,+             Rank2Types, FlexibleContexts, UndecidableInstances #-}+module System.Console.CmdLib.Record where+import System.Console.CmdLib.Attribute+import System.Console.CmdLib.Command+import System.Console.GetOpt+import Data.Data+import Data.List( nub, elemIndex )+import Control.Monad.State( evalState, get, put, State, execState )+import Data.Maybe( fromMaybe, fromJust )+import System.Exit++import System.Console.CmdLib.Flag++append :: forall a. (Data a) => a -> a -> a+append a = any <+< list+  where any = const a+        list :: (Typeable b) => b -> [String]+        list = (++(fromJust $ cast a)) . fromJust . cast++-- | This wrapper type allows use of record types (single or multi-constructor)+-- for handling flags. Each field of the record is made into a single flag of+-- the corresponding type. The record needs to be made an instance of the+-- "Attributes" class. That way, attributes can be attached to the field+-- selectors, although when used with RecordCommand, its "rec_options" method+-- can be used as well and the Attributes instance left empty.+--+-- > data Flags = Flags { wibblify :: Int, simplify :: Bool }+-- > instance Attributes Flags where+-- >     attributes _ =+-- >        wibblify %> Help "Add a wibblification pass." %+ ArgHelp "intensity" %%+-- >        simplify %> Help "Enable a two-pass simplifier."+--+-- A single value of the Flags type will then be passed to the "Command"+-- instances (those that use @Record Flags@ as their second type parameter),+-- containing the value of the rightmost occurence for each of the flags.+--+-- TODO: List-based option types should be accumulated instead of overriden.+data (Attributes rec) => Record rec = Record rec String deriving Eq++instance (Eq (Record rec), Data rec, Attributes rec) => FlagType (Record rec) where+  type Folded (Record rec) = rec++  flag_attrkey (Record _ f) = KeyF (typeOf (undefined :: rec)) f++  flag_list = [ Record undefined field |+                field <- nub $ concatMap constrFields+                         (dataTypeConstrs $ dataTypeOf (undefined :: rec)) ]++  flag_type f@(Record rec field) attr =+      fixup $ optionType [gmapQi idx dataTypeOf x] [gmapQi idx typeOf x]+    where constr = head [ ctor | ctor <- dataTypeConstrs $ dataTypeOf rec+                               , field `elem` constrFields ctor ]+          idx = fromMaybe (error $ "BUG: Getting type of nonexistent field " ++ field) $+                    elemIndex field $ constrFields constr+          x :: rec = fromConstr constr+          fixup BooleanOption | False <- invertible attr = SimpleOption+          fixup x = x++  flag_defaults attr = map setfield flag_list+    where setdef :: forall a. (Data a) => Record rec -> a+          setdef flag = defvalue $ attrs flag attr+          setfield flag@(Record _ field) rec = setField field rec (setdef flag)++  flag_attrs (Record _ name) = (attrFun $ attributes (undefined :: rec))+                               (KeyF (typeOf (undefined :: rec)) name) %++                               long (hyphenate name) %+ defaults++  flag_value (Record _ field) folded = getField field folded+  flag_set (Record _ field) v = \x -> setField field x (errcast v)+     where errcast x = case cast x of+                           Just x -> x+                           Nothing -> error "BUG: flag_set in Record used with wrong value type"++  flag_args f@(Record flag field) attr = case flag_type (Record flag field) attr of+    BooleanOption -> OptArg setoptional ""+    OptionalArgument -> OptArg setoptional ""+    RequiredArgument -> ReqArg setlist ""+    SimpleOption -> NoArg $ flag_set f True+   where set str v = setField field v (readFlag (undefined :: rec) str)+         setlist str v = setField field v (append (readFlag (undefined :: rec) str) (flag_value f v))+         setoptional str = set (fromMaybe "" str)++  flag_empty _ = fromConstr $ head $ dataTypeConstrs $ dataTypeOf (undefined :: rec)++-- | A bridge that allows multi-constructor record types to be used as a+-- description of a command set. In such a type, each constructor corresponds+-- to a single command and its fields to its options. To describe a program+-- with two commands, @foo@ and @bar@, each taking a @--wibble@ boolean option+-- and @bar@ also taking a @--text=<string>@ option, you can write:+--+-- > data Commands = Foo { wibble :: Bool }+-- >               | Bar { wibble :: Bool, text :: String }+-- >+-- > instance RecordCommand Commands where (...)+--+-- You should at least implement @run'@, @rec_options@ and @mode_summary@ are optional.++class (Data cmd) => RecordCommand cmd where+  -- | @run'@ is your entrypoint into the whole set of commands. You can+  -- dispatch on the command by looking at the constructor in @cmd@:+  --+  -- > run' cmd@(Foo {}) _ = putStrLn $ "Foo running. Wibble = " ++ show (wibble cmd)+  -- > run' cmd@(Bar {}) _ = putStrLn "This is bar."+  run' :: cmd -> [String] -> IO ()++  -- | You can also provide extra per-command flag attributes (match on the+  -- constructor like with @run'@). The attributes shared by various commands+  -- can be set in "rec_attrs" in "Attributes" instead.+  rec_options :: cmd -> AttributeMap Key+  rec_options _ = EmptyMap++  -- | Provide a help string for each mode. Used in help output. Again, pattern+  -- match like in @run'@.+  mode_summary :: cmd -> String+  mode_summary _ = "(no summary available)"++data RecordMode cmd = RecordMode { rec_cmdname :: String+                                 , rec_initial :: Constr }+                    deriving (Typeable)++instance (Eq (Record cmd), RecordCommand cmd, Data cmd, Attributes cmd)+         => Command (RecordMode cmd) (Record cmd) where+  cmdname = rec_cmdname+  run _ = run'++  summary cmd = mode_summary $ (fromConstr $ rec_initial cmd :: cmd)++  options cmd = rec_options ctor %% available %% everywhere disable+    where available = [ (KeyF (typeOf (undefined :: cmd)) opt, [enable])+                      | opt <- constrFields $ rec_initial cmd]+          ctor = (fromConstr $ rec_initial cmd :: cmd)++  cmd_flag_empty cmd = fromConstr $ rec_initial cmd++-- | Construct a command list (for "dispatch"/"helpCommands") from a+-- multi-constructor record data type. See also "RecordCommand".+recordCommands :: forall cmd. (Eq (Record cmd), Data cmd, RecordCommand cmd, Attributes cmd) => cmd -> [CommandWrap]+recordCommands _ = go $ dataTypeConstrs $ dataTypeOf (undefined :: cmd)+    where go = map $ CommandWrap . rec_cmd+          rec_cmd :: Constr -> RecordMode cmd+          rec_cmd x = RecordMode { rec_cmdname = nameFromConstr x+                                 , rec_initial = x }++-- | Record field update using a string field name. Sets a field value in a+-- record, using a (string) name of the field,+setField :: forall rec a. (Data rec) => String -> rec -> (forall b. (Data b) => b) -> rec+setField field current value = evalState (gmapM subst current) (constrFields $ toConstr current)+    where subst :: Data x => x -> State [String] x+          subst f = do x:xs <- get+                       put xs+                       if x == field then return value else return f++data Imp = Imp Int (forall a. (Typeable a) => a)++getField :: forall rec a. (Data rec, Typeable a) => String -> rec -> a+getField field value = case execState (gmapM find value) (Imp 0 (error "")) of Imp _ v -> v+    where idx = elemIndex field $ constrFields (toConstr value)+          find :: Data x => x -> State Imp x+          find f = do Imp i val <- get+                      if (Just i == idx) then put $ Imp (i + 1) (errcast f)+                                         else put $ Imp (i + 1) val+                      return $ error "find"+          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+  Nothing -> exitWith ExitSuccess >> return undefined+  Just (CommandWrap x, opts') -> execute' x opts' >>= \c -> case c of+    Just (command, _) -> return $ fromMaybe (error "bla") (cast command)+    Nothing -> exitWith ExitSuccess >> return undefined++executeR :: forall cmd. (Eq (Record cmd), Attributes cmd, RecordCommand cmd) => cmd -> [String] -> IO cmd+executeR cmd opts = execute' cmd' opts >>= \c -> case c of+  Just (command, _) -> return command+  Nothing -> exitWith ExitSuccess >> return undefined+  where cmd' = RecordMode (nameFromConstr $ toConstr cmd) (toConstr cmd)
+ cmdlib.cabal view
@@ -0,0 +1,48 @@+name:                cmdlib+version:             0.1+synopsis:            a library for command line parsing & online help++description: An alternative to cmdargs, based on getopt. Comes with a powerful+             attribute system. Supports complex interfaces with many options+             and commands, with option & command grouping, while at the same+             time keeping simple things simple.++-- The license under which the package is released.+-- copyright:+license:             BSD3+license-file:        LICENSE++-- The package author(s).+author:              Petr Rockai+maintainer:          me@mornfall.net+category:            System+build-type:          Simple++extra-source-files: rectest.sh++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.6++Library+  exposed-modules: System.Console.CmdLib+  other-modules: System.Console.CmdLib.Attribute+                 System.Console.CmdLib.Flag+                 System.Console.CmdLib.Command+                 System.Console.CmdLib.ADTs+                 System.Console.CmdLib.Record++  build-depends: base < 5, syb, mtl, split++flag test+  default:     False+  description: Build test binaries++Executable cmdlib-test+  if !flag(test)+     buildable: False+  main-is: testcmd.hs++Executable cmdlib-rectest+  if !flag(test)+     buildable: False+  main-is: testrec.hs
+ rectest.sh view
@@ -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
+ testcmd.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, MultiParamTypeClasses,+             DeriveDataTypeable, FlexibleInstances #-}+module Main where+import Prelude hiding ( readFile )++import Data.Char+import System.Console.CmdLib hiding ( Record )++data Flag = Name String | Author String | RemoveTestDirectory Bool+          | Test Bool | All | Pipe | Interactive Bool+          | Matches String | Patches String                       -- Matching+          | SshCm Bool | HttpPipelining Bool | RemoteDarcs String -- Network+          | TrustTimes Bool                                       -- Advanced+    deriving (Typeable, Data, Show, Eq)++matching = Matches +% Patches+network = SshCm +% HttpPipelining +% RemoteDarcs++ann cmd f opts = do putStrLn $ "command: " ++ cmd+                    putStr $ unlines $ map disp f+                    putStrLn $ "non-options: " ++ unwords opts+                 where disp x = drop 1 (hyphenate ctor) ++ ":" ++ rest+                         where ctor = takeWhile (/=' ') (show x)+                               rest = dropWhile (/=' ') (show x)+                       hyphenate (x:xs) | isUpper x = '-' : toLower x : hyphenate xs+                                        | otherwise = x : hyphenate xs+                       hyphenate [] = []++instance Attributes Flag where+  attributes _ =+    Name        %> Help "specify the name of patch" %+ short 'm' %+ ArgHelp "NAME"    %%+    Author      %> Help "specify author identity"                                     %%+    Test        %> Help "run the test script"                                         %%+    All         %> Help "answer yes to all patches" %+ short 'a'                      %%+    Pipe        %> Help "ask user interactively for the patch metadata"               %%+    Interactive %> Help "prompt user interactively" %+ Default True                   %%++    Group "Matching patches" <% matching                                              %%+    Matches     %> Help "select patches matching PATTERN" %+ ArgHelp "PATTERN"        %%+    Patches     %> Help "select patches matching REGEXP" %+ ArgHelp "REGEXP"          %%++    Group "Network options" <% network                                                %%+    SshCm       %> Help "use SSH ControlMaster feature"                               %%+    RemoteDarcs %> Help "name/path of the remote darcs binary"+                %+ Default "darcs" %+ ArgHelp "BINARY"                                %%+    HttpPipelining+                %> Help "enable HTTP pipelining" %+ Default True                      %%++    Group "Advanced options" <% RemoveTestDirectory +% TrustTimes                     %%+    RemoveTestDirectory+                %> Help "remove the test directory" %+ Default True                   %%+    TrustTimes  %> Help "trust the file modification times" %+ Default True           %%++    everywhere disable++data Record = Record deriving Typeable+data Pull = Pull deriving Typeable+data Push = Push deriving Typeable+data ShowCmd = ShowCmd deriving Typeable++data ShowRepo deriving Typeable+data ShowContents deriving Typeable++show_subcommands = (cmd :: ShowRepo) %: (cmd :: ShowContents)++instance Command ShowCmd (ADT Flag) where+  summary      _ = "Show information which is stored by darcs."+  help         _ = "Subcommands:\n" ++ helpCommands show_subcommands+  cmdname      _ = "show" -- override+  supercommand _ = True++  run _ f opts = dispatch show_subcommands opts++instance Command Record (ADT Flag) where+  options _ =  enable <% Name +% Author +% Test +% RemoveTestDirectory +% All +% Pipe +%+                         Interactive +% TrustTimes+  summary _ = "Create a patch from unrecorded changes."++  run _ = ann "record"++instance Command Pull (ADT Flag) where+  options _  =  enable <% matching +% network +% TrustTimes+  summary _  = "Copy and apply patches from another repository to this one."+  synopsis _ = "darcs pull [OPTION]... [REPOSITORY]..."++  run _ = ann "pull"++instance Command Push (ADT Flag) where+  options _  =  enable <% matching +% network+  summary _  = "Copy and apply patches from this repository to another one."+  run _ = ann "push"++instance Command ShowRepo (ADT Flag) where+  cmdname      _ = "repo"+  summary      _ = "Show repository summary information"+  run _          = ann "show repo"++instance Command ShowContents (ADT Flag) where+  cmdname      _ = "contents"+  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++main = getArgs >>= dispatch commands
+ testrec.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, MultiParamTypeClasses,+             DeriveDataTypeable, FlexibleInstances #-}+module Main where+import Prelude hiding ( readFile, all, last )++import Data.Char+import Data.List ( isPrefixOf )+import Data.List.Split ( splitOn )+import System.Console.CmdLib hiding ( Record, disable )+import qualified System.Console.CmdLib as Cmd++data ApplyAs = ApplyAs String | ApplyAsSelf deriving (Typeable, Data, Show, Eq)+data Conflicts = Mark | Allow | Disallow deriving (Typeable, Data, Show, Eq)+data Posthook = Always | Never | Prompt deriving (Typeable, Data, Show, Eq)++newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord, Typeable, Data, Show)+data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord, Typeable, Data, Show)++data Flag = Flag+  { test :: Bool+  , onlyToFiles :: Bool+  , removeTestDirectory :: Bool++  -- matching several+  , all :: Bool+  , matches :: String+  , patches :: String+  , tags :: String++  -- matching one+  , match :: String+  , patch :: String+  , tag :: String++  -- matching range+  , toMatch :: String+  , fromMatch :: String+  , fromPatch :: String+  , toPatch :: String+  , fromTag :: String+  , toTag :: String++  -- matching numerically+  , last :: Int+  , maxCount :: Int+  , index :: (Int,Int)++  , context :: AbsolutePath++  -- bundle sending/output+  , to :: String+  , cc :: String+  , output :: AbsolutePathOrStd+  , outputAutoName :: Maybe AbsolutePath+  , subject :: String+  , inReplyTo :: String+  , sendmailCmd :: String++  -- recording+  , author :: String+  , name :: String+  , logfile :: AbsolutePath+  , deleteLogfile :: Bool+  , pipe :: Bool++  -- amend+  , keepDate :: Bool++  -- add+  , recursive :: Bool+  , dateTrick :: Bool+  , boring :: Bool+  , caseOk :: Bool+  , reservedOk :: Bool++  -- push/pull/apply+  , setDefault :: Bool+  , applyAs :: ApplyAs+  , conflicts :: Conflicts+  , skipConflicts :: Bool+  , externalMerge :: String+  , setScriptsExecutable :: Bool++  -- repo combinators+  , union :: Bool+  , complement :: Bool+  , intersection :: Bool++  -- output+  , number :: Bool+  , count :: Bool++  -- misc+  , distName :: String+  , trustTimes :: Bool+  , dryRun :: Bool+  , disable :: Bool+  , promptForDependencies :: Bool++  -- hooks+  , runPosthook :: Posthook+  , posthook :: String++  -- network+  , sshCm :: Bool+  , httpPipelining :: Bool+  , remoteDarcs :: String++  -- verbosity & debugging+  , timings :: Bool+  , verbosity :: Int+  , debug :: Bool+  , debugHttp :: Bool++  } deriving (Typeable, Data, Show, Eq)++matchSeveral = matches +% patches +% tags +% all+matchRange = toMatch +% fromMatch +% toPatch +% fromPatch +% toTag +% fromTag+matchOne = match +% patch +% tag+matchNum = maxCount +% last +% index+apply = conflicts +% skipConflicts +% externalMerge +% setScriptsExecutable+posthooks = posthook +% runPosthook+reposet = intersection +% complement +% union++network = sshCm +% httpPipelining +% remoteDarcs++ann cmd f opts = do putStrLn $ "command = " ++ cmd+                    putStrLn $ disp (unwords . drop 1 . words $ show f)+                    putStrLn $ "non-options = " ++ unwords opts+                 where disp ('{':r) = disp r+                       disp ('}':r) = disp r+                       disp (',':' ':r) = '\n':disp r+                       disp (x:xs) = x:disp xs+                       disp [] = []++instance Attributes Flag where+  readFlag _ = readCommon <+< applyas <+< interval+    where applyas "self" = ApplyAsSelf+          applyas x | "user" `isPrefixOf` x = ApplyAs (drop 5 x)+                    | otherwise = error $ "Error decoding --apply-as argument " +++                                          x ++ ". Expected \"self\" or \"user:STRING\""+          interval :: String -> (Int, Int)+          interval str = case splitOn "-" str of+            [x, y] -> (read x, read y)+            _ -> error $ "Error parsing interval " ++ str++  attributes _ =++    group "Options" [+      name   %> [ short 'm', Help "specify the name of patch", ArgHelp "NAME" ],+      author %> [ short 'A', Help "specify author identity" ],+      test   %> [            Help "run the test script" ],+      all    %> [ short 'a', Help "answer yes to all patches",+                             InvLong ["interactive", "no-all"] ],+      pipe   %> [            Help "ask user interactively for the patch metadata" ] %+ simple+    ] %%++    group "Matching patches" [+      matches    %> [ Help "select patches matching PATTERN", ArgHelp "PATTERN" ],+      patches    %> [ Help "select patches matching REGEXP",  ArgHelp "REGEXP"  ],+      tags       %> [ Help "select tags matching REGEXP",     ArgHelp "REGEXP"  ]+    ] %%++    group "Network options" [+      sshCm          %> Help "use SSH ControlMaster feature",+      remoteDarcs    %> [ Help "name/path of the remote darcs binary"+                        , Default "darcs", ArgHelp "BINARY" ],+      httpPipelining %> [ Help "enable HTTP pipelining", Default True ]+    ] %%++    group "Applying patches" [+      conflicts      %> [ Help "how to treat conflicts", ArgHelp "allow|mark|disallow" ],+      externalMerge  %> [ Help "use external tool to merge conflicts", ArgHelp "COMMAND" ],+      skipConflicts  %> Help "filter out any patches that would create conflicts"+    ] %%++    group "Advanced options" [+      removeTestDirectory %> [ Help "remove the test directory", Default True ],+      trustTimes          %> [ Help "trust the file modification times", Default True+                             , InvLong ["ignore-times", "no-trust-times"] ],+      disable             %> Help "disable this command"+    ] %%++    group "Verbosity control" [+      verbosity %> Help "set verbosity level",+      debug     %> Help "give debug output",+      debugHttp %> Help "give debug output for libcurl (HTTP)",+      timings   %> Help "provide debugging timings information"+    ] %%++    enable <% verbosity +% debug +% disable %% everywhere Cmd.disable+    %% everywhere (Default (-1 :: Int, -1 :: Int))+    %% everywhere (Default $ AbsolutePath "")+    %% everywhere (Default $ APStd)+    %% everywhere (Default $ (Nothing :: Maybe AbsolutePath))+    %% everywhere (Default ApplyAsSelf)+    %% everywhere (Default Mark)+    %% everywhere (Default Never)++data Record = Record deriving Typeable+data Pull = Pull deriving Typeable+data Push = Push deriving Typeable+data Changes = Changes deriving Typeable+data Apply = Apply deriving Typeable+data ShowCmd = ShowCmd deriving Typeable++data ShowRepo deriving Typeable+data ShowContents deriving Typeable++show_subcommands = (cmd :: ShowRepo) %: (cmd :: ShowContents)++instance Command ShowCmd (Cmd.Record Flag) where+  summary      _ = "Show information which is stored by darcs."+  help         _ = "Subcommands:\n" ++ helpCommands show_subcommands+  cmdname      _ = "show" -- override+  supercommand _ = True++  run _ f opts = dispatch show_subcommands opts++instance Command Record (Cmd.Record Flag) where+  options _ =  enable <% name +% author +% test +% removeTestDirectory +% all +% pipe+                      +% trustTimes+  summary _ = "Create a patch from unrecorded changes."++  run _ = ann "record"++instance Command Pull (Cmd.Record Flag) where+  options _  =  enable <% matchSeveral +% network +% trustTimes +% apply +% posthooks+                       +% promptForDependencies +% reposet+  summary _  = "Copy and apply patches from another repository to this one."+  synopsis _ = "darcs pull [OPTION]... [REPOSITORY]..."++  run _ = ann "pull"++instance Command Push (Cmd.Record Flag) where+  options _  =  enable <% matchSeveral +% network+  summary _  = "Copy and apply patches from this repository to another one."+  run _ = ann "push"++instance Command Changes (Cmd.Record Flag) where+  options _  =  enable <% matchSeveral +% matchRange +% matchNum+  summary _  = "List patches in the repository."+  run     _  = ann "changes"++instance Command Apply (Cmd.Record Flag) where+  options _  =  enable <% matchSeveral +% matchRange +% matchNum +% apply+  summary _  = "Apply a patch bundle created by `darcs send'."+  run     _  = ann "apply"++instance Command ShowRepo (Cmd.Record Flag) where+  cmdname      _ = "repo"+  summary      _ = "Show repository summary information"+  run _          = ann "show repo"++instance Command ShowContents (Cmd.Record Flag) where+  cmdname      _ = "contents"+  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 %: Apply)+        %: commandGroup "Querying the repository:"+                   (Changes %: ShowCmd)++main = getArgs >>= dispatch commands