diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,38 @@ +# 0.7.0.0 + +- Add usage parsing QuasiQuoters [#7] + - Add `docopt` usage parsing QuasiQuoter + - Add `docoptFile` usage parsing QuasiQuoter + - Add `System.Docopt.NoTH` module + - Add `parseUsage` + - Add `parseUsageOrExit` +- New API organization [#10] + - Remove `optionsWithUsage` + - Remove `optionsWithUsageDebug` + - Remove `optionsWithUsageFile` + - Remove `optionsWithUsageFileDebug` + - Add `Docopt` type to represent a parsed usage string + - Add `usage` + - Add `parseArgs` + - Add `parseArgsOrExit` + - Add `exitWithUsage` + - Add `exitWithUsageMessage` + - Monomorphize `getArg` from `Monad m` to `Maybe` + - Add `getArgOrExitWith` + - Deprecate `getAllArgsM` + - Deprecate `notPresentM` + - Deprecate `isPresentM` + - Deprecate `getFirstArg` +- Add thorough haddock API documentation + +### 0.6.0.2 + +- Make `argument` not require its named option wrapped in angle brackets. [#4, #5] + +### 0.6.0.1 + +- Fix haddock docs. + +# 0.6.0.0 + +First release! Tracks features of reference Python implementation at version `0.6`. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,210 @@ +Docopt.hs +========= + +A Haskell port of python's [docopt](http://docopt.org). + +---------- + +## Want a command-line interface *without* building a parser? + +How about writing your help text first, and getting a parser for free! + +Save your help text to a file (i.e. `USAGE.txt`): + + Usage: + myprog cat + myprog echo [--caps] + + Options: + -c, --caps Caps-lock the echoed argument + +Then, in your `Myprog.hs`: + +```haskell +{-# LANGUAGE QuasiQuotes #-} +import Control.Monad (when) +import Data.Char (toUpper) +import System.Console.Docopt + +patterns :: Docopt +patterns = [docoptFile|USAGE.txt|] + +main = do + args <- parseArgsOrExit patterns =<< getArgs + + when (args `isPresent` (command "cat")) $ do + file <- args `getArgOrExit` (argument "file") + putStr =<< readFile file + + when (args `isPresent` (command "echo")) $ do + let charTransform = if args `isPresent` (longOption "caps") + then toUpper + else id + string <- args `getArgOrExit` (argument "string") + putStrLn $ map charTransform string +``` + +That's it! No Template Haskell, no unreadable syntax, no learning yet *another* finicky API. Write the usage patterns you support, and docopt builds the appropriate option parser for you (internally using [`parsec`](http://hackage.haskell.org/package/parsec)). If your user invokes your program correctly, you query for the arguments they provided. If the arguments provided do not match a supported usage pattern, you guessed it: docopt automatically prints the help text and exits! + + +Installation +------------ + + cabal sandbox init + cabal install docopt + +API Reference +------------- + +See [the package on hackage](https://hackage.haskell.org/package/docopt) + + +Help text format +================ + +Docopt only cares about 2 parts of your help text: + +- **Usage patterns**, e.g.: + + ``` + Usage: + my_program [-hs] [-o=] [--quiet | --verbose] [...] + ``` + These begin with `Usage:` (case-insensitive), and end with a blank line. + +- **Option descriptions**, e.g.: + + ``` + Options: + -h --help show this + -s --sorted sorted output + -o= specify output file + [default: ./test.txt] + --quiet print less text + --verbose print more text + ``` + + Any line after the usage patterns that begins with a `-` is treated as an option description (though an option's default may be on a different line). + +Usage Patterns +-------------- + +- #### `` + + Positional arguments. Constructed via `argument`, i.e. `argument "arg"` matches an `` element in the help text. + +- #### `--flag` or `--option=` + + Options are typically optional (though this is up to you), and can be either boolean (present/absent), as in `--flag`, or expect a trailing argument, as in `--option=`. Arguments can be separated from the option name by an `=` or a single space, and can be in `` form or `ARG` form (though consistency of style is recommended, it is not enforced). + + Short-style options, as in `-f` or `-f ARG`, are also allowed. Synonyms between different spellings of the same option (e.g. `-v` and `--verbose`) can be established in the option descriptions (see below). Short-style options can also be stacked, as in `-rfA`. When options are stacked, `-rfA` is effectively equivalent to `(-r | -f | -A)...` to the argument parser. + + You can match a long-style option `--flag` with `longOption "flag"`, and a short-style option `-f` with `shortOption 'f'` The same constructor is used whether the option expects an argument or not. + +- #### `command` + + Anything not recognized as a positional argument or a short or long option is treated as a command (or subcommand, same thing to docopt). A command named `pull` can be matched with `command "pull"`. + +- #### `[]` (brackets) e.g. `command [--option]` + + Patterns inside brackets are **optional**. + +- #### `()` (parens) + + Patterns inside parens are **required** (the same as patterns *not* in `()` are required). Parens are useful if you need to group some elements, either for use with `|` or `...`. + +- #### `|` (pipe) e.g. `command [--quiet | --verbose]` + + A pipe `|` separates mutually elements in a group. A group could be elements inside `[]`, `()`, or the whole usage line. + + ``` + Usage: + myprog command [--opt1 | --opt2] # valid + myprog go (left | right) # valid + myprog -v | -h # valid + ``` + + When elements are separated by a pipe, the elements are tried from left to right until one succeeds. At least one of the elements are required unless in an eplicitly optional group surrounded by `[]`. + +- #### `...` (ellipsis) e.g. `command ...` + + An ellipsis can trail any element or group to make it repeatable. Repeatable elements will be accumulated into a list of occurrences. + +- #### `[options]` (case sensitive) + + The string `[options]` is a shortcut to match any options specified in your option descriptions. + +- #### `[-]` and `[--]` + + Single hyphen `-` is used by convention to specify using `stdin` as input instead of reading a file. Double hyphen `--` is typically used to manually separate leading options from trailing positional arguments. Both of these are treated as `command`s, and so are perfectly legal in usage patterns. They are typically optional elements, but can be required if you drop the `[]`. + +Option descriptions +------------------- + +Option descriptions establish: +- which short and long options are synonymous +- whether an option expects an argument or is a simple flag +- if an option's argument has a default value + +**Rules**: + +- Any line *after* the usage patterns whose first non-space character is a `-` is treated as an option description. (`Options:` prefix line not required). + + ``` + Options: --help # invalid: line does not start with '-' + --verbose # good + ``` + +- Options on the same line will be treated by the parser as synonyms (everywhere interchangeable). Synonymous options are separated by a space (with optional comma): + + ``` + Usage: + myprog --help | --verbose + + Options: + -h, --help Print help text + -v --verbose Print help text twice + ``` + + Here, `myprog --help` and `myprog -h` will both work the same, as will `myprog --verbose` and `myprog -v`. + +- If any synonymous options are specified in the description with an argument, the option parser will expect an argument for all synonyms. If not, all synonyms will be treated as flags. + + ``` + Usage: + myprog analyze [--verbose] + + Options: + --verbose, -v LEVEL The level of output verbosity. + ``` + + Here, in the arguments `myprog analyze --verbose ./file1.txt` would be invalid, because `-v` *and its synonyms* expect an argument, so `./file1.txt` is captured as the argument of `--verbose`, *not* as the positional argument ``. Be careful! + + Options can be separated from arguments with a single space or a `=`, and arguments can have the form `` or `ARG`. Just be sure to separate synonyms and arguments from the beginning of the description by **at least 2 spaces**. + + ``` + --opt1 ARG1 Option 1. + --opt2= Option 2. # BAD: use 2 spaces + -a Option 3. + -b=ARG4 Option 4. + ``` + +- Options that expect arguments can be given a default value, in the form `[default: ]`. Default values do not need to be on the same line + + ``` + --host=NAME Host to listen on. [default: localhost] + --port=PORT Port number [default: 8080] + --directory=DIR This option has an especially long description + explaining its meaning. [default: ./] + ``` + +---------------- + + +#### Differences from reference python implementation: + + - does not automatically exclude from the `[options]` shortcut options that are already used elsewhere in the usage pattern (e.g. `usage: prog [options] -a` will try to parse `-a` twice). + + - does not automatically resolve partially-specified arguments, e.g. `--verb` does not match where `--verbose` is expected. This is planned to be deprecated in future versions of docopt, and will likely not be implemented in docopt.hs + + - is not insensitive to the ordering of adjacent options, e.g. `usage: prog -a -b` does not allow `prog -b -a` (reference implementation currently does). diff --git a/System/Console/Docopt.hs b/System/Console/Docopt.hs --- a/System/Console/Docopt.hs +++ b/System/Console/Docopt.hs @@ -1,7 +1,46 @@ -module System.Console.Docopt - ( - module System.Console.Docopt.Public, +-- | Example: +-- +-- @ +-- {-\# LANGUAGE QuasiQuotes \#-} +-- module Main where +-- +-- import Control.Monad (when) +-- import Data.Char (toUpper) +-- import System.Console.Docopt +-- +-- patterns :: Docopt +-- patterns = [docopt| +-- docopt-sample version 0.1.0 +-- +-- Usage: +-- docopt-sample cat \ +-- docopt-sample echo [--caps] \ +-- +-- Options: +-- -c, --caps Caps-lock the echoed argument +-- |] +-- +-- main :: IO () +-- main = do +-- args <- parseArgsOrExit patterns +-- +-- when (args \`isPresent\` (command \"cat\")) $ do +-- file <- args \`getArgOrExit\` (argument \"file\") +-- putStr =<< readFile file +-- +-- when (args \`isPresent\` (command \"echo\")) $ do +-- let charTransform = if args \`isPresent\` (longOption \"caps\") +-- then toUpper +-- else id +-- string <- args \`getArgOrExit\` (argument \"string\") +-- putStrLn $ map charTransform string +-- @ +module System.Console.Docopt + ( + module System.Console.Docopt.QQ, + module System.Console.Docopt.Public ) where +import System.Console.Docopt.QQ import System.Console.Docopt.Public diff --git a/System/Console/Docopt/NoTH.hs b/System/Console/Docopt/NoTH.hs new file mode 100644 --- /dev/null +++ b/System/Console/Docopt/NoTH.hs @@ -0,0 +1,38 @@ +module System.Console.Docopt.NoTH + ( + -- * Usage parsers + parseUsage + , parseUsageOrExit + + , module System.Console.Docopt.Public + ) + where + +import Data.Map as M hiding (null) +import System.Exit + +import System.Console.Docopt.Types +import System.Console.Docopt.Public +import System.Console.Docopt.ParseUtils +import System.Console.Docopt.UsageParse (pDocopt) + + +-- | Parse docopt-formatted usage patterns. +-- +-- For help with the docopt usage format, see +-- . +parseUsage :: String -> Either ParseError Docopt +parseUsage usg = + case runParser pDocopt M.empty "Usage" usg of + Left e -> Left e + Right optfmt -> Right (Docopt optfmt usg) + +-- | Same as 'parseUsage', but 'exitWithUsage' on parse failure. E.g. +-- +-- > let usageStr = "Usage:\n prog [--option]\n" +-- > patterns <- parseUsageOrExit usageStr +parseUsageOrExit :: String -> IO Docopt +parseUsageOrExit usg = exitUnless $ parseUsage usg + where + exit message = putStrLn message >> exitFailure + exitUnless = either (const $ exit usg) return diff --git a/System/Console/Docopt/OptParse.hs b/System/Console/Docopt/OptParse.hs --- a/System/Console/Docopt/OptParse.hs +++ b/System/Console/Docopt/OptParse.hs @@ -1,4 +1,4 @@ -module System.Console.Docopt.OptParse +module System.Console.Docopt.OptParse where import Control.Monad (unless) @@ -10,20 +10,20 @@ import System.Console.Docopt.Types --- | The meat and potatoes. +-- | The meat and potatoes. -- @delim@ is an obscure delimiter with which to intercalate the argv list, -- @fmt@ is the OptPattern together with metadata to tell the parser how to parse args. --- Together, these let @buildOptParser@ build a parsec parser that can be applied to an argv. +-- Together, these let @buildOptParser@ build a parsec parser that can be applied to an argv. buildOptParser :: String -> OptFormat -> CharParser OptParserState () -buildOptParser delim fmt@(pattern, infomap) = - +buildOptParser delim fmt@(pattern, infomap) = + let -- Helpers argDelim = (try $ string delim) "space between arguments" - + makeParser p = buildOptParser delim (p, infomap) - - argDelimIfNotInShortOptStack = do - st <- getState + + argDelimIfNotInShortOptStack = do + st <- getState if not $ inShortOptStack st then optional argDelim else return () @@ -41,20 +41,20 @@ updateSt_assertPresent opt = updateOptWith (\opt info _ -> assertPresent opt info) opt "" updateSt_inShortOptStack = updateState . updateInShortOptStack - + in case pattern of (Sequence pats) -> - assertTopConsumesAll $ foldl (andThen) (return ()) ps + assertTopConsumesAll $ foldl (andThen) (return ()) ps where assertTopConsumesAll p = do st <- getState if inTopLevelSequence st - then do + then do updateState $ \st -> st {inTopLevelSequence = False} p <* eof - else p + else p inner_pats = (\pat -> (pat, infomap)) `map` pats ps = (buildOptParser delim) `map` inner_pats - andThen = \p1 p2 -> do + andThen = \p1 p2 -> do p1 argDelimIfNotInShortOptStack p2 @@ -69,8 +69,8 @@ argDelimIfNotInShortOptStack makeParser $ Unordered rest (Optional pat) -> - case pat of - Unordered ps -> case ps of + case pat of + Unordered ps -> case ps of p:[] -> makeParser $ Optional p _ -> optional $ choice $ (parseThisThenRest ps) `map` ps where parseThisThenRest list pat = try $ do @@ -78,27 +78,27 @@ let rest = list \\ [pat] argDelimIfNotInShortOptStack makeParser $ Optional $ Unordered rest - _ -> optional $ try $ makeParser pat + _ -> optional $ try $ makeParser pat (Repeated pat) -> do - case pat of + case pat of (Optional p) -> (try $ makeParser p) `sepBy` argDelimIfNotInShortOptStack _ -> (try $ makeParser pat) `sepBy1` argDelimIfNotInShortOptStack return () - (Atom pat) -> case pat of + (Atom pat) -> case pat of o@(ShortOption c) -> do st <- getState if inShortOptStack st then return () else char '-' >> return () char c updateState $ updateInShortOptStack True - val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap - then try $ do + val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap + then try $ do optional $ string "=" <|> argDelim updateState $ updateInShortOptStack False manyTill1 anyChar (lookAhead_ argDelim <|> eof) else do stillInShortStack <- isNotFollowedBy argDelim - unless stillInShortStack $ - updateState $ updateInShortOptStack False + unless stillInShortStack $ + updateState $ updateInShortOptStack False return "" updateState $ withEachSynonym o $ \pa syn info -> saveOccurrence syn info val pa @@ -106,8 +106,8 @@ o@(LongOption name) -> do string "--" string name - val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap - then do + val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap + then do string "=" <|> argDelim --many (notFollowedBy (string delim) >> anyChar) manyTill1 anyChar (lookAhead_ argDelim <|> eof) @@ -122,7 +122,7 @@ --synparsers = oneOf `map` synlists oneOfSyns = map (\ss -> OneOf (map Atom ss)) synlists unorderedSynParser = buildOptParser delim (Unordered oneOfSyns, infomap) - in unorderedSynParser + in unorderedSynParser humanize o o@(Argument name) -> do val <- try $ many1 (notFollowedBy argDelim >> anyChar) @@ -154,7 +154,7 @@ saveOccurrence opt info newval argmap = M.alter updateCurrentVal opt argmap where updateCurrentVal m_oldval = case m_oldval of Nothing -> (newval `updateFrom`) =<< (optInitialValue info opt) - Just oldval -> newval `updateFrom` oldval + Just oldval -> newval `updateFrom` oldval updateFrom newval oldval = Just $ case oldval of MultiValue vs -> MultiValue $ newval : vs Value v -> Value newval @@ -166,42 +166,42 @@ assertPresent :: Option -> OptionInfo -> Arguments -> Arguments assertPresent opt info argmap = saveOccurrence opt info "" argmap -withEachSynonym :: Option -> - (Arguments -> Option -> OptionInfo -> Arguments) -> - OptParserState -> +withEachSynonym :: Option -> + (Arguments -> Option -> OptionInfo -> Arguments) -> + OptParserState -> OptParserState -withEachSynonym opt savefn st = +withEachSynonym opt savefn st = let infomap = optInfoMap st args = parsedArgs st syns = synonyms $ M.findWithDefault (fromSynList []) opt infomap -- give the savefn each opt's info, as well - foldsavefn = \args opt -> + foldsavefn = \args opt -> let info = M.findWithDefault (fromSynList []) opt infomap - in savefn args opt info + in savefn args opt info in st {parsedArgs = foldl foldsavefn args syns} optInitialValue :: OptionInfo -> Option -> Maybe ArgValue -optInitialValue info opt = - let repeatable = isRepeated info +optInitialValue info opt = + let repeatable = isRepeated info in case opt of Command name -> Just $ if repeatable then Counted 0 else NotPresent Argument name -> Just $ if repeatable then MultiValue [] else NoValue AnyOption -> Nothing -- no storable value for [options] shortcut - _ -> case expectsVal info of + _ -> case expectsVal info of True -> Just $ if repeatable then MultiValue [] else NoValue False -> Just $ if repeatable then Counted 0 else NotPresent optDefaultValue :: OptionInfo -> Option -> Maybe ArgValue -optDefaultValue info opt = +optDefaultValue info opt = let repeatable = isRepeated info - in case opt of + in case opt of Command name -> Just $ if repeatable then Counted 0 else NotPresent Argument name -> Just $ if repeatable then MultiValue [] else NoValue AnyOption -> Nothing -- no storable value for [options] shortcut - _ -> case expectsVal info of + _ -> case expectsVal info of True -> case defaultVal info of - Just dval -> Just $ if repeatable + Just dval -> Just $ if repeatable then MultiValue $ reverse $ words dval else Value dval Nothing -> Just $ if repeatable then MultiValue [] else NoValue @@ -209,15 +209,16 @@ getArguments :: OptFormat -> [String] -> Either ParseError Arguments -getArguments optfmt argv = +getArguments optfmt argv = let (pattern, infomap) = optfmt -- delimiter used to flatten argv to parsable String - delim = "«»" + -- TODO: parse argv without a nasty intercalate hack + delim = "«»" argvString = delim `intercalate` argv p = parsedArgs <$> (returnState $ buildOptParser delim optfmt) - + patAtoms = atoms pattern infoKeys = (\\ [AnyOption]) $ M.keys infomap allAtoms = nub $ patAtoms ++ infoKeys diff --git a/System/Console/Docopt/Public.hs b/System/Console/Docopt/Public.hs --- a/System/Console/Docopt/Public.hs +++ b/System/Console/Docopt/Public.hs @@ -1,63 +1,86 @@ -module System.Console.Docopt.Public +module System.Console.Docopt.Public ( - -- everything locally declared - module System.Console.Docopt.Public, + -- * Command line arguments parsers + parseArgs + , parseArgsOrExit - -- public types - Option(), - Arguments(), + -- *** Re-exported from Parsec + , ParseError + + -- * Parsed usage string + , Docopt () + , usage + , exitWithUsage + , exitWithUsageMessage + + -- * Argument lookup + , Option() + , Arguments() + + -- ** Query functions + , isPresent + , notPresent + , getArg + , getArgOrExitWith + , getArgWithDefault + , getAllArgs + , getArgCount + + -- ** 'Option' constructors + , command + , argument + , shortOption + , longOption + + -- ** Deprecated + , getAllArgsM + , notPresentM + , isPresentM + , getFirstArg ) where -import System.Environment (getArgs) import System.Exit import Data.Map as M hiding (null) - -import Control.Applicative - -import System.Console.Docopt.ParseUtils +import Data.Maybe (fromMaybe) import System.Console.Docopt.Types -import System.Console.Docopt.UsageParse (pDocopt) -import System.Console.Docopt.OptParse (getArguments) +import System.Console.Docopt.ApplicativeParsec (ParseError) +import System.Console.Docopt.OptParse --- * Public API - --- ** Main option parsing entry points - -optionsWithUsage :: String -> [String] -> IO Arguments -optionsWithUsage usage rawArgs = - case runParser pDocopt M.empty "Usage" usage of - Left err -> do putStrLn usage - exitFailure - Right fmt -> case getArguments fmt rawArgs of - Left err -> do putStrLn usage - exitFailure - Right parsedArgs -> return parsedArgs +-- | Parse command line arguments. +parseArgs :: Docopt -> [String] -> Either ParseError Arguments +parseArgs parser = getArguments (optFormat parser) -optionsWithUsageDebug :: String -> [String] -> IO Arguments -optionsWithUsageDebug usage rawArgs = - case runParser pDocopt M.empty "Usage" usage of - Left err -> fail $ show err - Right fmt -> case getArguments fmt rawArgs of - Left err -> fail $ show err - Right parsedArgs -> return parsedArgs +-- | Same as 'parseArgs', but 'exitWithUsage' on parse failure. E.g. +-- +-- > args <- parseArgsOrExit patterns =<< getArgs +parseArgsOrExit :: Docopt -> [String] -> IO Arguments +parseArgsOrExit parser argv = either (const $ exitWithUsage parser) return $ parseArgs parser argv -optionsWithUsageFile :: FilePath -> IO Arguments -optionsWithUsageFile path = do usageStr <- readFile path - rawArgs <- getArgs - optionsWithUsage usageStr rawArgs +-- | Exit after printing usage text. +exitWithUsage :: Docopt -> IO a +exitWithUsage doc = do + putStr $ usage doc + exitFailure -optionsWithUsageFileDebug :: FilePath -> IO Arguments -optionsWithUsageFileDebug path = do usageStr <- readFile path - rawArgs <- getArgs - optionsWithUsageDebug usageStr rawArgs +-- | Exit after printing a custom message followed by usage text. +-- Intended for convenience when more context can be given about what went wrong. +exitWithUsageMessage :: Docopt -> String -> IO a +exitWithUsageMessage doc msg = do + putStrLn msg + putStrLn "" + exitWithUsage doc --- ** Option lookup methods +-- Query functions +------------------ +-- | 'True' if an option was present at all in an invocation. +-- +-- Useful with 'longOption's and 'shortOption's, and in conjunction with 'Control.Monad.when'. isPresent :: Arguments -> Option -> Bool -isPresent args opt = +isPresent args opt = case opt `M.lookup` args of Nothing -> False Just val -> case val of @@ -65,56 +88,53 @@ NotPresent -> False _ -> True -isPresentM :: Monad m => Arguments -> Option -> m Bool -isPresentM args o = return $ isPresent args o - notPresent :: Arguments -> Option -> Bool -notPresent args o = not $ isPresent args o - -notPresentM :: Monad m => Arguments -> Option -> m Bool -notPresentM args o = return $ not $ isPresent args o - -getArg :: Monad m => Arguments -> Option -> m String -getArg args opt = - let failure = fail $ "no argument given: " ++ show opt - in case opt `M.lookup` args of - Nothing -> failure - Just val -> case val of - MultiValue (v:vs) -> return v - Value v -> return v - _ -> failure +notPresent = (not .) . isPresent -getFirstArg :: Monad m => Arguments -> Option -> m String -getFirstArg args opt = - let failure = fail $ "no argument given: " ++ show opt - in case opt `M.lookup` args of - Nothing -> failure - Just val -> case val of - MultiValue vs -> if null vs then failure else return $ last vs - Value v -> return v - _ -> failure +-- | 'Just' the value of the argument supplied, or 'Nothing' if one was not given. +-- +-- If the option's presence is required by your 'Docopt' usage text +-- (e.g. a positional argument), as in +-- +-- > Usage: +-- > prog +-- +-- then @getArg args (argument \'required\')@ is guaranteed to be a 'Just'. +getArg :: Arguments -> Option -> Maybe String +getArg args opt = + case opt `M.lookup` args of + Nothing -> Nothing + Just val -> case val of + MultiValue (v:_) -> Just v + Value v -> Just v + _ -> Nothing +-- | Same as 'getArg', but 'exitWithUsage' if 'Nothing'. +-- +-- As in 'getArg', if your usage pattern required the option, 'getArgOrExitWith' will not exit. +getArgOrExitWith :: Docopt -> Arguments -> Option -> IO String +getArgOrExitWith doc args opt = exitUnless $ getArg args opt + where exitUnless = maybe (exitWithUsageMessage doc $ "argument expected for: " ++ show opt) return +-- | Same as 'getArg', but eliminate 'Nothing' with a default argument. getArgWithDefault :: Arguments -> String -> Option -> String -getArgWithDefault args def opt = - case args `getArg` opt of - Just val -> val - Nothing -> def +getArgWithDefault args def opt = fromMaybe def (args `getArg` opt) +-- | Returns all occurrences of a repeatable option, e.g. @\...@. getAllArgs :: Arguments -> Option -> [String] -getAllArgs args opt = +getAllArgs args opt = case opt `M.lookup` args of - Nothing -> [] - Just val -> case val of - MultiValue vs -> reverse vs - Value v -> [v] - _ -> [] - -getAllArgsM :: Monad m => Arguments -> Option -> m [String] -getAllArgsM o e = return $ getAllArgs o e + Nothing -> [] + Just val -> case val of + MultiValue vs -> reverse vs + Value v -> [v] + _ -> [] +-- | Return the number of occurrences of an option in an invocation. +-- +-- Useful with repeatable flags, e.g. @[ -v | -vv | -vvv]@. getArgCount :: Arguments -> Option -> Int -getArgCount args opt = +getArgCount args opt = case opt `M.lookup` args of Nothing -> 0 Just val -> case val of @@ -125,16 +145,47 @@ _ -> 0 --- ** Public Option constructor functions +-- Option constructors +---------------------- +-- | For @Usage: prog cmd@, ask for @command \"cmd\"@. command :: String -> Option -command s = Command s +command = Command +-- | For @Usage: prog \@, ask for @argument \"file\"@. argument :: String -> Option -argument s = Argument s +argument = Argument +-- | For @Usage: prog -h@, ask for @shortOption \'h\'@. shortOption :: Char -> Option -shortOption c = ShortOption c +shortOption = ShortOption +-- | For @Usage: prog --version@, ask for @shortOption \"version\"@. longOption :: String -> Option -longOption s = LongOption s +longOption = LongOption + +-- Deprecated +------------- + +{-# DEPRECATED getAllArgsM "Monadic query functions will soon be removed" #-} +getAllArgsM :: Monad m => Arguments -> Option -> m [String] +getAllArgsM o e = return $ getAllArgs o e + +{-# DEPRECATED notPresentM "Monadic query functions will soon be removed" #-} +notPresentM :: Monad m => Arguments -> Option -> m Bool +notPresentM args o = return $ not $ isPresent args o + +{-# DEPRECATED isPresentM "Monadic query functions will soon be removed" #-} +isPresentM :: Monad m => Arguments -> Option -> m Bool +isPresentM args o = return $ isPresent args o + +{-# DEPRECATED getFirstArg "Use 'getAllArgs' instead" #-} +getFirstArg :: Monad m => Arguments -> Option -> m String +getFirstArg args opt = + let failure = fail $ "no argument given: " ++ show opt + in case opt `M.lookup` args of + Nothing -> failure + Just val -> case val of + MultiValue vs -> if null vs then failure else return $ last vs + Value v -> return v + _ -> failure diff --git a/System/Console/Docopt/QQ.hs b/System/Console/Docopt/QQ.hs new file mode 100644 --- /dev/null +++ b/System/Console/Docopt/QQ.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK prune #-} +module System.Console.Docopt.QQ + ( + -- * QuasiQuoter usage parsers + docopt + , docoptFile + ) where + +import qualified Data.Map as M + +import System.Console.Docopt.Types +import System.Console.Docopt.QQ.Instances () +import System.Console.Docopt.ApplicativeParsec +import System.Console.Docopt.UsageParse + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +parseFmt :: FilePath -> String -> Either ParseError OptFormat +parseFmt = runParser pDocopt M.empty + +docoptExp :: String -> Q Exp +docoptExp usg = do + let mkDocopt fmt = Docopt { usage = usg, optFormat = fmt } + loc <- loc_filename <$> location + case mkDocopt <$> parseFmt loc usg of + Left err -> fail $ show err + Right parser -> [| parser |] + +-- | A 'QuasiQuoter' which parses a usage string and returns a +-- 'Docopt'. +-- +-- Example usage: +-- +-- @ +-- patterns :: Docopt +-- patterns = [docopt| +-- docopt-sample version 0.1.0 +-- +-- Usage: +-- docopt-sample cat \ +-- docopt-sample echo [--caps] \ +-- +-- Options: +-- -c, --caps Caps-lock the echoed argument +-- |] +-- @ +-- +-- For help with the docopt usage format, see +-- . +docopt :: QuasiQuoter +docopt = QuasiQuoter { quoteExp = docoptExp + , quoteDec = unsupported "Declaration" + , quotePat = unsupported "Pattern" + , quoteType = unsupported "Type" + } + where unsupported = fail . (++ " context unsupported") + +-- | Same as 'docopt', but parses the given file instead of a literal +-- string. +-- +-- Example: +-- +-- @ +-- patterns :: Docopt +-- patterns = [docoptFile|USAGE|] +-- @ +-- +-- where @USAGE@ is the name of a file which contains the usage +-- string (relative to the directory from which ghc is invoked). +docoptFile :: QuasiQuoter +docoptFile = quoteFile docopt diff --git a/System/Console/Docopt/QQ/Instances.hs b/System/Console/Docopt/QQ/Instances.hs new file mode 100644 --- /dev/null +++ b/System/Console/Docopt/QQ/Instances.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide, prune #-} +module System.Console.Docopt.QQ.Instances where + +import System.Console.Docopt.Types +import Language.Haskell.TH.Lift + +import qualified Data.Map as M + +instance (Lift k, Lift v) => Lift (M.Map k v) where + lift m = [| M.fromList assoc |] + where assoc = M.toList m + +$(deriveLiftMany [ ''Option + , ''Pattern + , ''OptionInfo + , ''Docopt + ]) diff --git a/System/Console/Docopt/Types.hs b/System/Console/Docopt/Types.hs --- a/System/Console/Docopt/Types.hs +++ b/System/Console/Docopt/Types.hs @@ -28,6 +28,7 @@ atoms (Repeated p) = atoms p atoms (Atom a) = [a] +-- | A named leaf node of the usage pattern tree data Option = LongOption Name | ShortOption Char | Command Name @@ -47,13 +48,13 @@ -- | Used when parsing through the available option descriptions. -- Holds a list of synonymous options, Maybe a default value (if specified), --- an expectsVal :: Bool that indicates whether this option is a flag (--flag) --- or an option that needs an argument (--opt=arg), and isRepeated :: Bool +-- an expectsVal :: Bool that indicates whether this option is a flag (--flag) +-- or an option that needs an argument (--opt=arg), and isRepeated :: Bool -- that indicates whether this option is always single or needs to be accumulated -data OptionInfo = OptionInfo +data OptionInfo = OptionInfo { synonyms :: [Option] , defaultVal :: Maybe String - , expectsVal :: Bool + , expectsVal :: Bool , isRepeated :: Bool } deriving (Show, Eq) @@ -71,8 +72,8 @@ -- Used to build the actual command-line arg parser. type OptFormat = (OptPattern, OptInfoMap) --- | -data OptParserState = OptParserState +-- | +data OptParserState = OptParserState { optInfoMap :: OptInfoMap , parsedArgs :: Arguments , inShortOptStack :: Bool @@ -98,3 +99,8 @@ -- (in order of last to first, if multiple values encountered) type Arguments = Map Option ArgValue +-- | An abstract data type which represents Docopt usage patterns. +data Docopt = Docopt { optFormat :: OptFormat + -- | Retrieve the original usage string. + , usage :: String + } diff --git a/docopt.cabal b/docopt.cabal --- a/docopt.cabal +++ b/docopt.cabal @@ -1,5 +1,5 @@ name: docopt -version: 0.6.0.2 +version: 0.7.0.0 synopsis: A command-line interface parser that will make you smile description: Docopt parses command-line interface usage text that adheres to a familiar syntax, and from it builds a command-line argument parser that will ensure your program is invoked correctly with the available options specified in the usage text. This allows the developer to write a usage text and get an argument parser for free. @@ -7,9 +7,8 @@ license-file: LICENSE.txt author: Ryan Artecona maintainer: ryanartecona@gmail.com -copyright: (c) 2013 Ryan Artecona +copyright: (c) 2013-2015 Ryan Artecona -stability: Experimental category: Console build-type: Simple @@ -18,9 +17,18 @@ homepage: https://github.com/docopt/docopt.hs bug-reports: https://github.com/docopt/docopt.hs/issues +extra-source-files: README.md + CHANGELOG.md + +flag template-haskell + default: True + manual: True + description: + Build with QuasiQuoter usage parsers, which requires Template Haskell + library - exposed-modules: System.Console.Docopt - + exposed-modules: System.Console.Docopt.NoTH + other-modules: System.Console.Docopt.ApplicativeParsec System.Console.Docopt.ParseUtils System.Console.Docopt.Types @@ -31,6 +39,15 @@ build-depends: base == 4.*, parsec == 3.1.*, containers + + ghc-options: -Wall -fno-warn-unused-do-bind + + if impl(ghc >= 6.10) && flag(template-haskell) + exposed-modules: System.Console.Docopt + other-modules: System.Console.Docopt.QQ + System.Console.Docopt.QQ.Instances + build-depends: template-haskell >= 2.7 && < 3.0, + th-lift >= 0.7 && < 1.0 test-suite tests type: exitcode-stdio-1.0