diff --git a/Data/Generics/Any.hs b/Data/Generics/Any.hs --- a/Data/Generics/Any.hs +++ b/Data/Generics/Any.hs @@ -89,11 +89,13 @@ recompose :: Any -> [Any] -> Any recompose (Any x) cs | null s = Any $ res `asTypeOf` x | otherwise = err - where (res,s) = flip runState cs $ flip fromConstrM (D.toConstr x) $ do - cs <- get - if null cs then err else do - put $ tail cs - return $ fromAny $ head cs + where (res,s) = runState (fromConstrM field $ D.toConstr x) cs + + field :: Data d => State [Any] d + field = do cs <- get + if null cs then err else do + put $ tail cs + return $ fromAny $ head cs err = error $ "Data.Generics.Any.recompose: Incorrect number of children to recompose, " ++ ctor (Any x) ++ " :: " ++ show (Any x) ++ ", expected " ++ show (arity $ Any x) ++ diff --git a/System/Console/CmdArgs/Implicit/Ann.hs b/System/Console/CmdArgs/Implicit/Ann.hs --- a/System/Console/CmdArgs/Implicit/Ann.hs +++ b/System/Console/CmdArgs/Implicit/Ann.hs @@ -23,4 +23,7 @@ | ProgSummary String | ProgProgram String | ProgVerbosity + | ProgHelpArg [Ann] + | ProgVersionArg [Ann] + | ProgVerbosityArgs [Ann] [Ann] deriving (Eq,Ord,Show,Data,Typeable) diff --git a/System/Console/CmdArgs/Implicit/Global.hs b/System/Console/CmdArgs/Implicit/Global.hs --- a/System/Console/CmdArgs/Implicit/Global.hs +++ b/System/Console/CmdArgs/Implicit/Global.hs @@ -149,27 +149,38 @@ extraFlags p = p{progModes = map f $ progModes p} where f m = m{modeFlags_ = modeFlags_ m ++ map (\x -> def{flagFlag=x, flagExplicit=True, flagGroup=grp}) flags} grp = if length (progModes p) > 1 then Just commonGroup else Nothing - flags = flagHelpFormat undefined : flagVersion vers : if progVerbosity p then flagsVerbosity verb else [] - vers x = x{cmdArgsVersion = Just $ progSumm p} + flags = changeBuiltin (progHelpArg p) (flagHelpFormat $ error "flagHelpFormat undefined") ++ + changeBuiltin (progVersionArg p) (flagVersion vers) ++ + changeBuiltin (fst $ progVerbosityArgs p) loud ++ + changeBuiltin (snd $ progVerbosityArgs p) quiet + [loud,quiet] = flagsVerbosity verb + vers x = x{cmdArgsVersion = Just $ unlines $ progSumm p} verb v x = x{cmdArgsVerbosity = Just v} +changeBuiltin :: Maybe Builtin_ -> Flag a -> [Flag a] +changeBuiltin Nothing _ = [] +changeBuiltin (Just (Builtin_ names explicit help)) x =[x + {flagNames = names ++ if explicit then [] else flagNames x + ,flagHelp = fromMaybe (flagHelp x) help}] + + setHelp :: Prog_ -> Mode (CmdArgs Any) -> Mode (CmdArgs Any) setHelp p = mapModes0 add "" where mapModes0 f pre m = f pre $ mapModes1 f pre m mapModes1 f pre m = m{modeGroupModes = fmap (mapModes0 f (pre ++ head (modeNames m) ++ " ")) $ modeGroupModes m} - add pre m = changeHelp m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp} - where msg hlp = Line (progSumm p) : Line "" : helpText hlp (prepare m{modeNames = map (pre++) $ modeNames m}) + add pre m = changeHelp p m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp} + where msg hlp = map Line (progSumm p) ++ Line "" : helpText hlp (prepare m{modeNames = map (pre++) $ modeNames m}) prepare = mapModes1 (\_ m -> m{modeGroupFlags = groupCommonHide $ modeGroupFlags m}) "" -changeHelp :: Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a -changeHelp m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m} - where hlp = flagHelpFormat upd - f flg = if flagNames hlp == flagNames flg then hlp else flg +changeHelp :: Prog_ -> Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a +changeHelp p m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m} + where hlp = changeBuiltin (progHelpArg p) $ flagHelpFormat upd + f flg = if concatMap flagNames hlp == flagNames flg then head hlp else flg --------------------------------------------------------------------- diff --git a/System/Console/CmdArgs/Implicit/Local.hs b/System/Console/CmdArgs/Implicit/Local.hs --- a/System/Console/CmdArgs/Implicit/Local.hs +++ b/System/Console/CmdArgs/Implicit/Local.hs @@ -5,7 +5,7 @@ -- constraints. module System.Console.CmdArgs.Implicit.Local( local, err, - Prog_(..), progSumm, Mode_(..), Flag_(..), isFlag_ + Prog_(..), progSumm, Builtin_(..), Mode_(..), Flag_(..), isFlag_ ) where import System.Console.CmdArgs.Implicit.Ann @@ -22,15 +22,25 @@ data Prog_ = Prog_ {progModes :: [Mode_] - ,progSummary :: Maybe String + ,progSummary :: Maybe [String] ,progProgram :: String ,progHelp :: String -- only for multiple mode programs - ,progVerbosity :: Bool + ,progVerbosityArgs :: (Maybe Builtin_, Maybe Builtin_) + ,progHelpArg :: Maybe Builtin_ + ,progVersionArg :: Maybe Builtin_ } deriving Show instance Default Prog_ where - def = Prog_ def def def def def -progSumm x = fromMaybe ("The " ++ progProgram x ++ " program") $ progSummary x + def = Prog_ def def def def def (Just def) (Just def) +progSumm x = fromMaybe ["The " ++ progProgram x ++ " program"] $ progSummary x +data Builtin_ = Builtin_ + {builtinNames :: [String] + ,builtinExplicit :: Bool + ,builtinHelp :: Maybe String + } deriving Show +instance Default Builtin_ where + def = Builtin_ def def def + data Mode_ = Mode_ {modeFlags_ :: [Flag_] ,modeMode :: Mode (CmdArgs Any) @@ -40,7 +50,7 @@ } deriving Show instance Default Mode_ where def = Mode_ [] m def def def - where m = Mode (toGroup []) [] undefined Right "" [] Nothing (toGroup []) + where m = Mode (toGroup []) [] (error "Mode_ undefined") Right "" [] Nothing (toGroup []) data Flag_ = Flag_ @@ -57,7 +67,7 @@ } deriving Show instance Default Flag_ where - def = Flag_ "" undefined def def def + def = Flag_ "" (error "Flag_ undefined") def def def isFlag_ Flag_{} = True isFlag_ _ = False @@ -126,12 +136,26 @@ -- CAPTURE THE ANNOTATIONS progAnn :: Ann -> Prog_ -> Prog_ -progAnn (ProgSummary a) x = x{progSummary=Just a} +progAnn (ProgSummary a) x = x{progSummary=Just $ lines a} progAnn (ProgProgram a) x = x{progProgram=a} -progAnn ProgVerbosity x = x{progVerbosity=True} +progAnn ProgVerbosity x = x{progVerbosityArgs=let f sel = Just $ fromMaybe def $ sel $ progVerbosityArgs x in (f fst, f snd)} progAnn (Help a) x | length (progModes x) > 1 = x{progHelp=a} +progAnn (ProgHelpArg a) x = x{progHelpArg = builtinAnns (progHelpArg x) a} +progAnn (ProgVersionArg a) x = x{progVersionArg = builtinAnns (progVersionArg x) a} +progAnn (ProgVerbosityArgs a b) x = x{progVerbosityArgs=(builtinAnns (Just $ fromMaybe def $ fst $ progVerbosityArgs x) a, builtinAnns (Just $ fromMaybe def $ snd $ progVerbosityArgs x) b)} progAnn a x | length (progModes x) == 1 = x{progModes = map (modeAnn a) $ progModes x} progAnn a x = err "program" $ show a + + +builtinAnns = foldl (flip builtinAnn) + +builtinAnn :: Ann -> Maybe Builtin_ -> Maybe Builtin_ +builtinAnn _ Nothing = Nothing +builtinAnn Ignore _ = Nothing +builtinAnn Explicit (Just x) = Just x{builtinExplicit=True} +builtinAnn (Name a) (Just x) = Just x{builtinNames=a : builtinNames x} +builtinAnn (Help a) (Just x) = Just x{builtinHelp=Just a} +builtinAnn a x = err "builtin" $ show a modeAnn :: Ann -> Mode_ -> Mode_ diff --git a/System/Console/CmdArgs/Implicit/UI.hs b/System/Console/CmdArgs/Implicit/UI.hs --- a/System/Console/CmdArgs/Implicit/UI.hs +++ b/System/Console/CmdArgs/Implicit/UI.hs @@ -167,3 +167,31 @@ -- Add @--verbose@ and @--quiet@ flags. verbosity :: Ann verbosity = ProgVerbosity + + +-- | Modes: \"Customise the help argument.\" +-- +-- Add extra options to a help argument, such as 'help', 'name', 'ignore' or 'explicit'. +-- +-- > Sample{..} &= helpArg [explicit, name "h"] +helpArg :: [Ann] -> Ann +helpArg = ProgHelpArg + + +-- | Modes: \"Customise the version argument.\" +-- +-- Add extra options to a version argument, such as 'help', 'name', 'ignore' or 'explicit'. +-- +-- > Sample{..} &= versionArg [ignore] +versionArg :: [Ann] -> Ann +versionArg = ProgVersionArg + +-- | Modes: \"Customise the verbosity arguments.\" +-- +-- Add extra options to a verbosity arguments (@--verbose@ and @--quiet@), +-- such as 'help', 'name', 'ignore' or 'explicit'. The verbose options come +-- first, followed by the quiet options. +-- +-- > Sample{..} &= verbosityArgs [ignore] [name "silent", explicit] +verbosityArgs :: [Ann] -> [Ann] -> Ann +verbosityArgs = ProgVerbosityArgs diff --git a/System/Console/CmdArgs/Test/Implicit/Diffy.hs b/System/Console/CmdArgs/Test/Implicit/Diffy.hs --- a/System/Console/CmdArgs/Test/Implicit/Diffy.hs +++ b/System/Console/CmdArgs/Test/Implicit/Diffy.hs @@ -29,7 +29,7 @@ isHelp ["create","--help"] [] isHelp ["diff","--help"] [] isHelpNot ["--help"] ["diffy"] - isVersion ["--version"] "Diffy v1.0" + isVersion ["--version"] "Diffy v1.0\n" ["create"] === create fails ["create","file1"] fails ["create","--quiet"] diff --git a/System/Console/CmdArgs/Test/Implicit/Maker.hs b/System/Console/CmdArgs/Test/Implicit/Maker.hs --- a/System/Console/CmdArgs/Test/Implicit/Maker.hs +++ b/System/Console/CmdArgs/Test/Implicit/Maker.hs @@ -31,9 +31,9 @@ ,files = def &= args } &= help "Build the project" &= auto -mode = cmdArgsMode $ modes [build,wipe,test_] &= help "Build helper program" &= program "maker" &= summary "Maker v1.0" +mode = cmdArgsMode $ modes [build,wipe,test_] &= help "Build helper program" &= program "maker" &= summary "Maker v1.0\nMake it" -mode_ = cmdArgsMode_ $ modes_ [build,wipe,test_] += help "Build helper program" += program "maker" += summary "Maker v1.0" +mode_ = cmdArgsMode_ $ modes_ [build,wipe,test_] += help "Build helper program" += program "maker" += summary "Maker v1.0\nMake it" where threads_ = threads := def += help "Number of threads to use" += name "j" += typ "NUM" @@ -57,6 +57,7 @@ test = do let Tester{..} = testers "Maker" [mode,mode_] [] === build + isHelp ["--help"] ["Maker v1.0","Make it"] isHelp ["-?=one"] ["Common flags:"] isHelpNot ["-?=one"] [" -d --debug Debug build"] isHelp ["-?=all"] ["maker [build] [OPTIONS] [ITEM]"] diff --git a/System/Console/CmdArgs/Test/Implicit/Tests.hs b/System/Console/CmdArgs/Test/Implicit/Tests.hs --- a/System/Console/CmdArgs/Test/Implicit/Tests.hs +++ b/System/Console/CmdArgs/Test/Implicit/Tests.hs @@ -9,11 +9,11 @@ test = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> test10 >> - test11 >> test12 >> test13 + test11 >> test12 >> test13 >> test14 >> test15 demos = zipWith f [1..] [toDemo mode1, toDemo mode2, toDemo mode3, toDemo mode4, toDemo mode5, toDemo mode6 ,toDemo mode7, toDemo mode8, toDemo mode9, toDemo mode10, toDemo mode11, toDemo mode12 - ,toDemo mode13] + ,toDemo mode13, toDemo mode14, toDemo mode15] where f i x = x{modeHelp = "Testing various corner cases (" ++ show i ++ ")"} @@ -242,3 +242,34 @@ fails ["test13a --bar13=1"] ["test13a","--foo13=13"] === Test13A 13 (Left 1) ["test13c","--foo13=13"] === Test13C 13 + +-- check a list becomes modes not an enum +data Test14 = Test14A | Test14B | Test14C deriving (Eq,Show,Data,Typeable) + +mode14 = cmdArgsMode $ modes [Test14A, Test14B, Test14C] + +test14 = do + let Tester{..} = tester "Test14" mode14 + fails [] + ["test14a"] === Test14A + fails ["--test14a"] + +-- custom help flags +data Test15 = Test15 {test15a :: Bool} deriving (Eq,Show,Data,Typeable) + +mode15 = cmdArgsMode $ Test15 (False &= name "help") + &= helpArg [name "h", name "nohelp", explicit, help "whatever"] &= versionArg [ignore] + &= verbosityArgs [ignore] [explicit,name "silent"] + +test15 = do + let Tester{..} = tester "Test15" mode15 + invalid $ \_ -> Test15 (False &= name "help") + ["--help"] === Test15 True + ["-t"] === Test15 True + fails ["-?"] + isHelp ["--nohelp"] [" -h --nohelp whatever"] + isHelp ["-h"] [] + fails ["--version"] + fails ["--verbose"] + fails ["--quiet"] + isVerbosity ["--help","--silent"] Quiet diff --git a/cmdargs.cabal b/cmdargs.cabal --- a/cmdargs.cabal +++ b/cmdargs.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: cmdargs -version: 0.6.1 +version: 0.6.2 license: BSD3 license-file: LICENSE category: Console