cmdlib 0.3.1 → 0.3.2
raw patch · 7 files changed
+286/−96 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ System.Console.CmdLib: Required :: Bool -> Attribute
+ System.Console.CmdLib: mode_synopsis :: RecordCommand cmd => cmd -> Maybe String
+ System.Console.CmdLib: noAttributes :: AttributeMap k
Files
- System/Console/CmdLib.hs +9/−1
- System/Console/CmdLib/ADTs.hs +5/−2
- System/Console/CmdLib/Attribute.hs +17/−8
- System/Console/CmdLib/Command.hs +84/−37
- System/Console/CmdLib/Flag.hs +129/−36
- System/Console/CmdLib/Record.hs +41/−11
- cmdlib.cabal +1/−1
System/Console/CmdLib.hs view
@@ -43,6 +43,11 @@ module System.Console.CmdLib ( -- * News+ -- | Since version 0.3.2: Added a new Required attribute for mandatory+ -- flags/arguments to be used in record-based commands. Also added automatic+ -- "synopsis" derivation for record-based commands, which includes all flags+ -- and options. Flag values are evaluated during parsing now, providing early+ -- error reporting. Unambiguous command prefixes are now accepted. -- -- | Since version 0.3.1: "rec_optionStyle" and "rec_superCommand" have been -- added to the "RecordCommand" class, granting more flexibility to@@ -83,7 +88,7 @@ -- the "Attributes" class, which can be used to attach attributes to the -- flags. - , ADT, Record, Attributes(..)+ , ADT, Record, Attributes(..), noAttributes -- * Commands , (%:), commandGroup, Command(..), dispatch, dispatchOr, execute, helpCommands, helpOptions@@ -113,6 +118,9 @@ import Data.IORef import System.IO.Unsafe import System.Environment++-- | Use 'noAttributes' specify an empty attribute set. Available since 0.3.2.+noAttributes = EmptyMap -- | 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
System/Console/CmdLib/ADTs.hs view
@@ -4,6 +4,7 @@ import System.Console.CmdLib.Attribute import System.Console.CmdLib.Flag import System.Console.GetOpt+import Control.Exception ( throw ) import Data.Data import Data.Generics.Aliases( extB ) import Data.Maybe( fromMaybe )@@ -34,7 +35,9 @@ 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)+ setdef f = fromConstrB (if required (attr $ ADT f)+ then throw RequiredArgException+ else defvalue $ attrs (ADT f) attr) (toConstr f) flag_attrs (ADT flag) = (attrFun $ attributes flag) (KeyC $ toConstr flag) %+ long (nameFromConstr $ toConstr flag) %+@@ -47,7 +50,7 @@ BooleanOption -> OptArg addoptional "" OptionalArgument -> OptArg addoptional "" RequiredArgument -> ReqArg add ""- SimpleOption -> NoArg $ (flag:)+ SimpleOption -> NoArg (flag:) where reify :: Data a => String -> a reify y = fromConstrB (readFlag (undefined :: adt) y) (toConstr flag)
System/Console/CmdLib/Attribute.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, GADTs, FlexibleInstances, PatternGuards, FunctionalDependencies, UndecidableInstances,- TypeSynonymInstances, OverlappingInstances, Rank2Types #-}+ TypeSynonymInstances, OverlappingInstances, Rank2Types,+ DeriveDataTypeable #-} module System.Console.CmdLib.Attribute where import Prelude hiding ( catch )@@ -44,6 +45,11 @@ -- up in the list of non-option arguments. | Positional Int + -- | When True, this option will require that the argument must be provided.+ -- If the argument is also Positional, any preceeding Positional arguments+ -- should also be Required.+ | Required Bool+ -- | Set the help string for an argument, the @FOO@ in @--wibblify=FOO@. | ArgHelp String @@ -89,8 +95,11 @@ show (Enabled x) = "Enabled " ++ show x show (Group x) = "Group " ++ show x +data RequiredArgException = RequiredArgException deriving (Show, Typeable)+instance Exception RequiredArgException+ class (Eq k) => AttributeMapLike k a | a -> k where- attrFun :: a -> (k -> [Attribute])+ attrFun :: a -> k -> [Attribute] attrKeys :: a -> [k] data AttributeMap k where@@ -114,8 +123,8 @@ 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)+ attrKeys = concatMap attrKeys+ attrFun l = concat . zipWith ($) (map attrFun l) . repeat instance (Eq k) => AttributeMapLike k (AttributeMap k) where attrKeys (a :%% b) = attrKeys a ++ attrKeys b@@ -140,13 +149,13 @@ 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+required = getattr False $ \k -> case k of Required 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'+ | (Default v:rem) <- [ x | x@(Default _) <- attr ] =+ fromMaybe (defvalue rem) (cast v) | otherwise = error "No default value." setglobal :: [Attribute] -> (forall a. (Typeable a, Data a) => a) -> IO ()@@ -279,7 +288,7 @@ 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)] ]+ 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
System/Console/CmdLib/Command.hs view
@@ -1,18 +1,21 @@ {-# LANGUAGE ScopedTypeVariables, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverlappingInstances, DeriveDataTypeable,- FlexibleContexts #-}+ FlexibleContexts, TupleSections, Rank2Types #-} 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.Either ( partitionEithers )+import Data.List( sort, intercalate, isPrefixOf ) import Data.Char( toLower ) import Data.Maybe( fromJust, isNothing )-import Control.Monad( when )+import Control.Monad( when, forM_, void )+import Control.Exception ( evaluate, catch, SomeException ) import System.IO( hPutStrLn, stderr ) import System.Exit+import Prelude hiding ( catch ) -- | How to process options for a command. See "optionStyle" for details. data OptionStyle = Permuted | NonPermuted | NoOptions deriving Eq@@ -73,7 +76,8 @@ -- | Provides the commands' short synopsis. synopsis :: cmd -> String- synopsis _ = ""+ synopsis c = unwords $ cmdname c : opts where+ opts = usageDescr $ attrFun (cmdattrs c %% flag_attrs) -- | Provides a short (one-line) description of the command. Used in help -- output.@@ -95,24 +99,25 @@ cmd_flag_empty :: cmd -> Folded flag cmd_flag_empty _ = flag_empty (undefined :: flag) -cmdoptions :: (Command cmd flag) => cmd -> (Key -> [Attribute])+cmdoptions :: (Command cmd flag) => cmd -> Key -> [Attribute] cmdoptions = attrFun . options +cmdattrs :: forall cmd f . Command cmd f => cmd -> f -> [Attribute]+cmdattrs cmd = cmdoptions cmd . flag_attrkey+ 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) = ""+ where 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) ]+ (grp, getopt@(_:_)) <- helpDescr MergeSuffix $ attrFun (cmdattrs cmd %% flag_attrs) ] -helpCommands x = concat $ map one x+helpCommands x = concatMap one x where one (CommandWrap c) = " " ++ pad (cmdname c) ++ " " ++ summary c ++ "\n" one (CommandGroup name l) = "\n" ++ name ++ ":\n" ++ helpCommands l- pad str = (take 15 $ str ++ replicate 15 ' ') ++ " "+ pad str = take 15 (str ++ replicate 15 ' ') ++ " " -- | This could be used to implement a disambiguation function --@@ -129,30 +134,61 @@ | "--help" `elem` opts && not (supercommand cmd) = printHelp cmd >> return Nothing | ("--help":_) <- opts = printHelp cmd >> return Nothing | NoOptions <- optionStyle cmd = return $ Just (foldr ($) (cmd_flag_empty cmd) defaults, opts)- | otherwise = do case errs of- [] -> do sequence_ [ setglobal (attrs f) (flag_value f flags') | f <- flag_list ]- return $ Just (flags', opts'filtered)- _ -> die (concat errs) >> return Nothing+ | otherwise = case errs' of+ [] -> do checkFlags (flags ++ defaults)+ [f | f <- flag_list,+ enabled $ attrs f,+ not $ nonoption attrs f]+ sequence_ [ setglobal (attrs f) (flag_value f flags') | f <- flag_list ]+ evaluate $ Just (flags', opts'filtered)+ _ -> die (concat errs') >> return Nothing where getopts = optDescr attrs+ checkFlags providedFlags allFlags =+ forM_ allFlags $ \f -> checkFlag f fs+ where+ fs = foldr ($) (cmd_flag_empty cmd) providedFlags+ checkFlag f fs =+ (flag_eval f fs+ `catch`+ \(_ :: RequiredArgException) ->+ die $ "Missing required flag: " ++ flagDescr f)+ `catch`+ \(e :: SomeException) -> die $ "Malformed flag: " ++ show e+ order = if supercommand cmd || (optionStyle cmd == NonPermuted) then RequireOrder else Permute (flags, opts', errs) = getOpt order getopts opts- flags' = foldr ($) (cmd_flag_empty cmd) (positions' ++ extras ++ reverse flags ++ defaults)+ 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_parse f (opts' !! n) else id- | (f, n) <- positions ]- opts'filtered = removemany opts' (reverse $ sort $ map snd positions)- removemany l (n:ns) = removemany (remove l n) ns- removemany l [] = l+ positions = [ (f, n, r) | f <- flag_list,+ enabled $ attrs f,+ Just n <- [positional $ attrs f],+ r <- [required $ attrs f] ]+ positions' = [ if length opts' > n+ then Right $ flag_parse f (opts' !! n)+ else Left (f, r)+ | (f, n, r) <- positions ]+ (missingErrs, positions'') = filterRequiredMissing $+ partitionEithers positions'+ filterRequiredMissing (ls, rs) = (, rs) $ case filter snd ls of+ [] -> []+ rFlags -> let missingArgs = map (requiredFlagStr . fst) rFlags in+ [unwords $ "Missing required argument(s):" : missingArgs ]++ flagDescr f = let optDescr = head $ flagToOptDescr MergeSuffix attrs f+ (ss', ls') = formatOptDescrOptions optDescr in+ intercalate "|" $ ss' ++ ls'++ errs' = errs ++ missingErrs+ opts'filtered = removemany opts'+ (reverse $ sort $ map (\(_,s,_) -> s) positions)+ removemany = foldl remove 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)+ attrs = attrFun (cmdattrs cmd %% 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@@ -190,13 +226,18 @@ 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+findCommand :: String -> [CommandWrap] -> [CommandWrap]+findCommand key list = case accum list of Left x -> [x]+ Right x -> x+ where accum (c@(CommandWrap cmd):comms)+ | key == cmdname cmd = Left c -- short-circuit an exact match+ | key `isPrefixOf` cmdname cmd = (c:) `fmap` accum comms+ | otherwise = accum comms+ accum (CommandGroup _ comms:comms')+ | Right c <- accum comms = (c++) `fmap` accum comms'+ | Left x <- accum comms = Left x+ | otherwise = accum comms'+ accum [] = return [] printHelp c = putStr $ helpOptions c printCommands comms = putStr $ helpCommands comms@@ -208,13 +249,18 @@ | otherwise -> return $ Just (fromJust def, []) ("--help":x) -> dispatch' diefn dopt comms' ("help":x) (cmd:args') -> case findCommand cmd comms of- Nothing -> case def of- Nothing -> dieHelp $ "No such command " ++ cmd+ [] -> case def of+ Nothing -> dieHelp $ "No such command '" ++ cmd ++ "'" Just x -> return $ Just (x, args)- Just x -> return $ Just (x, args')+ [x] -> return $ Just (x, args')+ disamb -> dieAmb cmd disamb >> return Nothing where comms | null [ () | NoHelp <- dopt ] = HelpCommand comms %: comms' | otherwise = comms' dieHelp msg = printCommands comms >> diefn msg >> return Nothing+ dieAmb cmd matches =+ do putStrLn $ "The following commands match your request:"+ printCommands matches+ diefn $ "Ambiguous command '" ++ cmd ++ "'" def | (DefaultCommand n:_) <- [ o | o@(DefaultCommand _) <- dopt ] = Just n | otherwise = Nothing @@ -257,5 +303,6 @@ run (HelpCommand comms) _ args = case args of [] -> printCommands comms (cmd:_) -> case findCommand cmd comms of- Nothing -> printCommands comms >> die ("No such command " ++ cmd)- Just (CommandWrap comm) -> printHelp comm+ [] -> printCommands comms >> die ("No such command '" ++ cmd ++ "'")+ [CommandWrap comm] -> printHelp comm+ x -> printCommands x >> die ("Ambiguous command '" ++ cmd ++ "'")
System/Console/CmdLib/Flag.hs view
@@ -7,10 +7,12 @@ import Data.Data import Data.List.Split( splitOn )-import Data.List( nub, intercalate, isSuffixOf )-import Data.Char( isUpper, toLower )+import Data.List( nub, intercalate, isSuffixOf, sortBy, partition )+import Data.Ord ( comparing )+import Data.Char( isUpper, toLower, toUpper ) import Data.Generics.Aliases( extR ) import Data.Generics.Text( gshow )+import Data.Maybe ( fromJust, isJust ) newtype PathF = PathF String deriving (Typeable, Data) @@ -37,9 +39,10 @@ flag_attrs :: flag -> [Attribute] flag_args :: flag -> [Attribute] -> ArgDescr (Folded flag -> Folded flag)- flag_set :: (Typeable a) => flag -> a -> (Folded flag -> Folded flag)- flag_parse :: flag -> String -> (Folded flag -> Folded flag)+ flag_set :: (Typeable a) => flag -> a -> Folded flag -> Folded flag+ flag_parse :: flag -> String -> Folded flag -> Folded flag flag_value :: (Typeable a) => flag -> Folded flag -> a+ flag_eval :: flag -> Folded flag -> IO () flag_type :: flag -> [Attribute] -> OptionType flag_list :: [flag] flag_defaults :: (flag -> [Attribute]) -> [Folded flag -> Folded flag]@@ -58,11 +61,87 @@ ([_], _) -> RequiredArgument _ -> BadOption -nonoption attr x- | True <- extra (attr x) = True- | Just _ <- positional (attr x) = True- | otherwise = False+nonoption attr x = isExtra attr x || isPositional attr x +isExtra attr = extra . attr+isPositional attr = isJust . positional . attr+isRequired attr = required . attr++formatOptDescrOptions (Option ss ls _ _) = (ss', ls') where+ ss' = map (\s -> '-' : [s]) ss+ ls' = map ("--" ++) ls++usageDescr :: FlagType flag => (flag -> [Attribute]) -> [String]+usageDescr attr = optGroups ++ reqs' ++ nonopts where+ partitionFlag (os, ps, es) f | isExtra attr f = (os, ps, f : es)+ partitionFlag (os, ps, es) f | isPositional attr f = (os, f : ps, es)+ partitionFlag (os, ps, es) f = (f : os, ps, es)++ (opts, positionals, extras) = foldl partitionFlag ([],[],[])+ [f | f <- flag_list, enabled $ attr f]++ (reqs, opts') = partition (isRequired attr) opts+ reqs' = fmtRequired `map` concatMap (flagToOptDescr MergeSuffix attr) reqs++ fmtRequired :: OptDescr a -> String+ fmtRequired od@(Option ss ls ad _) = separated ++ args ad where+ (ss', ls') = formatOptDescrOptions od+ all = ss' ++ ls'+ separated = case length all of+ 0 -> ""+ 1 -> head all+ _ -> "<" ++ intercalate "|" all ++ ">"++ args (NoArg _ ) = ""+ args (ReqArg _ ad) = '=' : ad+ args (OptArg _ ad) = "[=" ++ ad ++ "]"++ optGroups = [ "[" ++ map toUpper g ++ "]" |+ g <- nub $ map (getgroup . attr) opts' ]++ nonopts = upperReqPositionals ++ upperPositionals ++ upperExtras where+ orderedPositionals = orderByPosition positionals+ splitAtLastRequired p (req, nonreq) = case req of+ [] -> if isRequired attr p+ then ([p], nonreq)+ else ([] , p : nonreq)+ _ -> (p : req, nonreq)+ (requiredPos, nonRequiredPos) = foldr splitAtLastRequired ([],[])+ orderedPositionals+ upperReqPositionals = map nonoptStr requiredPos+ upperPositionals =+ case nestedOptional $ map nonoptStr nonRequiredPos of+ [] -> []+ nOpts -> [nOpts]+ upperExtras = map ((\s -> "[" ++ s ++ "]" ) . nonoptStr)+ extras++ nonoptStr :: FlagType flag => flag -> String+ nonoptStr f = requiredFlagStr f ++ extractArgDesc ad where+ (Option _ _ ad _) = head . flagToOptDescr MergeSuffix flag_attrs $ f+ extractArgDesc (ReqArg _ ad) = '=' : ad+ extractArgDesc _ = ""++ -- | Turn ["a","b","c"] into "[a [b [c]]]"+ nestedOptional [] = ""+ nestedOptional (x : xs) = "[" ++ x ++ rest ++ "]" where+ rest = case nestedOptional xs of+ "" -> ""+ r -> ' ' : r++ orderByPosition = sortBy cmpPos where+ cmpPos = comparing getPos+ getPos = fromJust . positional . attr++requiredFlagStr :: FlagType flag => flag -> String+requiredFlagStr = underscorate . keyToStr' . flag_attrkey where+ keyToStr' (KeyF _ s) = s+ keyToStr' (KeyC c) = show c++ underscorate (x:xs) | isUpper x = '_' : x : underscorate xs+ | otherwise = toUpper x : underscorate xs+ underscorate [] = []+ 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@@ -76,35 +155,49 @@ -- first with --foo and help, second with --no-foo (and no further help). data HelpStyle = MergePrefix | MergeSuffix | NoMerge deriving Eq +flagToOptDescr :: FlagType flag => HelpStyle -> (flag -> [Attribute]) -> flag -> [OptDescr ()]+flagToOptDescr style attr 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) ]+ | otherwise = [Option (shorts $ attr x) (longs $ attr x) (args x) (help x)] where+ 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 ()+ ziplongs [] [] = []+ ziplongs (p:ps) ns = merge p (takeWhile (p `isSuffixOf`) ns)+ : ziplongs ps (dropWhile (p `isSuffixOf`) ns)+ 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"+ merge p ns =+ "[" ++ intercalate "/" [ take (length n - length p) n | n <- ns ] ++ "]" ++ p++ 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 ()+helpDescr style attr = requireds : [ grp g | g <- nub $ map getgroup+ [ attr f | f <- flag_list, enabled $ attr f ] ]+ where requireds = ("Required Flags", requiredOpts)+ requiredOpts = concat+ [ flagToOptDescr style attr x | x <- flag_list,+ not $ nonoption attr x,+ isRequired attr x,+ enabled $ attr x ]+ grp g = (g, grpOptions g)+ grpOptions g = concat+ [ flagToOptDescr style attr x | x <- flag_list,+ not $ nonoption attr x,+ not $ isRequired attr x,+ enabled $ attr x,+ getgroup (attr x) == g ] -- | The default parser for option arguments. Handles strings, string lists -- (always produces single-element list), integers, booleans (@yes|true|1@ vs
System/Console/CmdLib/Record.hs view
@@ -5,7 +5,10 @@ import System.Console.CmdLib.Command import System.Console.GetOpt import Data.Data+import Data.IORef import Data.List( nub, elemIndex )+import Control.Exception ( throw, evaluate )+import Control.Monad ( when ) import Control.Monad.State( evalState, get, put, State, execState ) import Data.Maybe( fromMaybe, fromJust ) import System.Exit@@ -60,18 +63,23 @@ 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)+ setfield flag@(Record _ field) rec =+ setField field rec (if required $ attr flag+ then throw RequiredArgException+ else 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_value (Record _ field) = getField field+ flag_eval (Record _ field) = evalField field+ flag_set (Record _ field) v = \x -> setField field x (errcast v) where errcast :: (Typeable a, Typeable b) => a -> b- errcast x = case cast x of- Just x -> x- Nothing -> error "BUG: flag_set in Record used with wrong value type"+ errcast x = fromMaybe+ (error "BUG: flag_set in Record used with wrong value type")+ (cast x) flag_parse f@(Record _ field) str v = setField field v (readFlag (undefined :: rec) str) @@ -132,6 +140,11 @@ mode_help :: cmd -> String mode_help _ = "" + -- | Optionally override the default usage string for each mode. Use patterns+ -- like in @run'@.+ mode_synopsis :: cmd -> Maybe String+ mode_synopsis _ = Nothing+ data RecordMode cmd = RecordMode { rec_cmdname :: String , rec_initial :: Constr } deriving (Typeable)@@ -141,13 +154,16 @@ cmdname = rec_cmdname run _ = run' - summary cmd = mode_summary $ (fromConstr $ rec_initial cmd :: cmd)- help cmd = mode_help $ (fromConstr $ rec_initial cmd :: cmd)+ summary cmd = mode_summary (fromConstr $ rec_initial cmd :: cmd)+ help cmd = mode_help (fromConstr $ rec_initial cmd :: cmd)+ synopsis cmd = fromMaybe+ (unwords $ cmdname cmd : usageDescr (attrFun $ cmdattrs cmd %% flag_attrs))+ (mode_synopsis (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)+ ctor = fromConstr $ rec_initial cmd :: cmd optionStyle cmd = rec_optionStyle (fromConstr $ rec_initial cmd :: cmd) @@ -182,12 +198,26 @@ 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)+ 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+ errcast = fromMaybe (error errorMsg) . cast where+ errorMsg = "BUG: getField used with wrong type on " ++ field+ ++ " expected: " ++ show (typeOf (undefined :: a))+ ++ " got: " ++ show (typeOf (undefined :: b)) +evalField :: forall rec. (Data rec) => String -> rec -> IO ()+evalField field value = do ref <- newIORef 0+ gmapM (find ref) value+ return ()+ where idx = elemIndex field $ constrFields (toConstr value)+ find :: Data x => IORef Int -> x -> IO x+ find ref f = do i <- readIORef ref+ writeIORef ref $ i + 1+ when (Just i == idx) (evaluate f >> return ())+ return f+ -- | A command parsing & dispatch entry point for record-based -- commands. Ex. (see "RecordCommand"): --@@ -200,7 +230,7 @@ dispatchR dopt opts = dispatch' die dopt (recordCommands (undefined :: cmd)) opts >>= \c -> case c of Nothing -> exitWith ExitSuccess >> return undefined Just (CommandWrap x, opts') -> execute' x opts' >>= \c -> case c of- Just (command, opts') -> case (cast command) of+ Just (command, opts') -> case cast command of Just comm -> return comm Nothing -> execute x opts' >> exitWith ExitSuccess >> return undefined Nothing -> exitWith ExitSuccess >> return undefined
cmdlib.cabal view
@@ -1,5 +1,5 @@ name: cmdlib-version: 0.3.1+version: 0.3.2 synopsis: a library for command line parsing & online help description: A commandline parsing library, based on getopt. Comes with a