diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010 Petr Rockai + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Console/CmdLib.hs b/System/Console/CmdLib.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib.hs @@ -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 #-} + diff --git a/System/Console/CmdLib/ADTs.hs b/System/Console/CmdLib/ADTs.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib/ADTs.hs @@ -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) :) diff --git a/System/Console/CmdLib/Attribute.hs b/System/Console/CmdLib/Attribute.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib/Attribute.hs @@ -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) + diff --git a/System/Console/CmdLib/Command.hs b/System/Console/CmdLib/Command.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib/Command.hs @@ -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!" diff --git a/System/Console/CmdLib/Flag.hs b/System/Console/CmdLib/Flag.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib/Flag.hs @@ -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 + diff --git a/System/Console/CmdLib/Record.hs b/System/Console/CmdLib/Record.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdLib/Record.hs @@ -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=@ 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) diff --git a/cmdlib.cabal b/cmdlib.cabal new file mode 100644 --- /dev/null +++ b/cmdlib.cabal @@ -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 diff --git a/rectest.sh b/rectest.sh new file mode 100644 --- /dev/null +++ b/rectest.sh @@ -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 diff --git a/testcmd.hs b/testcmd.hs new file mode 100644 --- /dev/null +++ b/testcmd.hs @@ -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 diff --git a/testrec.hs b/testrec.hs new file mode 100644 --- /dev/null +++ b/testrec.hs @@ -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