"] ++ lines src ++ [""] diff --git a/Maker.hs b/Maker.hs new file mode 100644 --- /dev/null +++ b/Maker.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Maker where +import System.Console.CmdArgs + +data Method = Debug | Release | Profile + deriving (Data,Typeable,Show,Eq) + +data Maker + = Wipe + | Test {threads :: Int, extra :: [String]} + | Build {threads :: Int, method :: Method, files :: [FilePath]} + deriving (Data,Typeable,Show,Eq) + +threadsMsg = text "Number of threads to use" & flag "j" & typ "NUM" + +wipe = mode $ Wipe &= prog "maker" & text "Clean all build objects" + +test = mode $ Test + {threads = def &= threadsMsg + ,extra = def &= typ "ANY" & args & unknownFlags + } &= text "Run the test suite" + +build = mode $ Build + {threads = def &= threadsMsg + ,method = enum Release + [Debug &= text "Debug build" + ,Release &= text "Release build" + ,Profile &= text "Profile build"] + ,files = def &= args + } &= text "Build the project" & defMode + +modes = [build,wipe,test] + +main = print =<< cmdArgs "Maker v1.0" modes 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/CmdArgs.hs b/System/Console/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdArgs.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, PatternGuards #-} +{-| + This module provides simple command line argument processing. + The main function of interest is 'cmdArgs'. + A simple example is: + + @data Sample = Sample {hello :: String} deriving (Show, Data, Typeable)@ + + @sample = 'mode' $ Sample{hello = def '&=' 'text' \"World argument\" '&' 'empty' \"world\"}@ + + @main = print =<< 'cmdArgs' \"Sample v1, (C) Neil Mitchell 2009\" [sample]@ + + + Attributes are used to control a number of behaviours: + + * The help message: 'text', 'typ', 'helpSuffix', 'prog' + + * Default behaviour: 'empty', 'defMode' + + * Flag name assignment: 'flag', 'explicit', 'enum' + + * Controlling non-flag arguments: 'args', 'argPos', 'unknownFlags' +-} + +module System.Console.CmdArgs( + -- * Running command lines + cmdArgs, modeValue, + -- * Attributes + module System.Console.CmdArgs.UI, + -- * Verbosity control + isQuiet, isNormal, isLoud, + -- * Display help information + HelpFormat(..), cmdArgsHelp, + -- * Default values + Default(..), + -- * Re-exported for convenience + Data, Typeable + ) where + +import System.IO.Unsafe +import Data.Dynamic +import Data.Data +import Data.List +import Data.Maybe +import Data.IORef +import System.Environment +import System.Exit +import System.FilePath +import Data.Char +import Control.Monad.State +import Data.Function + +import System.Console.CmdArgs.Type +import System.Console.CmdArgs.UI +import System.Console.CmdArgs.Expand +import System.Console.CmdArgs.Flag +import System.Console.CmdArgs.Help + + +--------------------------------------------------------------------- +-- DEFAULTS + +-- | Class for default values +class Default a where + -- | Provide a default value + def :: a + +instance Default Bool where def = False +instance Default [a] where def = [] +instance Default Int where def = 0 +instance Default Integer where def = 0 +instance Default Float where def = 0 +instance Default Double where def = 0 + + +--------------------------------------------------------------------- +-- VERBOSITY CONTROL + +{-# NOINLINE verbosity #-} +verbosity :: IORef Int -- 0 = quiet, 1 = normal, 2 = verbose +verbosity = unsafePerformIO $ newIORef 1 + +-- | Used to test if essential messages should be output to the user. +-- Always true (since even @--quiet@ wants essential messages output). +-- Must be called after 'cmdArgs'. +isQuiet :: IO Bool +isQuiet = return True + +-- | Used to test if normal messages should be output to the user. +-- True unless @--quiet@ is specified. +-- Must be called after 'cmdArgs'. +isNormal :: IO Bool +isNormal = fmap (>=1) $ readIORef verbosity + +-- | Used to test if helpful debug messages should be output to the user. +-- False unless @--verbose@ is specified. +-- Must be called after 'cmdArgs'. +isLoud :: IO Bool +isLoud = fmap (>=2) $ readIORef verbosity + + +--------------------------------------------------------------------- +-- MAIN DRIVERS + +-- | Extract the default value from inside a Mode. +modeValue :: Mode a -> a +modeValue = modeVal + + +-- | The main entry point for programs using CmdArgs. +-- For an example see "System.Console.CmdArgs". +cmdArgs :: Data a + => String -- ^ Information about the program, something like: @\"ProgramName v1.0, Copyright PersonName 2000\"@. + -> [Mode a] -- ^ The modes of operation, constructed by 'mode'. For single mode programs it is a singleton list. + -> IO a +cmdArgs short modes = do + modes <- return $ expand modes + (mode,args) <- parseModes modes `fmap` getArgs + when (hasAction args "!help") $ do + hlp <- case mode of + Right (True,mode) -> helpInfo short modes [mode] + _ -> helpInfo short modes modes + let Update _ op = fromJust $ getAction args "!help" + putStr $ showHelp hlp (fromDyn (op undefined) "") + exitSuccess + when (hasAction args "!version") $ do + putStrLn short + exitSuccess + mode <- case mode of + Right (_,x) -> return x + Left x -> putStrLn x >> exitFailure + sequence_ [putStrLn x >> exitFailure | Error x <- args] + when (hasAction args "!verbose") $ writeIORef verbosity 2 + when (hasAction args "!quiet") $ writeIORef verbosity 0 + return $ applyActions args $ modeValue mode + + +--------------------------------------------------------------------- +-- HELP INFORMATION + +-- | Format to display help in. +data HelpFormat + = Text -- ^ As output on the console. + | HTML -- ^ Suitable for inclusion in web pages (uses a table rather than explicit wrapping). + deriving (Eq,Ord,Show,Read,Enum,Bounded) + +-- | Display the help message, as it would appear with @--help@. +-- The first argument should match the first argument to 'cmdArgs'. +cmdArgsHelp :: String -> [Mode a] -> HelpFormat -> IO String +cmdArgsHelp short xs format = fmap (`showHelp` (show format)) $ helpInfo short modes modes + where modes = expand xs + + +helpInfo :: String -> [Mode a] -> [Mode a] -> IO [Help] +helpInfo short tot now = do + prog <- fmap (map toLower . takeBaseName) getProgName + prog <- return $ head $ mapMaybe modeProg tot ++ [prog] + let info = [([Norm $ unwords $ prog : [['['|def] ++ name ++ [']'|def] | length tot /= 1] ++ "[FLAG]" : args] ++ + [Norm $ " " ++ text | text /= ""] + ,concatMap helpFlag flags) + | Mode{modeName=name,modeFlags=flags,modeText=text,modeDef=def} <- now + , let args = map snd $ sortBy (compare `on` fst) $ concatMap helpFlagArgs flags] + let dupes = if length now == 1 then [] else foldr1 intersect (map snd info) + return $ + Norm short : + concat [ Norm "" : mode ++ [Norm "" | flags /= []] ++ map Trip flags + | (mode,args) <- info, let flags = args \\ dupes] ++ + (if null dupes then [] else Norm "":Norm "Common flags:":map Trip dupes) ++ + concat [ map Norm $ "":suf | suf@(_:_) <- map modeHelpSuffix tot] + + +--------------------------------------------------------------------- +-- PROCESS FLAGS + +parseModes :: [Mode a] -> [String] -> (Either String (Bool, Mode a), [Action]) +parseModes modes args + | [mode] <- modes = (Right (False,mode), parseFlags (modeFlags mode) args) + | [] <- poss, Just mode <- def = (Right (False,mode), parseFlags (modeFlags mode) args) + | [mode] <- poss = (Right (True, mode), parseFlags (modeFlags mode) $ tail args) + | otherwise = (Left err, parseFlags autoFlags args) + where + err = if null poss + then "No mode given, expected one of: " ++ unwords (map modeName modes) + else "Multiple modes given, could be any of: " ++ unwords (map modeName poss) + + def = listToMaybe $ filter modeDef modes + poss = let f eq = [m | a <- take 1 args, m <- modes, a `eq` modeName m] + (exact,prefix) = (f (==), f isPrefixOf) + in if null exact then prefix else exact + + +--------------------------------------------------------------------- +-- APPLICATION + +setField :: Data a => a -> String -> (Dynamic -> Dynamic) -> a +setField x name v = flip evalState (constrFields $ toConstr x) $ flip gmapM x $ \i -> do + n:ns <- get + put ns + return $ if n == name then fromDyn (v $ toDyn i) i else i + + +applyActions :: Data a => [Action] -> a -> a +applyActions (Update name op:as) x | not $ "!" `isPrefixOf` name = applyActions as $ setField x name op +applyActions (a:as) x = applyActions as x +applyActions [] x = x diff --git a/System/Console/CmdArgs/Expand.hs b/System/Console/CmdArgs/Expand.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdArgs/Expand.hs @@ -0,0 +1,83 @@ + +module System.Console.CmdArgs.Expand(defaults,expand,autoFlags) where + +import System.Console.CmdArgs.Type +import Data.Dynamic +import Data.List +import Data.Maybe +import Data.Char +import Data.Function + + +--------------------------------------------------------------------- +-- PRESUPPLIED ARGS + +autoFlags :: [Flag] +autoFlags = + [(f "!help" "?" "help" "Show usage information (optional format)") + {flagType=fromJust $ toFlagType (typeOf ""),flagOpt=Just "",flagTyp="FORMAT"} + ,f "!version" "V" "version" "Show version information" + ,f "!verbose" "v" "verbose" "Higher verbosity" + ,f "!quiet" "q" "quiet" "Lower verbosity" + ] + where f name short long text = flagDefault + {flagName=name,flagKey=name,flagFlag=[short,long],flagText=text,flagType=FlagBool (toDyn True),flagVal=toDyn False,flagExplicit=True} + +--------------------------------------------------------------------- +-- FLAG DEFAULTS + +-- FIXME: Add the string (default=foo) in the appropriate places +defaults :: a -> Flag -> Flag +defaults = error "todo" + + +--------------------------------------------------------------------- +-- FLAG EXPANSION +-- Introduce more long/short names + +-- (keyname,([flags],explicit)) +type FlagNames = [(String,([String],Bool))] + +-- Error if: +-- Two things with the same FldName have different FldFlag or Explicit +-- Two fields without the same FldName have different FldFlag +expand :: [Mode a] -> [Mode a] +expand xs | not $ checkFlags ys = error "Flag's don't meet their condition" + | otherwise = xs3 + where + xs3 = map (\x -> x{modeFlags=[if isFlagArgs c then c else c{flagFlag=fst $ fromJust $ lookup (flagKey c) ys2} | c <- modeFlags x]}) xs2 + ys2 = assignShort $ assignLong ys + ys = sort $ nub [(flagKey x, (flagFlag x, flagExplicit x)) | x <- map modeFlags xs2, x <- x, isFlagFlag x] + xs2 = map (\x -> x{modeFlags = autoFlags ++ modeFlags x}) xs + + +checkFlags :: FlagNames -> Bool +checkFlags xs | any ((/=) 1 . length) $ groupBy ((==) `on` fst) xs = error "Two record names have different flags" + | nub names /= names = error "One flag has been assigned twice" + | otherwise = True + where names = concatMap (fst . snd) xs + + +assignLong :: FlagNames -> FlagNames +assignLong xs = map f xs + where + seen = concatMap (fst . snd) xs + f (name,(already,False)) | name `notElem` seen = (name,(g name:already,False)) + f x = x + g xs | "_" `isSuffixOf` xs = g $ init xs + g xs = [if x == '_' then '-' else x | x <- xs] + + +assignShort :: FlagNames -> FlagNames +assignShort xs = zipWith (\x (a,(b,c)) -> (a,(maybe [] (return . return) x ++ b,c))) good xs + where + seen = concat $ filter ((==) 1 . length) $ concatMap (fst . snd) xs + guesses = map guess xs :: [Maybe Char] + dupes = let gs = catMaybes guesses in nub $ gs \\ nub gs + good = [if maybe True (`elem` (dupes++seen)) g then Nothing else g | g <- guesses] :: [Maybe Char] + + -- guess at a possible short flag + guess (name,(already,False)) | all ((/=) 1 . length) already = Just $ head $ head already + guess _ = Nothing + + diff --git a/System/Console/CmdArgs/Flag.hs b/System/Console/CmdArgs/Flag.hs new file mode 100644 --- /dev/null +++ b/System/Console/CmdArgs/Flag.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE PatternGuards #-} + +module System.Console.CmdArgs.Flag where + +import Data.Dynamic +import Data.List +import Data.Maybe +import Data.Char +import Control.Monad +import Data.Function + +import System.Console.CmdArgs.Type + + +data Action = Update String (Dynamic -> Dynamic) + | Error String + +instance Show Action where + show (Update x y) = "Update " ++ show x ++ "
+ by Neil Mitchell +
+ ++ CmdArgs is a library for defining and parsing command lines. The focus of CmdArgs is allowing the concise definition of fully-featured command line argument processors, in a mainly declarative manner (i.e. little coding needed). CmdArgs also supports multiple mode programs, for example as used in darcs. +
+ This document explains how to write the "hello world" of command line processors, then how to extend it with features into a complex command line processor. Finally this document gives three samples, which the cmdargs program can run. The three samples are: +
++ For each example you are encouraged to look at it's source (see the darcs repo, or the bottom of this document) and run it (try cmdargs hlint --help). The HLint program is fairly standard in terms of it's argument processing, and previously used the System.Console.GetOpt library. Using GetOpt required 90 lines and a reasonable amount of duplication. Using CmdArgs the code requires 30 lines, and the logic is much simpler. +
+ + ++ The following code defines a complete command line argument processor: +
+
+{-# LANGUAGE DeriveDataTypeable #-}
+module Sample where
+import System.Console.CmdArgs
+
+data Sample = Sample {hello :: String}
+ deriving (Show, Data, Typeable)
+
+sample = mode $ Sample{hello = def}
+
+main = print =<< cmdArgs "Sample v1, (C) Neil Mitchell 2009" [sample]
+
++ To use the CmdArgs library there are three steps: +
++ Now we have a reasonably functional command line argument processor. Some sample interactions are: +
+
+$ runhaskell Sample.hs --hello=world
+Sample {hello = "world"}
+
+$ runhaskell Sample.hs --help
+Sample v1, (C) Neil Mitchell 2009
+
+sample [FLAG]
+
+ -? --help[=FORMAT] Show usage information (optional format)
+ -V --version Show version information
+ -v --verbose Higher verbosity
+ -q --quiet Lower verbosity
+ -h --hello=VALUE
+
++ The CmdArgs library automatically provides support for: +
++ In order to control the behaviour we can add attributes. For example to add an attribute specifying the help text for the --hello argument we can write: +
+
+sample = mode $ Sample{hello = def &= text "Who to say hello to"}
+
++ We can add additional attributes, for example to specify the type of the value expected by hello: +
+
+sample = mode $ Sample {hello = def &= text "Who to say hello to" & typ "WORLD"}
+
++ Now when running --help the final line is: +
++ -h --hello=WORLD Who to say hello to ++
+ There are many more attributes, detailed in the Haddock documentation. +
+ + ++ To specify a program with multiple modes, similar to darcs, we can supply a data type with multiple constructors, for example: +
+
+data Sample = Hello {whom :: String}
+ | Goodbye
+ deriving (Show, Data, Typeable)
+
+hello = mode $ Hello{whom = def}
+goodbye = mode $ Goodbye
+
+main = print =<< cmdArgs "Sample v2, (C) Neil Mitchell 2009" [hello,goodbye]
+
++ Compared to the first example, we now have multiple constructors, and a sample value for each constructor is passed to cmdArgs. Some sample interactions with this command line are: +
+
+$ runhaskell Sample.hs hello --whom=world
+Hello {whom = "world"}
+
+$ runhaskell Sample.hs goodbye
+Goodbye
+
+$ runhaskell Sample.hs --help
+Sample v2, (C) Neil Mitchell 2009
+
+sample hello [FLAG]
+
+ -w --whom=VALUE
+
+sample goodbye [FLAG]
+
+Common flags:
+ -? --help[=FORMAT] Show usage information (optional format)
+ -V --version Show version information
+ -v --verbose Higher verbosity
+ -q --quiet Lower verbosity
+
++ As before, the behaviour can be customised using attributes. +
+ ++ For each of the following examples we first explain the purpose of the program, then give the source code, and finally the output of --help=HTML. The programs are intended to show sample uses of CmdArgs, and are available to experiment with through cmdargs progname. +
+ ++ The HLint program analyses a list of files, using various options to control the analysis. The command line processing is simple, but a few interesting points are: +
+
+{-# LANGUAGE DeriveDataTypeable #-}
+module HLint where
+import System.Console.CmdArgs
+
+data HLint = HLint
+ {report :: [FilePath]
+ ,hint :: [FilePath]
+ ,color :: Bool
+ ,ignore :: [String]
+ ,show_ :: Bool
+ ,test :: Bool
+ ,cpp_define :: [String]
+ ,cpp_include :: [String]
+ ,files :: [String]
+ }
+ deriving (Data,Typeable,Show,Eq)
+
+hlint = mode $ HLint
+ {report = def &= empty "report.html" & typFile & text "Generate a report in HTML"
+ ,hint = def &= typFile & text "Hint/ignore file to use"
+ ,color = def &= flag "c" & flag "colour" & text "Color the output (requires ANSI terminal)"
+ ,ignore = def &= typ "MESSAGE" & text "Ignore a particular hint"
+ ,show_ = def &= text "Show all ignored ideas"
+ ,test = def &= text "Run in test mode"
+ ,cpp_define = def &= typ "NAME[=VALUE]" & text "CPP #define"
+ ,cpp_include = def &= typDir & text "CPP include path"
+ ,files = def &= args & typ "FILE/DIR"
+ } &=
+ prog "hlint" &
+ text "Suggest improvements to Haskell source code" &
+ helpSuffix ["To check all Haskell files in 'src' and generate a report type:"," hlint src --report"]
+
+modes = [hlint]
+
+main = print =<< cmdArgs "HLint v1.6.5, (C) Neil Mitchell 2006-2009" modes
+
+
+
+| HLint v1.6.5, (C) Neil Mitchell 2006-2009 | ||
| hlint [FLAG] [FILE/DIR] | ||
| Suggest improvements to Haskell source code | ||
| -? | --help[=FORMAT] | Show usage information (optional format) |
| -V | --version | Show version information |
| -v | --verbose | Higher verbosity |
| -q | --quiet | Lower verbosity |
| -r | --report[=FILE] | Generate a report in HTML (default=report.html) |
| -h | --hint=FILE | Hint/ignore file to use |
| -c | --color --colour | Color the output (requires ANSI terminal) |
| -i | --ignore=MESSAGE | Ignore a particular hint |
| -s | --show | Show all ignored ideas |
| -t | --test | Run in test mode |
| --cpp-define=NAME[=VALUE] | CPP #define | |
| --cpp-include=DIR | CPP include path | |
| To check all Haskell files in 'src' and generate a report type: | ||
| hlint src --report | ||
+ The Diffy sample is a based on the idea of creating directory listings and comparing them. The tool can operate in two separate modes, create or diff. This sample is fictional, but the ideas are drawn from a real program. A few notable features: +
+
+{-# LANGUAGE DeriveDataTypeable #-}
+module Diffy where
+import System.Console.CmdArgs
+
+data Diffy = Create {src :: FilePath, out :: FilePath}
+ | Diff {old :: FilePath, new :: FilePath, out :: FilePath}
+ deriving (Data,Typeable,Show,Eq)
+
+outFlags = text "Output file" & typFile
+
+create = mode $ Create
+ {src = "." &= text "Source directory" & typDir
+ ,out = "ls.txt" &= outFlags
+ } &= prog "diffy" & text "Create a fingerprint"
+
+diff = mode $ Diff
+ {old = def &= typ "OLDFILE" & argPos 0
+ ,new = def &= typ "NEWFILE" & argPos 1
+ ,out = "diff.txt" &= outFlags
+ } &= text "Perform a diff"
+
+modes = [create,diff]
+
+main = print =<< cmdArgs "Diffy v1.0" modes
+
+
+
+| Diffy v1.0 | ||
| diffy create [FLAG] | ||
| Create a fingerprint | ||
| -s | --src=DIR | Source directory (default=.) |
| -o | --out=FILE | Output file (default=ls.txt) |
| diffy diff [FLAG] OLDFILE NEWFILE | ||
| Perform a diff | ||
| -o | --out=FILE | Output file (default=diff.txt) |
| Common flags: | ||
| -? | --help[=FORMAT] | Show usage information (optional format) |
| -V | --version | Show version information |
| -v | --verbose | Higher verbosity |
| -q | --quiet | Lower verbosity |
+ The Maker sample is based around a build system, where we can either build a project, clean the temporary files, or run a test. The test mode is designed to run another program, passing any unknown arguments onwards. Some interesting features are: +
+
+{-# LANGUAGE DeriveDataTypeable #-}
+module Maker where
+import System.Console.CmdArgs
+
+data Method = Debug | Release | Profile
+ deriving (Data,Typeable,Show,Eq)
+
+data Maker
+ = Wipe
+ | Test {threads :: Int, extra :: [String]}
+ | Build {threads :: Int, method :: Method, files :: [FilePath]}
+ deriving (Data,Typeable,Show,Eq)
+
+threadsMsg = text "Number of threads to use" & flag "j" & typ "NUM"
+
+wipe = mode $ Wipe &= prog "maker" & text "Clean all build objects"
+
+test = mode $ Test
+ {threads = def &= threadsMsg
+ ,extra = def &= typ "ANY" & args & unknownFlags
+ } &= text "Run the test suite"
+
+build = mode $ Build
+ {threads = def &= threadsMsg
+ ,method = enum Release
+ [Debug &= text "Debug build"
+ ,Release &= text "Release build"
+ ,Profile &= text "Profile build"]
+ ,files = def &= args
+ } &= text "Build the project" & defMode
+
+modes = [build,wipe,test]
+
+main = print =<< cmdArgs "Maker v1.0" modes
+
+
+
+| Maker v1.0 | ||
| maker [build] [FLAG] [FILE] | ||
| Build the project | ||
| -j | --threads=NUM | Number of threads to use |
| -d | --debug | Debug build |
| -r | --release | Release build |
| -p | --profile | Profile build |
| maker wipe [FLAG] | ||
| Clean all build objects | ||
| maker test [FLAG] [ANY] | ||
| Run the test suite | ||
| -j | --threads=NUM | Number of threads to use |
| Common flags: | ||
| -? | --help[=FORMAT] | Show usage information (optional format) |
| -V | --version | Show version information |
| -v | --verbose | Higher verbosity |
| -q | --quiet | Lower verbosity |