diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} module Options.Applicative.Builder ( -- * Parser builders -- @@ -23,6 +24,7 @@ argument, arguments, flag, + flag', switch, nullOption, strOption, @@ -35,8 +37,8 @@ value, metavar, reader, - hide, - multi, + hidden, + internal, transform, command, idm, @@ -44,7 +46,7 @@ -- * Readers -- - -- | A collection of basic option readers. + -- | A collection of basic 'Option' readers. auto, str, disabled, @@ -56,19 +58,25 @@ FlagFields, CommandFields, - -- * Builder for `ParserInfo` + -- * Builder for 'ParserInfo' InfoMod, fullDesc, header, progDesc, footer, failureCode, - info + info, + + -- * Builder for 'ParserPrefs' + PrefsMod, + multiSuffix, + prefs ) where import Control.Applicative import Control.Category import Control.Monad +import Data.Functor.Identity import Data.Lens.Common import Options.Applicative.Common @@ -79,12 +87,16 @@ data OptionFields a = OptionFields { _optNames :: [OptName] , _optReader :: String -> Maybe a } + deriving Functor data FlagFields a = FlagFields - { _flagNames :: [OptName] } + { _flagNames :: [OptName] + , _flagActive :: a } + deriving Functor data CommandFields a = CommandFields { _cmdCommands :: [(String, ParserInfo a)] } + deriving Functor optNames :: Lens (OptionFields a) [OptName] optNames = lens _optNames $ \x o -> o { _optNames = x } @@ -109,77 +121,67 @@ -- mod -- -data Mod f r a b = Mod (f r -> f r) (Option r a -> Option r b) +data Mod f a b = Mod (f a -> f b) (OptProperties a -> OptProperties b) -optionMod :: (Option r a -> Option r b) -> Mod f r a b +optionMod :: (OptProperties a -> OptProperties a) -> Mod f a a optionMod = Mod id -fieldMod :: (f r -> f r) -> Mod f r a a +fieldMod :: (f a -> f a) -> Mod f a a fieldMod f = Mod f id -instance Category (Mod f r) where +instance Category (Mod f) where id = Mod id id Mod f1 g1 . Mod f2 g2 = Mod (f1 . f2) (g1 . g2) -- readers -- --- | Option reader based on the 'Read' type class. +-- | 'Option' reader based on the 'Read' type class. auto :: Read a => String -> Maybe a auto arg = case reads arg of [(r, "")] -> Just r _ -> Nothing --- | String option reader. +-- | String 'Option' reader. str :: String -> Maybe String str = Just --- | Null option reader. All arguments will fail validation. +-- | Null 'Option' reader. All arguments will fail validation. disabled :: String -> Maybe a disabled = const Nothing -- modifiers -- -- | Specify a short name for an option. -short :: HasName f => Char -> Mod f r a a +short :: HasName f => Char -> Mod f a a short = fieldMod . name . OptShort -- | Specify a long name for an option. -long :: HasName f => String -> Mod f r a a +long :: HasName f => String -> Mod f a a long = fieldMod . name . OptLong -- | Specify a default value for an option. -value :: a -> Mod f r a a -value = optionMod . setL optDefault . Just +value :: a -> Mod f a a +value = optionMod . setL propDefault . Just -- | Specify the help text for an option. -help :: String -> Mod f r a a -help = optionMod . setL optHelp +help :: String -> Mod f a a +help = optionMod . setL propHelp --- | Specify the option reader. -reader :: (String -> Maybe r) -> Mod OptionFields r a a +-- | Specify the 'Option' reader. +reader :: (String -> Maybe a) -> Mod OptionFields a a reader = fieldMod . setL optReader -- | Specify the metavariable. -metavar :: String -> Mod f r a a -metavar = optionMod . setL optMetaVar +metavar :: String -> Mod f a a +metavar = optionMod . setL propMetaVar --- | Hide this option. -hide :: Mod f r a a -hide = optionMod $ optShow^=False +-- | Hide this option from the brief description. +hidden :: Mod f a a +hidden = optionMod $ propVisibility ^%= min Hidden --- | Create a multi-valued option. -multi :: Mod f r a [a] -multi = optionMod f - where - f opt = optCont ^%= (fmap (fmap reverse) . ) $ mkOptGroup [] - where - mkOptGroup xs = opt - { _optDefault = Just xs - , _optCont = mkCont xs } - mkCont xs r = do - p' <- getL optCont opt r - x <- evalParser p' - return $ liftOpt (mkOptGroup (x:xs)) +-- | Hide this option from the help text +internal :: Mod f a a +internal = optionMod $ propVisibility ^= Internal -- | Apply a transformation to the return value of this option. -- @@ -188,78 +190,110 @@ -- -- >strOption -- >( transform Just --- >, value Nothing ) -transform :: (a -> b) -> Mod f r a b -transform f = optionMod $ fmap f +-- >& value Nothing ) +transform :: Functor f => (a -> b) -> Mod f a b +transform f = Mod (fmap f) (fmap f) -- | Add a command to a subparser option. -command :: String -> ParserInfo r -> Mod CommandFields r a a +command :: String -> ParserInfo a -> Mod CommandFields a a command cmd pinfo = fieldMod $ cmdCommands^%=((cmd, pinfo):) -- parsers -- --- | Base default option. -baseOpts :: OptReader a -> Option a a -baseOpts opt = Option - { _optMain = opt - , _optMetaVar = "" - , _optShow = True - , _optCont = return . pure - , _optHelp = "" - , _optDefault = Nothing } +-- | Base default properties. +baseProps :: OptProperties a +baseProps = OptProperties + { _propMetaVar = "" + , _propVisibility = Visible + , _propHelp = "" + , _propDefault = Nothing } -- | Builder for a command parser. The 'command' modifier can be used to -- specify individual commands. -subparser :: Mod CommandFields a a b -> Parser b -subparser m = liftOpt . g . baseOpts $ opt +subparser :: Mod CommandFields a b -> Parser b +subparser m = liftOpt $ Option rdr (g baseProps) where Mod f g = m . metavar "COMMAND" CommandFields cmds = f (CommandFields []) - opt = CmdReader (map fst cmds) (`lookup` cmds) + rdr = CmdReader (map fst cmds) (`lookup` cmds) -- | Builder for an argument parser. -argument :: (String -> Maybe a) -> Mod f a a b -> Parser b -argument p (Mod _ g) = liftOpt . g . baseOpts $ ArgReader p +argument :: (String -> Maybe a) -> Mod Identity a b -> Parser b +argument p (Mod f g) = liftOpt $ Option (ArgReader p') (g baseProps) + where p' s = fmap (runIdentity . f . Identity) (p s) -- | Builder for an argument list parser. All arguments are collected and -- returned as a list. -arguments :: (String -> Maybe a) -> Mod f a [a] b -> Parser b -arguments p m = argument p (m . multi) +-- +-- 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 Identity a b -> Parser [b] +arguments p m = args + where + p' ('-':_) = Nothing + p' s = p s + args1 = ((Just <$> arg') <|> (ddash *> pure Nothing)) `BindP` \x -> case x of + Nothing -> many arg + Just a -> fmap (a:) args + args = args1 <|> pure [] + + arg' = argument p' m + arg = argument p m + + ddash = argument (guard . (== "--")) internal + -- | Builder for a flag parser. -- -- A flag that switches from a \"default value\" to an \"active value\" when -- encountered. For a simple boolean value, use `switch` instead. flag :: a -- ^ default value -> a -- ^ active value - -> Mod FlagFields a a b -- ^ option modifier + -> Mod FlagFields a b -- ^ option modifier -> Parser b -flag defv actv (Mod f g) = liftOpt . g . set_default . baseOpts $ rdr +flag defv actv m = flag' actv (m . value defv) + +-- | Builder for a flag parser without a default value. +-- +-- Same as 'flag', but with no default value. In particular, this flag will +-- never parse successfully by itself. +-- +-- It still makes sense to use it as part of a composite parser. For example +-- +-- > length <$> many (flag' () (short 't')) +-- +-- is a parser that counts the number of "-t" arguments on the command line. +flag' :: a -- ^ active value + -> Mod FlagFields a b -- ^ option modifier + -> Parser b +flag' actv (Mod f g) = liftOpt $ Option rdr (g baseProps) where - rdr = let fields = f (FlagFields []) - in FlagReader (fields^.flagNames) actv - set_default = optDefault ^= Just defv + rdr = let FlagFields ns actv' = f (FlagFields [] actv) + in FlagReader ns actv' -- | Builder for a boolean flag. -- -- > switch = flag False True -switch :: Mod FlagFields Bool Bool a -> Parser a +switch :: Mod FlagFields Bool a -> Parser a switch = flag False True -- | Builder for an option with a null reader. A non-trivial reader can be -- added using the 'reader' modifier. -nullOption :: Mod OptionFields a a b -> Parser b -nullOption (Mod f g) = liftOpt . g . baseOpts $ rdr +nullOption :: Mod OptionFields a b -> Parser b +nullOption (Mod f g) = liftOpt $ Option rdr (g baseProps) where rdr = let fields = f (OptionFields [] disabled) in OptReader (fields^.optNames) (fields^.optReader) -- | Builder for an option taking a 'String' argument. -strOption :: Mod OptionFields String String a -> Parser a +strOption :: Mod OptionFields String a -> Parser a strOption m = nullOption $ m . reader str -- | Builder for an option using the 'auto' reader. -option :: Read a => Mod OptionFields a a b -> Parser b +option :: Read a => Mod OptionFields a b -> Parser b option m = nullOption $ m . reader auto -- | Modifier for 'ParserInfo'. @@ -304,6 +338,27 @@ , _descFailureCode = 1 } } + +newtype PrefsModC a b = PrefsMod + { applyPrefsMod :: a -> b } + -- this newtype is just to define a Category instance, for consistency with + -- the other modifiers; we're only going to use it with a = b = ParserPrefs + +-- | Modifier for 'ParserPrefs'. +type PrefsMod = PrefsModC ParserPrefs ParserPrefs + +instance Category PrefsModC where + id = PrefsMod id + m1 . m2 = PrefsMod $ applyPrefsMod m1 . applyPrefsMod m2 + +multiSuffix :: String -> PrefsMod +multiSuffix s = PrefsMod $ prefMultiSuffix ^= s + +prefs :: PrefsMod -> ParserPrefs +prefs m = applyPrefsMod m base + where + base = ParserPrefs + { _prefMultiSuffix = "" } -- | Trivial option modifier. idm :: Category hom => hom a a diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -61,8 +61,8 @@ optionNames _ = [] -- | Create a parser composed of a single option. -liftOpt :: Option r a -> Parser a -liftOpt opt = ConsP (fmap const opt) (pure ()) +liftOpt :: Option a -> Parser a +liftOpt = OptP uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing @@ -126,14 +126,25 @@ stepParser :: Parser a -> String -> [String] -> P (Parser a, [String]) stepParser (NilP _) _ _ = empty -stepParser (ConsP opt p) arg args - | Just matcher <- optMatches (opt^.optMain) arg +stepParser (OptP opt) arg args + | Just matcher <- optMatches (opt ^. optMain) arg = do (r, args') <- matcher args - liftOpt' <- getL optCont opt r - return (liftOpt' <*> p, args') - | otherwise - = do (p', args') <- stepParser p arg args - return (ConsP opt p', args') + return (pure r, args') + | otherwise = empty +stepParser (MultP p1 p2) arg args = msum + [ do (p1', args') <- stepParser p1 arg args + return (p1' <*> p2, args') + , do (p2', args') <- stepParser p2 arg args + return (p1 <*> p2', args') ] +stepParser (AltP p1 p2) arg args = msum + [ do (p1', args') <- stepParser p1 arg args + return (p1' <|> p2, args') + , do (p2', args') <- stepParser p2 arg args + return (p1 <|> p2', args') ] +stepParser (BindP p k) arg args = do + (p', args') <- stepParser p arg args + x <- evalParser p' + return (k x, args') -- | Apply a 'Parser' to a command line, and return a result and leftover -- arguments. This function returns an error if any parsing error occurs, or @@ -159,13 +170,31 @@ -- | The default value of a 'Parser'. This function returns an error if any of -- the options don't have a default value. evalParser :: Parser a -> P a -evalParser (NilP r) = pure r -evalParser (ConsP opt p) = tryP (opt^.optDefault) <*> evalParser p +evalParser (NilP r) = tryP r +evalParser (OptP opt) = tryP (opt ^. optDefault) +evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2 +evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2 +evalParser (BindP p k) = evalParser p >>= evalParser . k -- | Map a polymorphic function over all the options of a parser, and collect -- the results. -mapParser :: (forall r x . Option r x -> b) +mapParser :: (forall x . OptHelpInfo -> Option x -> b) -> Parser a -> [b] -mapParser _ (NilP _) = [] -mapParser f (ConsP opt p) = f opt : mapParser f p +mapParser = go False False + where + has_default :: Parser a -> Bool + has_default p = case runP (evalParser p) of + (Left _, _) -> False + (Right _, _) -> True + + go :: Bool -> Bool + -> (forall x . OptHelpInfo -> Option x -> b) + -> Parser a -> [b] + go _ _ _ (NilP _) = [] + go m d f (OptP opt) = [f (OptHelpInfo m d') opt] + where d' = d || isJust (opt^.optDefault) + go m d f (MultP p1 p2) = go m d f p1 ++ go m d f p2 + go m d f (AltP p1 p2) = go m d' f p1 ++ go m d' f p2 + where d' = d || has_default p1 || has_default p2 + go _ d f (BindP p _) = go True d f p diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -27,16 +27,20 @@ & short 'h' & help "Show this help text" & value id - & hide ) + & hidden ) -- | Run a program description. -- -- Parse command line arguments. Display help text and exit if any parse error -- occurs. execParser :: ParserInfo a -> IO a -execParser pinfo = do +execParser = customExecParser (prefs idm) + +-- | Run a program description with custom preferences. +customExecParser :: ParserPrefs -> ParserInfo a -> IO a +customExecParser pprefs pinfo = do args <- getArgs - case execParserPure pinfo args of + case execParserPure pprefs pinfo args of Right a -> return a Left failure -> do progn <- getProgName @@ -44,16 +48,17 @@ exitWith (errExitCode failure) -- | A pure version 'execParser'. -execParserPure :: ParserInfo a -- ^ Description of the program to run +execParserPure :: ParserPrefs -- ^ Global preferences for this parser + -> ParserInfo a -- ^ Description of the program to run -> [String] -- ^ Program arguments -> Either ParserFailure a -execParserPure pinfo args = +execParserPure pprefs pinfo args = case runP p of (Right a, _) -> Right a (Left msg, ctx) -> Left ParserFailure { errMessage = \progn -> with_context ctx pinfo $ \name -> - parserHelpText + parserHelpText pprefs . add_error msg . add_usage name progn , errExitCode = ExitFailure (pinfo^.infoFailureCode) } @@ -61,7 +66,7 @@ parser = pinfo^.infoParser add_usage name progn i = modL infoHeader - (\h -> vcat [h, usage (i^.infoParser) ename]) + (\h -> vcat [h, usage pprefs (i^.infoParser) ename]) i where ename = maybe progn (\n -> progn ++ " " ++ n) name @@ -77,8 +82,8 @@ p = runParserFully parser args -- | Generate option summary. -usage :: Parser a -> String -> String -usage p progn = foldr (<+>) "" +usage :: ParserPrefs -> Parser a -> String -> String +usage pprefs p progn = foldr (<+>) "" [ "Usage:" , progn - , briefDesc p ] + , briefDesc pprefs p ] diff --git a/Options/Applicative/Help.hs b/Options/Applicative/Help.hs --- a/Options/Applicative/Help.hs +++ b/Options/Applicative/Help.hs @@ -24,30 +24,40 @@ , descSurround :: Bool } -- | Generate description for a single option. -optDesc :: OptDescStyle -> Option r a -> String -optDesc style opt = +optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> String +optDesc pprefs style info opt = let ns = optionNames $ opt^.optMain mv = opt^.optMetaVar descs = map showOption (sort ns) desc' = intercalate (descSep style) descs <+> mv + show_opt + | opt^.optVisibility == Hidden + = descHidden style + | otherwise + = opt^.optVisibility == Visible + suffix + | hinfoMulti info + = pprefs^.prefMultiSuffix + | otherwise + = "" render text - | not (opt^.optShow) && not (descHidden style) + | not show_opt = "" | null text || not (descSurround style) - = text - | isJust (opt^.optDefault) - = "[" ++ text ++ "]" + = text ++ suffix + | hinfoDefault info + = "[" ++ text ++ "]" ++ suffix | null (drop 1 descs) - = text + = text ++ suffix | otherwise - = "(" ++ text ++ ")" + = "(" ++ text ++ ")" ++ suffix in render desc' -- | Generate descriptions for commands. cmdDesc :: Parser a -> [String] cmdDesc = concat . mapParser desc where - desc opt + desc _ opt | CmdReader cmds p <- opt^.optMain = tabulate [(cmd, d) | cmd <- cmds @@ -56,8 +66,8 @@ = [] -- | Generate a brief help text for a parser. -briefDesc :: Parser a -> String -briefDesc = foldr (<+>) "" . mapParser (optDesc style) +briefDesc :: ParserPrefs -> Parser a -> String +briefDesc pprefs = foldr (<+>) "" . mapParser (optDesc pprefs style) where style = OptDescStyle { descSep = "|" @@ -65,14 +75,14 @@ , descSurround = True } -- | Generate a full help text for a parser. -fullDesc :: Parser a -> [String] -fullDesc = tabulate . catMaybes . mapParser doc +fullDesc :: ParserPrefs -> Parser a -> [String] +fullDesc pprefs = tabulate . catMaybes . mapParser doc where - doc opt + doc info opt | null n = Nothing | null h = Nothing | otherwise = Just (n, h) - where n = optDesc style opt + where n = optDesc pprefs style info opt h = opt^.optHelp style = OptDescStyle { descSep = "," @@ -80,11 +90,11 @@ , descSurround = False } -- | Generate the help text for a program. -parserHelpText :: ParserInfo a -> String -parserHelpText pinfo = unlines +parserHelpText :: ParserPrefs -> ParserInfo a -> String +parserHelpText pprefs pinfo = unlines $ nn [pinfo^.infoHeader] ++ [ " " ++ line | line <- nn [pinfo^.infoProgDesc] ] - ++ [ line | let opts = fullDesc p + ++ [ line | let opts = fullDesc pprefs p , not (null opts) , line <- ["", "Common options:"] ++ opts , pinfo^.infoFullDesc ] diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -2,6 +2,7 @@ module Options.Applicative.Types ( ParserInfo(..), ParserDesc(..), + ParserPrefs(..), Context(..), P, @@ -22,15 +23,22 @@ Option(..), OptName(..), OptReader(..), + OptProperties(..), + OptVisibility(..), Parser(..), ParserFailure(..), + OptHelpInfo(..), optMain, optDefault, - optShow, + optVisibility, optHelp, optMetaVar, - optCont + propDefault, + propVisibility, + propHelp, + propMetaVar, + prefMultiSuffix, ) where import Control.Applicative @@ -58,6 +66,11 @@ , _descFailureCode :: Int -- ^ exit code for a parser failure } +-- | Global preferences for a top-level 'Parser'. +data ParserPrefs = ParserPrefs + { _prefMultiSuffix :: String -- ^ metavar suffix for multiple options + } + data Context where Context :: Maybe String -> ParserInfo a -> Context NullContext :: Context @@ -73,14 +86,26 @@ | OptLong !String deriving (Eq, Ord) +-- | Visibility of an option in the help text. +data OptVisibility + = Internal -- ^ does not appear in the help text at all + | Hidden -- ^ only visible in the full description + | Visible -- ^ visible both in the full and brief descriptions + deriving (Eq, Ord) + -- | Specification for an individual parser option. -data Option r a = Option - { _optMain :: OptReader r -- ^ reader for this option - , _optDefault :: Maybe a -- ^ default value - , _optShow :: Bool -- ^ whether this flag is shown is the brief description - , _optHelp :: String -- ^ help text for this option - , _optMetaVar :: String -- ^ metavariable for this option - , _optCont :: r -> P (Parser a) } -- ^ option continuation +data OptProperties a = OptProperties + { _propDefault :: Maybe a -- ^ default value + , _propVisibility :: OptVisibility -- ^ whether this flag is shown is the brief description + , _propHelp :: String -- ^ help text for this option + , _propMetaVar :: String -- ^ metavariable for this option + } deriving Functor + +-- | A single option of a parser. +data Option a = Option + { _optMain :: OptReader a -- ^ reader for this option + , _optProps :: OptProperties a -- ^ properties of this option + } deriving Functor -- | An 'OptReader' defines whether an option matches an command line argument. @@ -93,21 +118,29 @@ -- | A @Parser a@ is an option parser returning a value of type 'a'. data Parser a where - NilP :: a -> Parser a - ConsP :: Option r (a -> b) - -> Parser a - -> Parser b + NilP :: Maybe a -> Parser a + OptP :: Option a -> Parser a + MultP :: Parser (a -> b) -> Parser a -> Parser b + AltP :: Parser a -> Parser a -> Parser a + BindP :: Parser a -> (a -> Parser b) -> Parser b instance Functor Parser where - fmap f (NilP x) = NilP (f x) - fmap f (ConsP opt p) = ConsP (fmap (f.) opt) p + fmap f (NilP x) = NilP (fmap f x) + fmap f (OptP opt) = OptP (fmap f opt) + fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2 + fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2) + fmap f (BindP p k) = BindP p (fmap f . k) instance Applicative Parser where - pure = NilP - NilP f <*> p = fmap f p - ConsP opt p1 <*> p2 = - ConsP (fmap uncurry opt) $ (,) <$> p1 <*> p2 + pure = NilP . Just + (<*>) = MultP +instance Alternative Parser where + empty = NilP Nothing + (<|>) = AltP + many p = some p <|> pure [] + some p = p `BindP` (\r -> (r:) <$> many p) + -- | Result after a parse error. data ParserFailure = ParserFailure { errMessage :: String -> String -- ^ Function which takes the program name @@ -120,26 +153,42 @@ { errMessage = \_ -> msg , errExitCode = ExitFailure 1 } +data OptHelpInfo = OptHelpInfo + { hinfoMulti :: Bool + , hinfoDefault :: Bool } + -- lenses -optMain :: Lens (Option r a) (OptReader r) +optMain :: Lens (Option a) (OptReader a) optMain = lens _optMain $ \x o -> o { _optMain = x } -optDefault :: Lens (Option r a) (Maybe a) -optDefault = lens _optDefault $ \x o -> o { _optDefault = x } +optProps :: Lens (Option a) (OptProperties a) +optProps = lens _optProps $ \x o -> o { _optProps = x } -optShow :: Lens (Option r a) Bool -optShow = lens _optShow $ \x o -> o { _optShow = x } +propDefault :: Lens (OptProperties a) (Maybe a) +propDefault = lens _propDefault $ \x o -> o { _propDefault = x } -optHelp :: Lens (Option r a) String -optHelp = lens _optHelp $ \x o -> o { _optHelp = x } +propVisibility :: Lens (OptProperties a) OptVisibility +propVisibility = lens _propVisibility $ \x o -> o { _propVisibility = x } -optMetaVar :: Lens (Option r a) String -optMetaVar = lens _optMetaVar $ \x o -> o { _optMetaVar = x } +propHelp :: Lens (OptProperties a) String +propHelp = lens _propHelp $ \x o -> o { _propHelp = x } -optCont :: Lens (Option r a) (r -> P (Parser a)) -optCont = lens _optCont $ \x o -> o { _optCont = x } +propMetaVar :: Lens (OptProperties a) String +propMetaVar = lens _propMetaVar $ \x o -> o { _propMetaVar = x } +optDefault :: Lens (Option a) (Maybe a) +optDefault = propDefault . optProps + +optVisibility :: Lens (Option a) OptVisibility +optVisibility = propVisibility . optProps + +optHelp :: Lens (Option a) String +optHelp = propHelp . optProps + +optMetaVar :: Lens (Option a) String +optMetaVar = propMetaVar . optProps + descFull :: Lens ParserDesc Bool descFull = lens _descFull $ \x p -> p { _descFull = x } @@ -175,3 +224,6 @@ infoFailureCode :: Lens (ParserInfo a) Int infoFailureCode = descFailureCode . infoDesc + +prefMultiSuffix :: Lens ParserPrefs String +prefMultiSuffix = lens _prefMultiSuffix $ \x p -> p { _prefMultiSuffix = x } diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -180,7 +180,7 @@ ```haskell switch ( long "keep-tmp-files" -, help "Retain all intermediate temporary files" ) +& help "Retain all intermediate temporary files" ) ``` ### Arguments @@ -288,8 +288,11 @@ returnA -< Options args verbose ``` -where parsers can be converted to arrows using `asA`, and the resulting -composed arrow is converted back to a `Parser` with `runA`. +where parsers are converted to arrows using `asA`, and the resulting composed +arrow is converted back to a `Parser` with `runA`. + +See `tests/Examples/Cabal.hs` for a slightly more elaborate example using the +arrow syntax for defining parsers. ## How it works diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -1,5 +1,5 @@ name: optparse-applicative -version: 0.1.1 +version: 0.2.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser: diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -4,14 +4,17 @@ import qualified Examples.Hello as Hello import qualified Examples.Commands as Commands import qualified Examples.Cabal as Cabal +import qualified Examples.Alternatives as Alternatives -import Options.Applicative.Extra -import Options.Applicative.Types +import Options.Applicative import System.Exit import Test.HUnit import Test.Framework.Providers.HUnit import Test.Framework.TH.Prime +run :: ParserInfo a -> [String] -> Either ParserFailure a +run = execParserPure (prefs idm) + assertLeft :: Show b => Either a b -> (a -> Assertion) -> Assertion assertLeft x f = either f err x where @@ -19,7 +22,7 @@ checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion checkHelpText name p args = do - let result = execParserPure p args + let result = run p args assertLeft result $ \(ParserFailure err code) -> do expected <- readFile $ "tests/" ++ name ++ ".err.txt" expected @=? err name @@ -36,7 +39,7 @@ case_args :: Assertion case_args = do - let result = execParserPure Commands.opts ["hello", "foo", "bar"] + let result = run Commands.opts ["hello", "foo", "bar"] case result of Left _ -> assertFailure "unexpected parse error" @@ -44,6 +47,36 @@ ["foo", "bar"] @=? args Right Commands.Goodbye -> assertFailure "unexpected result: Goodbye" + +case_args_opts :: Assertion +case_args_opts = do + let result = run Commands.opts ["hello", "foo", "--bar"] + case result of + Left _ -> return () + Right (Commands.Hello xs) -> + assertFailure $ "unexpected result: Hello " ++ show xs + Right Commands.Goodbye -> + assertFailure "unexpected result: Goodbye" + +case_args_ddash :: Assertion +case_args_ddash = do + let result = run Commands.opts ["hello", "foo", "--", "--bar", "baz"] + case result of + Left _ -> + assertFailure "unexpected parse error" + Right (Commands.Hello args) -> + ["foo", "--bar", "baz"] @=? args + Right Commands.Goodbye -> + assertFailure "unexpected result: Goodbye" + +case_alts :: Assertion +case_alts = do + let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"] + case result of + Left _ -> assertFailure "unexpected parse error" + Right xs -> [b, a, b, a, a, b] @=? xs + where a = Alternatives.A + b = Alternatives.B main :: IO () main = $(defaultMainGenerator)