diff --git a/System/Console/CmdLib.hs b/System/Console/CmdLib.hs --- a/System/Console/CmdLib.hs +++ b/System/Console/CmdLib.hs @@ -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 diff --git a/System/Console/CmdLib/ADTs.hs b/System/Console/CmdLib/ADTs.hs --- a/System/Console/CmdLib/ADTs.hs +++ b/System/Console/CmdLib/ADTs.hs @@ -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) diff --git a/System/Console/CmdLib/Attribute.hs b/System/Console/CmdLib/Attribute.hs --- a/System/Console/CmdLib/Attribute.hs +++ b/System/Console/CmdLib/Attribute.hs @@ -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 diff --git a/System/Console/CmdLib/Command.hs b/System/Console/CmdLib/Command.hs --- a/System/Console/CmdLib/Command.hs +++ b/System/Console/CmdLib/Command.hs @@ -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 ++ "'") diff --git a/System/Console/CmdLib/Flag.hs b/System/Console/CmdLib/Flag.hs --- a/System/Console/CmdLib/Flag.hs +++ b/System/Console/CmdLib/Flag.hs @@ -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 diff --git a/System/Console/CmdLib/Record.hs b/System/Console/CmdLib/Record.hs --- a/System/Console/CmdLib/Record.hs +++ b/System/Console/CmdLib/Record.hs @@ -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 diff --git a/cmdlib.cabal b/cmdlib.cabal --- a/cmdlib.cabal +++ b/cmdlib.cabal @@ -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