optparse-applicative 0.4.3 → 0.5.0
raw patch · 19 files changed
+589/−381 lines, 19 files
Files
- Options/Applicative/Arrows.hs +2/−1
- Options/Applicative/BashCompletion.hs +15/−15
- Options/Applicative/Builder.hs +33/−175
- Options/Applicative/Builder/Arguments.hs +85/−0
- Options/Applicative/Builder/Completer.hs +4/−3
- Options/Applicative/Builder/Internal.hs +122/−0
- Options/Applicative/Common.hs +55/−42
- Options/Applicative/Extra.hs +50/−25
- Options/Applicative/Help.hs +10/−10
- Options/Applicative/Internal.hs +73/−26
- Options/Applicative/Types.hs +45/−14
- Options/Applicative/Utils.hs +1/−1
- README.md +34/−36
- optparse-applicative.cabal +9/−1
- tests/Examples/Cabal.hs +13/−13
- tests/Examples/Commands.hs +2/−2
- tests/Examples/Hello.hs +5/−5
- tests/Tests.hs +28/−12
- tests/commands.err.txt +3/−0
Options/Applicative/Arrows.hs view
@@ -33,7 +33,8 @@ ) where import Control.Arrow-import Control.Category+import Control.Category (Category(..))+ import Options.Applicative import Prelude hiding ((.), id)
Options/Applicative/BashCompletion.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE PatternGuards #-} module Options.Applicative.BashCompletion ( bashCompletionParser ) where -import Control.Applicative+import Control.Applicative ((<$>), (<*>), many) import Data.Foldable (asum)-import Data.List-import Data.Maybe-import System.Exit+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe)+import System.Exit (ExitCode(..)) import Options.Applicative.Builder import Options.Applicative.Common@@ -24,11 +23,11 @@ complParser = asum [ failure <$> ( bashCompletionQuery parser pprefs- <$> (many . strOption) (long "bash-completion-word" & internal)- <*> option (long "bash-completion-index" & internal) )+ <$> (many . strOption) (long "bash-completion-word" <> internal)+ <*> option (long "bash-completion-index" <> internal) ) , failure <$> (bashCompletionScript <$>- strOption (long "bash-completion-script" & internal)) ]+ strOption (long "bash-completion-script" <> internal)) ] bashCompletionQuery :: Parser a -> ParserPrefs -> [String] -> Int -> String -> IO [String] bashCompletionQuery parser pprefs ws i _ = case runCompletion compl pprefs of@@ -42,10 +41,10 @@ . mapParser (\_ -> opt_completions) opt_completions opt = case optMain opt of- OptReader ns _ -> show_names ns- FlagReader ns _ -> show_names ns- ArgReader rdr -> run_completer (crCompleter rdr)- CmdReader ns _ -> filter_names ns+ OptReader ns _ _ -> show_names ns+ FlagReader ns _ -> show_names ns+ ArgReader rdr -> run_completer (crCompleter rdr)+ CmdReader ns _ -> filter_names ns show_name (OptShort c) = '-':[c] show_name (OptLong name) = "--" ++ name@@ -58,9 +57,10 @@ (ws', ws'') = splitAt i ws - is_completion- | (w:_) <- ws'' = isPrefixOf w- | otherwise = const True+ is_completion =+ case ws'' of+ w:_ -> isPrefixOf w+ _ -> const True compl = do setParser Nothing parser
Options/Applicative/Builder.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveFunctor #-} module Options.Applicative.Builder ( -- * Parser builders --@@ -13,13 +12,15 @@ -- -- > out = strOption -- > ( long "output"- -- > & short 'o'- -- > & metavar "FILENAME" )+ -- > <> short 'o'+ -- > <> metavar "FILENAME" ) -- -- creates a parser for an option called \"output\". subparser, argument,+ argument', arguments,+ arguments1, flag, flag', switch,@@ -36,6 +37,8 @@ showDefault, metavar, reader,+ noArgError,+ ParseError(..), hidden, internal, command,@@ -44,6 +47,7 @@ completer, idm, (&),+ (<>), -- * Readers --@@ -52,15 +56,6 @@ str, disabled, - -- * Internals- Mod,- HasName,- HasCompleter,- OptionFields,- FlagFields,- CommandFields,- ArgumentFields,- -- * Builder for 'ParserInfo' InfoMod, fullDesc,@@ -78,93 +73,30 @@ prefs ) where -import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.Monoid+import Control.Applicative (pure, (<|>))+import Data.Monoid (Monoid (..), (<>)) import Options.Applicative.Builder.Completer+import Options.Applicative.Builder.Arguments+import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Types -data OptionFields a = OptionFields- { optNames :: [OptName]- , optCompleter :: Completer- , optReader :: String -> Maybe a }- deriving Functor--data FlagFields a = FlagFields- { flagNames :: [OptName]- , flagActive :: a }- deriving Functor--data CommandFields a = CommandFields- { cmdCommands :: [(String, ParserInfo a)] }- deriving Functor--data ArgumentFields a = ArgumentFields- { argCompleter :: Completer }- deriving Functor--class HasName f where- name :: OptName -> f a -> f a--instance HasName OptionFields where- name n fields = fields { optNames = n : optNames fields }--instance HasName FlagFields where- name n fields = fields { flagNames = n : flagNames fields }--class HasCompleter f where- modCompleter :: (Completer -> Completer) -> f a -> f a--instance HasCompleter OptionFields where- modCompleter f p = p { optCompleter = f (optCompleter p) }--instance HasCompleter ArgumentFields where- modCompleter f p = p { argCompleter = f (argCompleter p) }---- mod ----data DefaultProp a = DefaultProp- (Maybe a)- (Maybe (a -> String))--instance Monoid (DefaultProp a) where- mempty = DefaultProp Nothing Nothing- mappend (DefaultProp d1 s1) (DefaultProp d2 s2) =- DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)--data Mod f a = Mod (f a -> f a)- (DefaultProp a)- (OptProperties -> OptProperties)--optionMod :: (OptProperties -> OptProperties) -> Mod f a-optionMod = Mod id mempty--fieldMod :: (f a -> f a) -> Mod f a-fieldMod f = Mod f mempty id--instance Monoid (Mod f a) where- mempty = Mod id mempty id- Mod f1 d1 g1 `mappend` Mod f2 d2 g2- = Mod (f2 . f1) (d2 <> d1) (g2 . g1)- -- readers -- -- | 'Option' reader based on the 'Read' type class.-auto :: Read a => String -> Maybe a+auto :: Monad m => Read a => String -> m a auto arg = case reads arg of- [(r, "")] -> Just r- _ -> Nothing+ [(r, "")] -> return r+ _ -> fail "Cannot parse value" -- | String 'Option' reader.-str :: String -> Maybe String-str = Just+str :: Monad m => String -> m String+str = return -- | Null 'Option' reader. All arguments will fail validation.-disabled :: String -> Maybe a-disabled = const Nothing+disabled :: Monad m => String -> m a+disabled = const . fail $ "Disabled option" -- modifiers -- @@ -193,9 +125,13 @@ help s = optionMod $ \p -> p { propHelp = s } -- | Specify the 'Option' reader.-reader :: (String -> Maybe a) -> Mod OptionFields a+reader :: (String -> Either ParseError a) -> Mod OptionFields a reader f = fieldMod $ \p -> p { optReader = f } +-- | Specify the error to display when no argument is provided to this option.+noArgError :: ParseError -> Mod OptionFields a+noArgError e = fieldMod $ \p -> p { optNoArgError = e }+ -- | Specify the metavariable. metavar :: String -> Mod f a metavar var = optionMod $ \p -> p { propMetaVar = var }@@ -205,10 +141,6 @@ hidden = optionMod $ \p -> p { propVisibility = min Hidden (propVisibility p) } --- | Hide this option from the help text-internal :: Mod f a-internal = optionMod $ \p -> p { propVisibility = Internal }- -- | Add a command to a subparser option. command :: String -> ParserInfo a -> Mod CommandFields a command cmd pinfo = fieldMod $ \p ->@@ -230,94 +162,18 @@ -- A completer is a function String -> IO String which, given a partial -- argument, returns all possible completions for that argument. completer :: HasCompleter f => Completer -> Mod f a-completer f = fieldMod $ modCompleter (<> f)+completer f = fieldMod $ modCompleter (`mappend` f) -- parsers -- --- | Base default properties.-baseProps :: OptProperties-baseProps = OptProperties- { propMetaVar = ""- , propVisibility = Visible- , propHelp = ""- , propShowDefault = Nothing }--mkParser :: DefaultProp a- -> (OptProperties -> OptProperties)- -> OptReader a- -> Parser a-mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def- where- opt = mkOption d g rdr--mkOption :: DefaultProp a- -> (OptProperties -> OptProperties)- -> OptReader a- -> Option a-mkOption d g rdr = Option rdr (mkProps d g)--mkProps :: DefaultProp a- -> (OptProperties -> OptProperties)- -> OptProperties-mkProps (DefaultProp def sdef) g = props- where- props = (g baseProps)- { propShowDefault = sdef <*> def }-- -- | Builder for a command parser. The 'command' modifier can be used to -- specify individual commands. subparser :: Mod CommandFields a -> Parser a subparser m = mkParser d g rdr where- Mod f d g = m & metavar "COMMAND"+ Mod f d g = m <> metavar "COMMAND" CommandFields cmds = f (CommandFields []) rdr = CmdReader (map fst cmds) (`lookup` cmds)---- | Builder for an argument parser.-argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a-argument p (Mod f d g) = mkParser d g (ArgReader rdr)- where- ArgumentFields compl = f (ArgumentFields mempty)- rdr = CReader compl p---- | Builder for an argument list parser. All arguments are collected and--- returned as a list.------ Note that arguments starting with @'-'@ are ignored.------ This parser accepts a special argument: @--@. When a @--@ is found on the--- command line, all following arguments are included in the result, even if--- they start with @'-'@.-arguments :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]-arguments p m = set_default <$> fromM args- where- Mod f (DefaultProp def sdef) g = m- show_def = sdef <*> def-- p' ('-':_) = Nothing- p' s = p s-- props = mkProps mempty g- props' = (mkProps mempty g) { propShowDefault = show_def }-- args = do- mx <- oneM $ optional arg_or_ddash- case mx of- Nothing -> return []- Just Nothing -> manyM arg- Just (Just x) -> (x:) <$> args- arg_or_ddash = (Just <$> arg') <|> (ddash *> pure Nothing)- set_default [] = fromMaybe [] def- set_default xs = xs-- arg = liftOpt (Option (ArgReader (CReader compl p)) props)- arg' = liftOpt (Option (ArgReader (CReader compl p')) props')-- ddash = argument (guard . (== "--")) internal-- ArgumentFields compl = f (ArgumentFields mempty)- -- | Builder for a flag parser. -- -- A flag that switches from a \"default value\" to an \"active value\" when@@ -358,18 +214,18 @@ nullOption :: Mod OptionFields a -> Parser a nullOption m = mkParser d g rdr where- Mod f d g = metavar "ARG" <> m- fields = f (OptionFields [] mempty disabled)+ Mod f d g = metavar "ARG" `mappend` m+ fields = f (OptionFields [] mempty disabled (ErrorMsg "")) crdr = CReader (optCompleter fields) (optReader fields)- rdr = OptReader (optNames fields) crdr+ rdr = OptReader (optNames fields) crdr (optNoArgError fields) -- | Builder for an option taking a 'String' argument. strOption :: Mod OptionFields String -> Parser String-strOption m = nullOption $ reader str & m+strOption m = nullOption $ reader str <> m -- | Builder for an option using the 'auto' reader. option :: Read a => Mod OptionFields a -> Parser a-option m = nullOption $ reader auto & m+option m = nullOption $ reader auto <> m -- | Modifier for 'ParserInfo'. newtype InfoMod a = InfoMod@@ -433,7 +289,8 @@ where base = ParserPrefs { prefMultiSuffix = ""- , prefDisambiguate = False }+ , prefDisambiguate = False+ , prefShowHelpOnError = False } -- convenience shortcuts @@ -442,5 +299,6 @@ idm = mempty -- | Compose modifiers.+{-# DEPRECATED (&) "Use (<>) instead" #-} (&) :: Monoid m => m -> m -> m (&) = mappend
+ Options/Applicative/Builder/Arguments.hs view
@@ -0,0 +1,85 @@+module Options.Applicative.Builder.Arguments+ ( argument+ , argument'+ , arguments+ , arguments1+ ) where++import Control.Applicative ((<$>), pure, (<*>), optional, (<|>), (*>))+import Control.Monad (guard)+import Data.Maybe (fromMaybe)+import Data.Monoid (mempty)++import Options.Applicative.Builder.Internal+import Options.Applicative.Common+import Options.Applicative.Types++skipOpts :: (String -> Maybe a) -> String -> Maybe a+skipOpts _ ('-':_) = Nothing+skipOpts rdr s = rdr s++-- | Builder for an argument parser.+argument' :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a+argument' p (Mod f d g) = mkParser d g (ArgReader rdr)+ where+ ArgumentFields compl = f (ArgumentFields mempty)+ rdr = CReader compl p++-- | Builder for an argument parser ignoring arguments starting with '-'.+argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a+argument p = argument' (skipOpts p)++-- | Builder for an argument list parser. All arguments are collected and+-- returned as a list.+--+-- Note that arguments starting with @'-'@ are ignored.+--+-- This parser accepts a special argument: @--@. When a @--@ is found on the+-- command line, all following arguments are included in the result, even if+-- they start with @'-'@.+arguments :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]+arguments = arguments_ True++-- | Like `arguments`, but require at least one argument.+arguments1 :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]+arguments1 = arguments_ False++-- | Builder for an argument list parser. All arguments are collected and+-- returned as a list.+--+-- Note that arguments starting with @'-'@ are ignored.+--+-- This parser accepts a special argument: @--@. When a @--@ is found on the+-- command line, all following arguments are included in the result, even if+-- they start with @'-'@.+arguments_ :: Bool -> (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]+arguments_ allow_empty p m = set_default <$> fromM args1+ where+ Mod f (DefaultProp def sdef) g = m+ show_def = sdef <*> def++ props = mkProps mempty g+ props' = (mkProps mempty g) { propShowDefault = show_def }++ args1 | allow_empty = args+ | otherwise = do+ mx <- oneM arg_or_ddash+ case mx of+ Nothing -> someM arg+ Just x -> (x:) <$> args+ args = do+ mx <- oneM $ optional arg_or_ddash+ case mx of+ Nothing -> return []+ Just Nothing -> manyM arg+ Just (Just x) -> (x:) <$> args+ arg_or_ddash = (Just <$> arg') <|> (ddash *> pure Nothing)+ set_default [] = fromMaybe [] def+ set_default xs = xs++ arg = liftOpt (Option (ArgReader (CReader compl p)) props)+ arg' = liftOpt (Option (ArgReader (CReader compl (skipOpts p))) props')++ ddash = argument' (guard . (== "--")) internal++ ArgumentFields compl = f (ArgumentFields mempty)
Options/Applicative/Builder/Completer.hs view
@@ -4,11 +4,12 @@ , bashCompleter ) where -import Control.Applicative+import Control.Applicative ((<$>), pure) import Control.Exception (IOException, try)-import Data.List+import Data.List (isPrefixOf)+import System.Process (readProcess)+ import Options.Applicative.Types-import System.Process listIOCompleter :: IO [String] -> Completer listIOCompleter ss = Completer $ \s ->
+ Options/Applicative/Builder/Internal.hs view
@@ -0,0 +1,122 @@+module Options.Applicative.Builder.Internal (+ -- * Internals+ Mod(..),+ HasName(..),+ HasCompleter(..),+ OptionFields(..),+ FlagFields(..),+ CommandFields(..),+ ArgumentFields(..),+ DefaultProp(..),++ optionMod,+ fieldMod,++ baseProps,+ mkParser,+ mkOption,+ mkProps,++ internal+ ) where++import Control.Applicative (pure, (<*>), empty, (<|>))+import Control.Monad (mplus)+import Data.Monoid (Monoid(..))++import Options.Applicative.Common+import Options.Applicative.Types++data OptionFields a = OptionFields+ { optNames :: [OptName]+ , optCompleter :: Completer+ , optReader :: String -> Either ParseError a+ , optNoArgError :: ParseError }++data FlagFields a = FlagFields+ { flagNames :: [OptName]+ , flagActive :: a }++data CommandFields a = CommandFields+ { cmdCommands :: [(String, ParserInfo a)] }++data ArgumentFields a = ArgumentFields+ { argCompleter :: Completer }++class HasName f where+ name :: OptName -> f a -> f a++instance HasName OptionFields where+ name n fields = fields { optNames = n : optNames fields }++instance HasName FlagFields where+ name n fields = fields { flagNames = n : flagNames fields }++class HasCompleter f where+ modCompleter :: (Completer -> Completer) -> f a -> f a++instance HasCompleter OptionFields where+ modCompleter f p = p { optCompleter = f (optCompleter p) }++instance HasCompleter ArgumentFields where+ modCompleter f p = p { argCompleter = f (argCompleter p) }++-- mod --++data DefaultProp a = DefaultProp+ (Maybe a)+ (Maybe (a -> String))++instance Monoid (DefaultProp a) where+ mempty = DefaultProp Nothing Nothing+ mappend (DefaultProp d1 s1) (DefaultProp d2 s2) =+ DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)++data Mod f a = Mod (f a -> f a)+ (DefaultProp a)+ (OptProperties -> OptProperties)++optionMod :: (OptProperties -> OptProperties) -> Mod f a+optionMod = Mod id mempty++fieldMod :: (f a -> f a) -> Mod f a+fieldMod f = Mod f mempty id++instance Monoid (Mod f a) where+ mempty = Mod id mempty id+ Mod f1 d1 g1 `mappend` Mod f2 d2 g2+ = Mod (f2 . f1) (d2 `mappend` d1) (g2 . g1)++-- | Base default properties.+baseProps :: OptProperties+baseProps = OptProperties+ { propMetaVar = ""+ , propVisibility = Visible+ , propHelp = ""+ , propShowDefault = Nothing }++mkParser :: DefaultProp a+ -> (OptProperties -> OptProperties)+ -> OptReader a+ -> Parser a+mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def+ where+ opt = mkOption d g rdr++mkOption :: DefaultProp a+ -> (OptProperties -> OptProperties)+ -> OptReader a+ -> Option a+mkOption d g rdr = Option rdr (mkProps d g)++mkProps :: DefaultProp a+ -> (OptProperties -> OptProperties)+ -> OptProperties+mkProps (DefaultProp def sdef) g = props+ where+ props = (g baseProps)+ { propShowDefault = sdef <*> def }++-- | Hide this option from the help text+internal :: Mod f a+internal = optionMod $ \p -> p { propVisibility = Internal }
Options/Applicative/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-} module Options.Applicative.Common ( -- * Option parsers --@@ -44,17 +44,17 @@ optionNames ) where -import Control.Applicative-import Control.Monad-import Data.List-import Data.Maybe-import Data.Monoid+import Control.Applicative (pure, (<*>), (<$>), (<|>), empty)+import Control.Monad (guard, msum)+import Data.List (isPrefixOf)+import Data.Maybe (maybeToList, isJust)+import Data.Monoid (Monoid(..)) import Options.Applicative.Internal import Options.Applicative.Types optionNames :: OptReader a -> [OptName]-optionNames (OptReader names _) = names+optionNames (OptReader names _ _) = names optionNames (FlagReader names _) = names optionNames _ = [] @@ -80,40 +80,42 @@ optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (Matcher m a) optMatches disambiguate opt arg = case opt of- OptReader names rdr- | Just (arg1, val) <- parsed- , has_name arg1 names- -> Just $ \args -> do- let mb_args = uncons $ maybeToList val ++ args- (arg', args') <- maybe (missingArgP (crCompleter rdr)) return mb_args- r <- liftMaybe $ crReader rdr arg'- return (r, args')- | otherwise -> Nothing- FlagReader names x- | Just (arg1, Nothing) <- parsed- , has_name arg1 names- -> Just $ \args -> return (x, args)- ArgReader rdr- | Just result <- crReader rdr arg- -> Just $ \args -> return (result, args)- CmdReader _ f- | Just subp <- f arg- -> Just $ \args -> do- setContext (Just arg) subp- runParser (infoParser subp) args- _ -> Nothing+ OptReader names rdr no_arg_err -> do+ (arg1, val) <- parsed+ guard $ has_name arg1 names+ return $ \args -> do+ let mb_args = uncons $ maybeToList val ++ args+ let missing_arg = missingArgP no_arg_err (crCompleter rdr)+ (arg', args') <- maybe missing_arg return mb_args+ r <- liftEither (crReader rdr arg')+ return (r, args')+ FlagReader names x -> do+ (arg1, Nothing) <- parsed+ guard $ has_name arg1 names+ return $ \args -> return (x, args)+ ArgReader rdr -> do+ result <- crReader rdr arg+ return $ \args -> return (result, args)+ CmdReader _ f ->+ flip fmap (f arg) $ \subp args -> do+ setContext (Just arg) subp+ x <- tryP $ runParser (infoParser subp) args+ case x of+ Left e -> errorP e+ Right r -> return r where- parsed- | '-' : '-' : arg1 <- arg- = case span (/= '=') arg1 of- (_, "") -> Just (OptLong arg1, Nothing)- (arg1', _ : rest) -> Just (OptLong arg1', Just rest)- | '-' : arg1 <- arg- = case arg1 of- [] -> Nothing- [a] -> Just (OptShort a, Nothing)- (a : rest) -> Just (OptShort a, Just rest)- | otherwise = Nothing+ parsed =+ case arg of+ '-' : '-' : arg1 ->+ Just $+ case span (/= '=') arg1 of+ (_, "") -> (OptLong arg1, Nothing)+ (arg1', _ : rest) -> (OptLong arg1', Just rest)+ '-' : arg1 ->+ case arg1 of+ [] -> Nothing+ (a : rest) -> Just (OptShort a, if null rest then Nothing else Just rest)+ _ -> Nothing has_name a | disambiguate = any (isOptionPrefix a) | otherwise = elem a@@ -155,7 +157,9 @@ prefs <- getPrefs x <- tryP $ do_step prefs arg argt case x of- Left e -> liftMaybe result <|> errorP e+ Left e -> case (result, e) of+ (Just r, ErrorMsg _) -> return r+ _ -> errorP e Right (p', args') -> runParser p' args' where result = (,) <$> evalParser p <*> pure args@@ -165,8 +169,17 @@ [m] -> m _ -> empty | otherwise- = msum parses+ = case parses of+ [] -> parseError arg+ (m : _) -> m where parses = stepParser prefs p arg argt++parseError :: MonadP m => String -> m a+parseError arg = errorP . ErrorMsg $ msg+ where+ msg = case arg of+ ('-':_) -> "Invalid option `" ++ arg ++ "'"+ _ -> "Invalid argument `" ++ arg ++ "'" runParserFully :: MonadP m => Parser a -> [String] -> m a runParserFully p args = do
Options/Applicative/Extra.hs view
@@ -11,7 +11,11 @@ ParserFailure(..), ) where -import Control.Applicative+import Control.Applicative ((<$>), (<|>))+import System.Environment (getArgs, getProgName)+import System.Exit (exitWith, ExitCode(..))+import System.IO (hPutStr, stderr)+ import Options.Applicative.BashCompletion import Options.Applicative.Common import Options.Applicative.Builder hiding (briefDesc)@@ -19,19 +23,18 @@ import Options.Applicative.Internal import Options.Applicative.Utils import Options.Applicative.Types-import System.Environment-import System.Exit-import System.IO -- | A hidden \"helper\" option which always fails. helper :: Parser (a -> a) helper = nullOption ( long "help"- & short 'h'- & help "Show this help text"- & value id- & metavar ""- & hidden )+ <> reader (const (Left ShowHelpText))+ <> noArgError ShowHelpText+ <> short 'h'+ <> help "Show this help text"+ <> value id+ <> metavar ""+ <> hidden ) -- | Run a program description. --@@ -68,24 +71,50 @@ (Right r, _) -> case r of Result a -> Right a Extra failure -> Left failure- (Left msg, ctx) -> Left ParserFailure- { errMessage = \progn- -> with_context ctx pinfo $ \names ->- return- . parserHelpText pprefs- . add_error msg- . add_usage names progn- , errExitCode = ExitFailure (infoFailureCode pinfo) }+ (Left msg, ctx) -> Left $+ parserFailure pprefs pinfo msg ctx where parser = infoParser pinfo+ parser' = (Extra <$> bashCompletionParser parser pprefs)+ <|> (Result <$> parser)+ p = runParserFully parser' args++parserFailure :: ParserPrefs -> ParserInfo a+ -> ParseError -> Context+ -> ParserFailure+parserFailure pprefs pinfo msg ctx = ParserFailure+ { errMessage = \progn+ -> with_context ctx pinfo $ \names ->+ return+ . show_help+ . add_error+ . add_usage names progn+ , errExitCode = ExitFailure (infoFailureCode pinfo) }+ where add_usage names progn i = i { infoHeader = vcat- [ infoHeader i- , usage pprefs (infoParser i) ename ] }+ ( header_line i +++ [ usage pprefs (infoParser i) ename ] ) } where ename = unwords (progn : names)- add_error msg i = i- { infoHeader = vcat [msg, infoHeader i] }+ add_error i = i+ { infoHeader = vcat (error_msg ++ [infoHeader i]) }+ error_msg = case msg of+ ShowHelpText -> []+ ErrorMsg m -> [m]+ show_full_help = case msg of+ ShowHelpText -> True+ _ -> prefShowHelpOnError pprefs+ show_help i+ | show_full_help+ = parserHelpText pprefs i+ | otherwise+ = unlines $ filter (not . null) [ infoHeader i ]+ header_line i+ | show_full_help+ = [ infoHeader i ]+ | otherwise+ = [] with_context :: Context -> ParserInfo a@@ -93,10 +122,6 @@ -> c with_context NullContext i f = f [] i with_context (Context n i) _ f = f n i-- parser' = (Extra <$> bashCompletionParser parser pprefs)- <|> (Result <$> parser)- p = runParserFully parser' args -- | Generate option summary. usage :: ParserPrefs -> Parser a -> String -> String
Options/Applicative/Help.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards #-} module Options.Applicative.Help ( cmdDesc, briefDesc,@@ -6,8 +5,9 @@ parserHelpText, ) where -import Data.List-import Data.Maybe+import Data.List (intercalate, sort)+import Data.Maybe (maybeToList, catMaybes)+ import Options.Applicative.Common import Options.Applicative.Types import Options.Applicative.Utils@@ -56,13 +56,13 @@ cmdDesc :: Parser a -> [String] cmdDesc = concat . mapParser desc where- desc _ opt- | CmdReader cmds p <- optMain opt- = tabulate [(cmd, d)- | cmd <- reverse cmds- , d <- maybeToList . fmap infoProgDesc $ p cmd ]- | otherwise- = []+ desc _ opt =+ case optMain opt of+ CmdReader cmds p ->+ tabulate [(cmd, d)+ | cmd <- reverse cmds+ , d <- maybeToList . fmap infoProgDesc $ p cmd ]+ _ -> [] -- | Generate a brief help text for a parser. briefDesc :: ParserPrefs -> Parser a -> String
Options/Applicative/Internal.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE GADTs, FlexibleInstances #-}+{-# LANGUAGE GADTs #-} module Options.Applicative.Internal ( P , Context(..) , MonadP(..)+ , ParseError(..) , uncons , liftMaybe+ , liftEither , runP @@ -15,14 +17,16 @@ , ComplError(..) ) where -import Control.Applicative-import Control.Monad-import Control.Monad.Trans.Class+import Control.Applicative (Applicative(..), Alternative(..), (<$>))+import Control.Monad (MonadPlus(..), liftM, ap)+import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Error+ (runErrorT, ErrorT, Error(..), throwError, catchError) import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Data.Maybe-import Data.Monoid+ (runReader, runReaderT, Reader, ReaderT, ask)+import Control.Monad.Trans.Writer (runWriterT, WriterT, tell)+import Data.Maybe (maybeToList)+import Data.Monoid (Monoid(..)) import Options.Applicative.Types @@ -31,13 +35,33 @@ setParser :: Maybe String -> Parser a -> m () getPrefs :: m ParserPrefs - missingArgP :: Completer -> m a- tryP :: m a -> m (Either String a)- errorP :: String -> m a+ missingArgP :: ParseError -> Completer -> m a+ tryP :: m a -> m (Either ParseError a)+ errorP :: ParseError -> m a exitP :: Parser b -> Maybe a -> m a -type P = ErrorT String (WriterT Context (Reader ParserPrefs))+newtype P a = P (ErrorT ParseError (WriterT Context (Reader ParserPrefs)) a) +instance Functor P where+ fmap f (P m) = P $ fmap f m++instance Applicative P where+ pure a = P $ pure a+ P f <*> P a = P $ f <*> a++instance Alternative P where+ empty = P empty+ P x <|> P y = P $ x <|> y++instance Monad P where+ return a = P $ return a+ P x >>= k = P $ x >>= \a -> case k a of P y -> y++instance MonadPlus P where+ mzero = P mzero+ mplus (P x) (P y) = P $ mplus x y++ data Context where Context :: [String] -> ParserInfo a -> Context NullContext :: Context@@ -52,21 +76,24 @@ mappend c _ = c instance MonadP P where- setContext name = lift . tell . Context (maybeToList name)+ setContext name = P . lift . tell . Context (maybeToList name) setParser _ _ = return ()- getPrefs = lift . lift $ ask+ getPrefs = P . lift . lift $ ask - missingArgP _ = empty- tryP p = lift $ runErrorT p- exitP _ = maybe mzero return- errorP = throwError+ missingArgP e _ = errorP e+ tryP (P p) = P $ lift $ runErrorT p+ exitP _ = P . liftMaybe+ errorP = P . throwError liftMaybe :: MonadPlus m => Maybe a -> m a liftMaybe = maybe mzero return -runP :: P a -> ParserPrefs -> (Either String a, Context)-runP = runReader . runWriterT . runErrorT+liftEither :: MonadP m => Either ParseError a -> m a+liftEither = either errorP return +runP :: P a -> ParserPrefs -> (Either ParseError a, Context)+runP (P p) = runReader . runWriterT . runErrorT $ p+ uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing uncons (x : xs) = Just (x, xs)@@ -100,20 +127,40 @@ ComplParser p -> ComplParser p ComplOption c -> ComplOption c -type Completion = ErrorT String (ReaderT ParserPrefs ComplResult)+newtype Completion a =+ Completion (ErrorT ParseError (ReaderT ParserPrefs ComplResult) a) +instance Functor Completion where+ fmap f (Completion m) = Completion $ fmap f m++instance Applicative Completion where+ pure a = Completion $ pure a+ Completion f <*> Completion a = Completion $ f <*> a++instance Alternative Completion where+ empty = Completion empty+ Completion x <|> Completion y = Completion $ x <|> y++instance Monad Completion where+ return a = Completion $ return a+ Completion x >>= k = Completion $ x >>= \a -> case k a of Completion y -> y++instance MonadPlus Completion where+ mzero = Completion mzero+ mplus (Completion x) (Completion y) = Completion $ mplus x y+ instance MonadP Completion where setContext _ _ = return () setParser _ _ = return ()- getPrefs = lift ask+ getPrefs = Completion $ lift ask - missingArgP = lift . lift . ComplOption- tryP p = catchError (Right <$> p) (return . Left)- exitP p _ = lift . lift . ComplParser $ SomeParser p- errorP = throwError+ missingArgP _ = Completion . lift . lift . ComplOption+ tryP (Completion p) = Completion $ catchError (Right <$> p) (return . Left)+ exitP p _ = Completion . lift . lift . ComplParser $ SomeParser p+ errorP = Completion . throwError runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)-runCompletion c prefs = case runReaderT (runErrorT c) prefs of+runCompletion (Completion c) prefs = case runReaderT (runErrorT c) prefs of ComplResult _ -> Nothing ComplParser p' -> Just $ Left p' ComplOption compl -> Just $ Right compl
Options/Applicative/Types.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE GADTs, DeriveFunctor, Rank2Types #-}+{-# LANGUAGE GADTs, Rank2Types #-} module Options.Applicative.Types (+ ParseError(..), ParserInfo(..), ParserPrefs(..), @@ -19,6 +20,7 @@ fromM, oneM, manyM,+ someM, optVisibility, optMetaVar,@@ -27,11 +29,20 @@ ) where import Control.Applicative-import Control.Monad-import Control.Monad.Trans.Error-import Data.Monoid-import System.Exit+ (Applicative(..), Alternative(..), (<$>), optional)+import Control.Monad (ap, liftM)+import Control.Monad.Trans.Error (Error(..))+import Data.Monoid (Monoid(..))+import System.Exit (ExitCode(..)) +data ParseError+ = ErrorMsg String+ | ShowHelpText+ deriving Show++instance Error ParseError where+ strMsg = ErrorMsg+ -- | A full description for a runnable 'Parser' for a program. data ParserInfo a = ParserInfo { infoParser :: Parser a -- ^ the option parser for the program@@ -40,12 +51,16 @@ , infoHeader :: String -- ^ header of the full parser description , infoFooter :: String -- ^ footer of the full parser description , infoFailureCode :: Int -- ^ exit code for a parser failure- } deriving Functor+ } +instance Functor ParserInfo where+ fmap f i = i { infoParser = fmap f (infoParser i) }+ -- | Global preferences for a top-level 'Parser'. data ParserPrefs = ParserPrefs { prefMultiSuffix :: String -- ^ metavar suffix for multiple options , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations+ , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors } data OptName = OptShort !Char@@ -71,21 +86,34 @@ data Option a = Option { optMain :: OptReader a -- ^ reader for this option , optProps :: OptProperties -- ^ properties of this option- } deriving Functor+ } -data CReader a = CReader+instance Functor Option where+ fmap f (Option m p) = Option (fmap f m) p++data CReader m a = CReader { crCompleter :: Completer- , crReader :: String -> Maybe a }- deriving Functor+ , crReader :: String -> m a } +instance Functor m => Functor (CReader m) where+ fmap f (CReader c r) = CReader c (fmap f . r)++type OptCReader = CReader (Either ParseError)+type ArgCReader = CReader Maybe+ -- | An 'OptReader' defines whether an option matches an command line argument. data OptReader a- = OptReader [OptName] (CReader a) -- ^ option reader+ = OptReader [OptName] (OptCReader a) ParseError -- ^ option reader | FlagReader [OptName] !a -- ^ flag reader- | ArgReader (CReader a) -- ^ argument reader+ | ArgReader (ArgCReader a) -- ^ argument reader | CmdReader [String] (String -> Maybe (ParserInfo a)) -- ^ command reader- deriving Functor +instance Functor OptReader where+ fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e+ fmap f (FlagReader ns x) = FlagReader ns (f x)+ fmap f (ArgReader cr) = ArgReader (fmap f cr)+ fmap f (CmdReader cs g) = CmdReader cs ((fmap . fmap) f . g)+ -- | A @Parser a@ is an option parser returning a value of type 'a'. data Parser a where NilP :: Maybe a -> Parser a@@ -132,6 +160,9 @@ Nothing -> return [] Just x -> (x:) <$> manyM p +someM :: Parser a -> ParserM [a]+someM p = (:) <$> oneM p <*> manyM p+ instance Alternative Parser where empty = NilP Nothing (<|>) = AltP@@ -166,7 +197,7 @@ = Leaf a | MultNode [OptTree a] | AltNode [OptTree a]- deriving (Functor, Show)+ deriving Show optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps
Options/Applicative/Utils.hs view
@@ -5,7 +5,7 @@ pad ) where -import Data.List+import Data.List (intercalate) -- | Concatenate two strings with a space in the middle. (<+>) :: String -> String -> String
README.md view
@@ -18,11 +18,11 @@ sample = Sample <$> strOption ( long "hello"- & metavar "TARGET"- & help "Target for the greeting" )+ <> metavar "TARGET"+ <> help "Target for the greeting" ) <*> switch ( long "quiet"- & help "Whether to be quiet" )+ <> help "Whether to be quiet" ) ``` The parser is built using [applicative style][applicative] starting from a set@@ -41,19 +41,22 @@ where opts = info (helper <*> sample) ( fullDesc- & progDesc "Print a greeting for TARGET"- & header "hello - a test for optparse-applicative" )+ <> progDesc "Print a greeting for TARGET"+ <> header "hello - a test for optparse-applicative" ) ``` The `greet` function is the entry point of the program, while `opts` is a complete description of the program, used when generating a help text. The-`helper` combinator takes any parser, and adds a `help` option to it (which-always fails).+`helper` combinator takes any parser, and adds a `help` option to it. The `hello` option in this example is mandatory (since it doesn't have a-default value), so running the program without any argument will display the-help text:+default value), so running the program without any argument will display a+short option summary: + Usage: hello --hello TARGET [--quiet]++Running the program with the `--help` option will display the full help text:+ hello - a test for optparse-applicative Usage: hello --hello TARGET [--quiet]@@ -64,8 +67,7 @@ --hello TARGET Target for the greeting --quiet Whether to be quiet -containing a short usage summary, and a detailed list of options with-descriptions.+containing a detailed list of options with descriptions. [applicative]: http://www.soi.city.ac.uk/~ross/papers/Applicative.html @@ -111,10 +113,10 @@ ```haskell strOption-( long "output"-& short 'o'-& metavar "FILE"-& help "Write output to FILE" )+ ( long "output"+ <> short 'o'+ <> metavar "FILE"+ <> help "Write output to FILE" ) ``` creates a regular option with a string argument (which can be referred to as@@ -130,9 +132,9 @@ lineCount :: Parser Int lineCount = option ( long "lines"- & short 'n'- & metavar "K"- & help "Output the last K lines" )+ <> short 'n'+ <> metavar "K"+ <> help "Output the last K lines" ) ``` specifies a regular option with an `Int` argument. We added an explicit type@@ -151,8 +153,8 @@ parseFluxCapacitor :: String -> Maybe FluxCapacitor option-( long "flux-capacitor"-& reader parseFluxCapacitor )+ ( long "flux-capacitor"+ <> reader parseFluxCapacitor ) ``` ### Flags@@ -168,9 +170,9 @@ data Verbosity = Normal | Verbose flag Normal Verbose-( long "verbose"-& short 'v'-& help "Enable verbose mode"+ ( long "verbose"+ <> short 'v'+ <> help "Enable verbose mode" ``` is a flag parser returning a `Verbosity` value.@@ -179,8 +181,8 @@ ```haskell switch-( long "keep-tmp-files"-& help "Retain all intermediate temporary files" )+ ( long "keep-tmp-files"+ <> help "Retain all intermediate temporary files" ) ``` ### Arguments@@ -216,10 +218,10 @@ ```haskell subparser-( command "add" (info addOptions- ( progDesc "Add a file to the repository" ))-& command "commit" (info commitOptions- ( progDesc "Record changes to the repository" ))+ ( command "add" (info addOptions+ ( progDesc "Add a file to the repository" ))+ <> command "commit" (info commitOptions+ ( progDesc "Record changes to the repository" )) ) ``` @@ -254,7 +256,7 @@ opts :: Parser (IO ()) opts = subparser ( command "start" (info (start <$> argument str idm) idm)- & command "stop" (info (pure stop) idm) )+ <> command "stop" (info (pure stop) idm) ) main :: IO () main = join $ execParser (info opts idm)@@ -271,11 +273,7 @@ combined with other parsers using normal `Applicative` combinators. Modifiers are instances of the `Monoid` typeclass, so they can be combined-using the composition function `mappend`, for which the-`Options.Applicative.Builders` module provides a convenience alias `(&)`.--Feel free to use `mappend` or `(<>)`, if you prefer. `(&)` is mostly there for-backwards compatibility with the previous implementation.+using the composition function `mappend` (or simply `(<>)`). See the haddock documentation for `Options.Applicative.Builder` for a full list of builders and modifiers.@@ -298,7 +296,7 @@ opts :: Parser Options opts = runA $ proc () -> do- verbosity <- asA (option (short 'v' & value 0)) -< ()+ verbosity <- asA (option (short 'v' <> value 0)) -< () let verbose = verbosity > 0 args <- asA (arguments str idm) -< () returnA -< Options args verbose
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name: optparse-applicative-version: 0.4.3+version: 0.5.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser:@@ -82,18 +82,25 @@ homepage: https://github.com/pcapriotti/optparse-applicative bug-reports: https://github.com/pcapriotti/optparse-applicative/issues +source-repository head+ type: git+ location: https://github.com/pcapriotti/optparse-applicative.git+ library exposed-modules: Options.Applicative, Options.Applicative.Arrows, Options.Applicative.BashCompletion, Options.Applicative.Builder,+ Options.Applicative.Builder.Arguments, Options.Applicative.Builder.Completer,+ Options.Applicative.Builder.Internal, Options.Applicative.Common, Options.Applicative.Extra, Options.Applicative.Help, Options.Applicative.Types, Options.Applicative.Utils other-modules: Options.Applicative.Internal+ ghc-options: -Wall build-depends: base == 4.*, transformers >= 0.2 && < 0.4, process == 1.1.*@@ -101,6 +108,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Tests.hs+ ghc-options: -Wall build-depends: base == 4.*, HUnit == 1.2.*, optparse-applicative,
tests/Examples/Cabal.hs view
@@ -39,13 +39,13 @@ ( command "install" (info installParser (progDesc "Installs a list of packages"))- & command "update"+ <> command "update" (info updateParser (progDesc "Updates list of known packages"))- & command "configure"+ <> command "configure" (info configureParser (progDesc "Prepare to build the package"))- & command "build"+ <> command "build" (info buildParser (progDesc "Make this package ready for installation")) ) -< () A helper -< Args opts cmds@@ -54,10 +54,10 @@ commonOpts = CommonOpts <$> option ( short 'v'- & long "verbose"- & metavar "LEVEL"- & help "Set verbosity to LEVEL"- & value 0 )+ <> long "verbose"+ <> metavar "LEVEL"+ <> help "Set verbosity to LEVEL"+ <> value 0 ) installParser :: Parser Command installParser = runA $ proc () -> do@@ -86,12 +86,12 @@ configureOpts = runA $ proc () -> do tests <- (asA . switch) ( long "enable-tests"- & help "Enable compilation of test suites" ) -< ()+ <> help "Enable compilation of test suites" ) -< () flags <- (asA . many . strOption) ( short 'f'- & long "flags"- & metavar "FLAGS"- & help "Enable the given flag" ) -< ()+ <> long "flags"+ <> metavar "FLAGS"+ <> help "Enable the given flag" ) -< () returnA -< ConfigureOpts tests flags buildParser :: Parser Command@@ -103,8 +103,8 @@ buildOpts = runA $ proc () -> do bdir <- (asA . strOption) ( long "builddir"- & metavar "DIR"- & value "dist" ) -< ()+ <> metavar "DIR"+ <> value "dist" ) -< () returnA -< BuildOpts bdir pinfo :: ParserInfo Args
tests/Examples/Commands.hs view
@@ -16,7 +16,7 @@ ( command "hello" (info hello (progDesc "Print greeting"))- & command "goodbye"+ <> command "goodbye" (info (pure Goodbye) (progDesc "Say goodbye")) )@@ -26,7 +26,7 @@ run Goodbye = putStrLn "Goodbye." opts :: ParserInfo Sample-opts = info sample idm+opts = info (sample <**> helper) idm main :: IO () main = execParser opts >>= run
tests/Examples/Hello.hs view
@@ -11,11 +11,11 @@ sample = Sample <$> strOption ( long "hello"- & metavar "TARGET"- & help "Target for the greeting" )+ <> metavar "TARGET"+ <> help "Target for the greeting" ) <*> switch ( long "quiet"- & help "Whether to be quiet" )+ <> help "Whether to be quiet" ) greet :: Sample -> IO () greet (Sample h False) = putStrLn $ "Hello, " ++ h@@ -27,5 +27,5 @@ opts :: ParserInfo Sample opts = info (sample <**> helper) ( fullDesc- & progDesc "Print a greeting for TARGET"- & header "hello - a test for optparse-applicative" )+ <> progDesc "Print a greeting for TARGET"+ <> header "hello - a test for optparse-applicative" )
tests/Tests.hs view
@@ -87,9 +87,9 @@ case_show_default :: Assertion case_show_default = do let p = option ( short 'n'- & help "set count"- & value (0 :: Int)- & showDefault)+ <> help "set count"+ <> value (0 :: Int)+ <> showDefault) i = info (p <**> helper) idm result = run i ["--help"] case result of@@ -114,19 +114,19 @@ let p = p1 <|> p2 <|> p3 p1 = (Just . Left) <$> strOption ( long "virtual-machine"- & metavar "VM"- & help "Virtual machine name" )+ <> metavar "VM"+ <> help "Virtual machine name" ) p2 = (Just . Right) <$> strOption ( long "cloud-service"- & metavar "CS"- & help "Cloud service name" )+ <> metavar "CS"+ <> help "Cloud service name" ) p3 = flag' Nothing ( long "dry-run" ) i = info (p <**> helper) idm checkHelpText "alt" i ["--help"] case_nested_commands :: Assertion case_nested_commands = do- let p3 = strOption (short 'a' & metavar "A")+ let p3 = strOption (short 'a'<> metavar "A") p2 = subparser (command "b" (info p3 idm)) p1 = subparser (command "c" (info p2 idm)) i = info (p1 <**> helper) idm@@ -167,8 +167,8 @@ case_completion :: Assertion case_completion = do let p = (,)- <$> strOption (long "foo" & value "")- <*> strOption (long "bar" & value "")+ <$> strOption (long "foo"<> value "")+ <*> strOption (long "bar"<> value "") i = info p idm result = run i ["--bash-completion-index", "0"] case result of@@ -195,13 +195,29 @@ case_issue_19 = do let p = option ( short 'x'- & reader (Just . str)- & value Nothing )+ <> reader (fmap Just . str)+ <> value Nothing ) i = info (p <**> helper) idm result = run i ["-x", "foo"] case result of Left _ -> assertFailure "unexpected parse error" Right r -> Just "foo" @=? r++case_arguments1_none :: Assertion+case_arguments1_none = do+ let p = arguments1 str idm+ i = info (p <**> helper) idm+ result = run i []+ assertLeft result $ \(ParserFailure _ _) -> return ()++case_arguments1_some :: Assertion+case_arguments1_some = do+ let p = arguments1 str idm+ i = info (p <**> helper) idm+ result = run i ["foo", "--", "bar", "baz"]+ case result of+ Left _ -> assertFailure "unexpected parse error"+ Right r -> ["foo", "bar", "baz"] @=? r main :: IO () main = $(defaultMainGenerator)
tests/commands.err.txt view
@@ -1,5 +1,8 @@ Usage: commands COMMAND +Available options:+ -h,--help Show this help text+ Available commands: hello Print greeting goodbye Say goodbye