packages feed

optparse-applicative 0.7.0.2 → 0.8.0

raw patch · 16 files changed

+709/−421 lines, 16 filesdep +QuickCheckdep +ansi-wl-pprintdep +test-framework-quickcheck2

Dependencies added: QuickCheck, ansi-wl-pprint, test-framework-quickcheck2

Files

Options/Applicative/BashCompletion.hs view
@@ -6,23 +6,21 @@ import Data.Foldable (asum) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe)-import System.Exit (ExitCode(..))  import Options.Applicative.Builder import Options.Applicative.Common import Options.Applicative.Internal import Options.Applicative.Types -bashCompletionParser :: Parser a -> ParserPrefs -> Parser ParserFailure-bashCompletionParser parser pprefs = complParser+bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser CompletionResult+bashCompletionParser pinfo pprefs = complParser   where-    failure opts = ParserFailure-      { errMessage = \progn -> unlines <$> opts progn-      , errExitCode = ExitSuccess }+    failure opts = CompletionResult+      { execCompletion = \progn -> unlines <$> opts progn }      complParser = asum       [ failure <$>-        (   bashCompletionQuery parser pprefs+        (   bashCompletionQuery pinfo pprefs         <$> (many . strOption) (long "bash-completion-word"                                   `mappend` internal)         <*> option (long "bash-completion-index" `mappend` internal) )@@ -30,8 +28,8 @@           (bashCompletionScript <$>             strOption (long "bash-completion-script" `mappend` internal)) ] -bashCompletionQuery :: Parser a -> ParserPrefs -> [String] -> Int -> String -> IO [String]-bashCompletionQuery parser pprefs ws i _ = case runCompletion compl pprefs of+bashCompletionQuery :: ParserInfo a -> ParserPrefs -> [String] -> Int -> String -> IO [String]+bashCompletionQuery pinfo pprefs ws i _ = case runCompletion compl pprefs of   Just (Left (SomeParser p)) -> list_options p   Just (Right c)             -> run_completer c   _                          -> return []@@ -42,30 +40,35 @@       . mapParser (\_ -> opt_completions)      opt_completions opt = case optMain opt of-      OptReader ns _ _ -> show_names ns-      FlagReader ns _  -> show_names ns+      OptReader ns _ _ -> return $ show_names ns+      FlagReader ns _  -> return $ show_names ns       ArgReader rdr    -> run_completer (crCompleter rdr)-      CmdReader ns _   -> filter_names ns+      CmdReader ns _   -> return $ filter_names ns +    show_name :: OptName -> String     show_name (OptShort c) = '-':[c]     show_name (OptLong name) = "--" ++ name +    show_names :: [OptName] -> [String]     show_names = filter_names . map show_name-    filter_names = return . filter is_completion +    filter_names :: [String] -> [String]+    filter_names = filter is_completion+     run_completer :: Completer -> IO [String]     run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))      (ws', ws'') = splitAt i ws +    is_completion :: String -> Bool     is_completion =       case ws'' of         w:_ -> isPrefixOf w         _ -> const True      compl = do-      setParser Nothing parser-      runParserFully parser (drop 1 ws')+      setParser Nothing (infoParser pinfo)+      runParserInfo pinfo (drop 1 ws')  bashCompletionScript :: String -> String -> IO [String] bashCompletionScript prog progn = return
Options/Applicative/Builder.hs view
@@ -34,6 +34,7 @@   short,   long,   help,+  helpDoc,   value,   showDefaultWith,   showDefault,@@ -69,9 +70,13 @@   fullDesc,   briefDesc,   header,-  progDesc,+  headerDoc,   footer,+  footerDoc,+  progDesc,+  progDescDoc,   failureCode,+  noIntersperse,   info,    -- * Builder for 'ParserPrefs'@@ -80,7 +85,7 @@   disambiguate,   showHelpOnError,   noBacktrack,-  noIntersperse,+  columns,   prefs,    -- * Types@@ -103,6 +108,8 @@ import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Types+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Chunk  -- readers -- @@ -131,7 +138,7 @@ long = fieldMod . name . OptLong  -- | Specify a default value for an option.-value :: a -> Mod f a+value :: HasValue f => a -> Mod f a value x = Mod id (DefaultProp (Just x) Nothing) id  -- | Specify a function to show the default value for an option.@@ -144,8 +151,13 @@  -- | Specify the help text for an option. help :: String -> Mod f a-help s = optionMod $ \p -> p { propHelp = s }+help s = optionMod $ \p -> p { propHelp = paragraph s } +-- | Specify the help text for an option as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+helpDoc :: Maybe Doc -> Mod f a+helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }+ -- | Specify the 'Option' reader. reader :: (String -> ReadM a) -> Mod OptionFields a reader f = fieldMod $ \p -> p { optReader = f }@@ -159,7 +171,7 @@ noArgError e = fieldMod $ \p -> p { optNoArgError = e }  -- | Specify the metavariable.-metavar :: String -> Mod f a+metavar :: HasMetavar f => String -> Mod f a metavar var = optionMod $ \p -> p { propMetaVar = var }  -- | Hide this option from the brief description.@@ -197,7 +209,7 @@ subparser :: Mod CommandFields a -> Parser a subparser m = mkParser d g rdr   where-    Mod _ d g = m `mappend` metavar "COMMAND"+    Mod _ d g = metavar "COMMAND" `mappend` m     rdr = uncurry CmdReader (mkCommand m)  -- | Builder for an argument parser.@@ -209,10 +221,12 @@  -- | Builder for an argument list parser. All arguments are collected and -- returned as a list.+{-# DEPRECATED arguments "Use many and argument instead" #-} arguments :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] arguments r m = many (argument r m)  -- | Like `arguments`, but require at least one argument.+{-# DEPRECATED arguments1 "Use some and argument instead" #-} arguments1 :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] arguments1 r m = some (argument r m) @@ -304,20 +318,39 @@  -- | Specify a header for this parser. header :: String -> InfoMod a-header s = InfoMod $ \i -> i { infoHeader = s }+header s = InfoMod $ \i -> i { infoHeader = paragraph s } +-- | Specify a header for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+headerDoc :: Maybe Doc -> InfoMod a+headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }+ -- | Specify a footer for this parser. footer :: String -> InfoMod a-footer s = InfoMod $ \i -> i { infoFooter = s }+footer s = InfoMod $ \i -> i { infoFooter = paragraph s } +-- | Specify a footer for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+footerDoc :: Maybe Doc -> InfoMod a+footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }+ -- | Specify a short program description. progDesc :: String -> InfoMod a-progDesc s = InfoMod $ \i -> i { infoProgDesc = s }+progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s } +-- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'+-- value.+progDescDoc :: Maybe Doc -> InfoMod a+progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }+ -- | Specify an exit code if a parse error occurs. failureCode :: Int -> InfoMod a failureCode n = InfoMod $ \i -> i { infoFailureCode = n } +-- | Disable parsing of regular options after arguments+noIntersperse :: InfoMod a+noIntersperse = InfoMod $ \p -> p { infoIntersperse = False }+ -- | Create a 'ParserInfo' given a 'Parser' and a modifier. info :: Parser a -> InfoMod a -> ParserInfo a info parser m = applyInfoMod m base@@ -325,10 +358,11 @@     base = ParserInfo       { infoParser = parser       , infoFullDesc = True-      , infoProgDesc = ""-      , infoHeader = ""-      , infoFooter = ""-      , infoFailureCode = 1 }+      , infoProgDesc = mempty+      , infoHeader = mempty+      , infoFooter = mempty+      , infoFailureCode = 1+      , infoIntersperse = True }  newtype PrefsMod = PrefsMod   { applyPrefsMod :: ParserPrefs -> ParserPrefs }@@ -349,8 +383,8 @@ noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } -noIntersperse :: PrefsMod-noIntersperse = PrefsMod $ \p -> p { prefIntersperse = False }+columns :: Int -> PrefsMod+columns cols = PrefsMod $ \p -> p { prefColumns = cols }  prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base@@ -360,7 +394,7 @@       , prefDisambiguate = False       , prefShowHelpOnError = False       , prefBacktrack = True-      , prefIntersperse = True }+      , prefColumns = 80 }  -- convenience shortcuts
Options/Applicative/Builder/Internal.hs view
@@ -3,6 +3,8 @@   Mod(..),   HasName(..),   HasCompleter(..),+  HasValue,+  HasMetavar,   OptionFields(..),   FlagFields(..),   CommandFields(..),@@ -62,6 +64,23 @@ instance HasCompleter ArgumentFields where   modCompleter f p = p { argCompleter = f (argCompleter p) } +class HasValue f where+  -- this is just so that it is not necessary to specify the kind of f+  hasValueDummy :: f a -> ()+instance HasValue OptionFields where+  hasValueDummy _ = ()+instance HasValue ArgumentFields where+  hasValueDummy _ = ()++class HasMetavar f where+  hasMetavarDummy :: f a -> ()+instance HasMetavar OptionFields where+  hasMetavarDummy _ = ()+instance HasMetavar ArgumentFields where+  hasMetavarDummy _ = ()+instance HasMetavar CommandFields where+  hasMetavarDummy _ = ()+ -- mod --  data DefaultProp a = DefaultProp@@ -118,7 +137,7 @@ baseProps = OptProperties   { propMetaVar = ""   , propVisibility = Visible-  , propHelp = ""+  , propHelp = mempty   , propShowDefault = Nothing }  mkCommand :: Mod CommandFields a -> ([String], String -> Maybe (ParserInfo a))
Options/Applicative/Common.hs view
@@ -32,11 +32,16 @@   --   -- A basic 'ParserInfo' with default values for fields can be created using   -- the 'info' function.+  --+  -- A 'ParserPrefs' contains general preferences for all command-line+  -- options, and can be built with the 'prefs' function.   ParserInfo(..),+  ParserPrefs(..),    -- * Running parsers-  runParser,+  runParserInfo,   runParserFully,+  runParser,   evalParser,    -- * Low-level utilities@@ -83,8 +88,6 @@   mappend m@(Match _) _ = m   mappend _ m = m -type Args = [String]- argMatches :: MonadP m => OptReader a -> String            -> Maybe (StateT Args m a) argMatches opt arg = case opt of@@ -96,12 +99,11 @@       setContext (Just arg) subp       prefs <- getPrefs       let runSubparser-            | prefBacktrack prefs = \p a -> do-                policy <- getPolicy-                runParser policy p a-            | otherwise = \p a-            -> (,) <$> runParserFully p a <*> pure []-      runSubparser (infoParser subp) args+            | prefBacktrack prefs = \i a -> do+                runParser (getPolicy i) (infoParser i) a+            | otherwise = \i a+            -> (,) <$> runParserInfo i a <*> pure []+      runSubparser subp args   _ -> Nothing  optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)@@ -185,11 +187,6 @@     Just matcher -> lift matcher     Nothing -> mzero -data ArgPolicy-  = SkipOpts-  | AllowOpts-  deriving Eq- stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String            -> Parser a -> NondetT (StateT Args m) (Parser a) stepParser pprefs SkipOpts arg p = case parseWord arg of@@ -226,16 +223,17 @@       ('-':_) -> "Invalid option `" ++ arg ++ "'"       _       -> "Invalid argument `" ++ arg ++ "'" -getPolicy :: MonadP m => m ArgPolicy-getPolicy = do-  prefs <- getPrefs-  return $ if prefIntersperse prefs-             then SkipOpts-             else AllowOpts+getPolicy :: ParserInfo a -> ArgPolicy+getPolicy i = if infoIntersperse i+  then SkipOpts+  else AllowOpts -runParserFully :: MonadP m => Parser a -> Args -> m a-runParserFully p args = do-  policy <- getPolicy+runParserInfo :: MonadP m => ParserInfo a -> Args -> m a+runParserInfo i args+  = runParserFully (getPolicy i) (infoParser i) args++runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a+runParserFully policy p args = do   (r, args') <- runParser policy p args   guard $ null args'   return r
Options/Applicative/Extra.hs view
@@ -10,15 +10,17 @@   customExecParser,   customExecParserMaybe,   execParserPure,-  usage,   ParserFailure(..),+  ParserResult(..),+  ParserPrefs(..),+  CompletionResult(..),   ) where -import Control.Applicative ((<$>), (<|>), (<**>))-import Data.Monoid (mconcat)+import Control.Applicative (pure, (<$>), (<|>), (<**>))+import Data.Monoid (mempty, mconcat) import System.Environment (getArgs, getProgName) import System.Exit (exitWith, ExitCode(..))-import System.IO (hPutStr, stderr)+import System.IO (hPutStrLn, stderr)  import Options.Applicative.BashCompletion import Options.Applicative.Builder hiding (briefDesc)@@ -27,7 +29,6 @@ import Options.Applicative.Help import Options.Applicative.Internal import Options.Applicative.Types-import Options.Applicative.Utils  -- | A hidden \"helper\" option which always fails. helper :: Parser (a -> a)@@ -57,15 +58,19 @@ customExecParser pprefs pinfo = do   args <- getArgs   case execParserPure pprefs pinfo args of-    Right a -> return a-    Left failure -> do+    Success a -> return a+    Failure failure -> do       progn <- getProgName-      let c = errExitCode failure-      msg <- errMessage failure progn-      case c of-        ExitSuccess -> putStr msg-        _           -> hPutStr stderr msg-      exitWith c+      let (msg, exit) = execFailure failure progn+      case exit of+        ExitSuccess -> putStrLn msg+        _           -> hPutStrLn stderr msg+      exitWith exit+    CompletionInvoked compl -> do+      progn <- getProgName+      msg <- execCompletion compl progn+      putStr msg+      exitWith ExitSuccess  -- | Run a program description in pure code. --@@ -81,73 +86,39 @@ -- -- See 'execParserMaybe' for details. customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a-customExecParserMaybe pprefs pinfo-  = either (const Nothing) Just-  . execParserPure pprefs pinfo--data Result a = Result a-              | Extra ParserFailure+customExecParserMaybe pprefs pinfo args = case execParserPure pprefs pinfo args of+  Success r -> Just r+  _         -> Nothing  -- | The most general way to run a program description in pure code. execParserPure :: ParserPrefs       -- ^ Global preferences for this parser                -> ParserInfo a      -- ^ Description of the program to run                -> [String]          -- ^ Program arguments-               -> Either ParserFailure a+               -> ParserResult a execParserPure pprefs pinfo args =   case runP p pprefs of-    (Right r, _) -> case r of-      Result a -> Right a-      Extra failure -> Left failure-    (Left msg, ctx) -> Left $-      parserFailure pprefs pinfo msg ctx+    (Right (Right r), _) -> Success r+    (Right (Left c), _) -> CompletionInvoked c+    (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx   where-    parser = infoParser pinfo-    parser' = (Extra <$> bashCompletionParser parser pprefs)-          <|> (Result <$> parser)-    p = runParserFully parser' args+    pinfo' = pinfo+      { infoParser = (Left <$> bashCompletionParser pinfo pprefs)+                 <|> (Right <$> infoParser pinfo) }+    p = runParserInfo pinfo' 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 = exit_code }+parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->+  let h = with_context ctx pinfo $ \names pinfo' -> mconcat+            [ base_help pinfo'+            , usage_help progn names pinfo'+            , error_help ]+  in (render_help h, exit_code)   where-    add_usage names progn i = case msg of-      InfoMsg _ -> i-      _         -> i-        { infoHeader = vcat-            ( header_line i ++-              [ usage pprefs (infoParser i) ename ] ) }-      where-        ename = unwords (progn : names)-    add_error i = i-      { infoHeader = vcat (error_msg ++ [infoHeader i]) }-    error_msg = case msg of-      ShowHelpText -> []-      ErrorMsg m   -> [m]-      InfoMsg  m   -> [m]     exit_code = case msg of-      InfoMsg _ -> ExitSuccess-      _         -> ExitFailure (infoFailureCode pinfo)-    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-      = []+      ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)+      _          -> ExitSuccess      with_context :: Context                  -> ParserInfo a@@ -156,9 +127,32 @@     with_context NullContext i f = f [] i     with_context (Context n i) _ f = f n i --- | Generate option summary.-usage :: ParserPrefs -> Parser a -> String -> String-usage pprefs p progn = foldr (<+>) ""-  [ "Usage:"-  , progn-  , briefDesc pprefs p ]+    render_help :: ParserHelp -> String+    render_help = (`displayS` "")+                . renderPretty 1.0 (prefColumns pprefs)+                . helpText++    show_full_help = case msg of+      ShowHelpText -> True+      _            -> prefShowHelpOnError pprefs++    usage_help progn names i = case msg of+      InfoMsg _ -> mempty+      _         -> usageHelp $ vcatChunks+        [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names+        , fmap (indent 2) . infoProgDesc $ i ]++    error_help = headerHelp $ case msg of+      ShowHelpText -> mempty+      ErrorMsg m   -> stringChunk m+      InfoMsg  m   -> stringChunk m++    base_help :: ParserInfo a -> ParserHelp+    base_help i+      | show_full_help+      = mconcat [h, f, parserHelp pprefs (infoParser i)]+      | otherwise+      = h+      where+        h = headerHelp (infoHeader i)+        f = footerHelp (infoFooter i)
Options/Applicative/Help.hs view
@@ -1,115 +1,7 @@ module Options.Applicative.Help (-  cmdDesc,-  briefDesc,-  fullDesc,-  parserHelpText,+  module X   ) where -import Data.List (intercalate, sort)-import Data.Maybe (maybeToList, catMaybes)--import Options.Applicative.Common-import Options.Applicative.Types-import Options.Applicative.Utils---- | Style for rendering an option.-data OptDescStyle = OptDescStyle-  { descSep :: String-  , descHidden :: Bool-  , descSurround :: Bool }---- | Generate description for a single option.-optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> String-optDesc pprefs style info opt =-  let ns = optionNames $ optMain opt-      mv = optMetaVar opt-      descs = map showOption (sort ns)-      desc' = intercalate (descSep style) descs <+> mv-      show_opt-        | optVisibility opt == Hidden-        = descHidden style-        | otherwise-        = optVisibility opt == Visible-      suffix-        | hinfoMulti info-        = prefMultiSuffix pprefs-        | otherwise-        = ""-      render text-        | not show_opt-        = ""-        | null text || not (descSurround style)-        = text ++ suffix-        | hinfoDefault info-        = "[" ++ text ++ "]" ++ suffix-        | null (drop 1 descs)-        = text ++ suffix-        | otherwise-        = "(" ++ text ++ ")" ++ suffix-  in render desc'---- | Generate descriptions for commands.-cmdDesc :: Parser a -> [String]-cmdDesc = concat . mapParser desc-  where-    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-briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)-  where-    style = OptDescStyle-      { descSep = "|"-      , descHidden = False-      , descSurround = True }--    fold_tree (Leaf x) = x-    fold_tree (MultNode xs) = unwords (fold_trees xs)-    fold_tree (AltNode xs) = alt_node (fold_trees xs)--    alt_node [n] = n-    alt_node ns = "(" ++ intercalate " | " ns ++ ")"--    fold_trees = filter (not . null) . map fold_tree---- | Generate a full help text for a parser.-fullDesc :: ParserPrefs -> Parser a -> [String]-fullDesc pprefs = tabulate . catMaybes . mapParser doc-  where-    doc info opt-      | null n = Nothing-      | null h = Nothing-      | otherwise = Just (n, h ++ hdef)-      where n = optDesc pprefs style info opt-            h = optHelp opt-            hdef = maybe "" show_def (optShowDefault opt)-            show_def s = " (default: " ++ s ++ ")"-    style = OptDescStyle-      { descSep = ","-      , descHidden = True-      , descSurround = False }---- | Generate the help text for a program.-parserHelpText :: ParserPrefs -> ParserInfo a -> String-parserHelpText pprefs pinfo = unlines-   $ nn [infoHeader pinfo]-  ++ [ "  " ++ line | line <- nn [infoProgDesc pinfo] ]-  ++ [ line | let opts = fullDesc pprefs p-            , not (null opts)-            , line <- ["", "Available options:"] ++ opts-            , infoFullDesc pinfo ]-  ++ [ line | let cmds = cmdDesc p-            , not (null cmds)-            , line <- ["", "Available commands:"] ++ cmds-            , infoFullDesc pinfo ]-  ++ [ line | footer <- nn [infoFooter pinfo]-            , line <- ["", footer] ]-  where-    nn = filter (not . null)-    p = infoParser pinfo+import Options.Applicative.Help.Pretty as X+import Options.Applicative.Help.Chunk as X+import Options.Applicative.Help.Core as X
+ Options/Applicative/Help/Chunk.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}+module Options.Applicative.Help.Chunk+  ( mappendWith+  , Chunk(..)+  , chunked+  , listToChunk+  , (<<+>>)+  , (<</>>)+  , vcatChunks+  , vsepChunks+  , isEmpty+  , stringChunk+  , paragraph+  , extractChunk+  , tabulate+  ) where++import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Monoid++import Options.Applicative.Help.Pretty++mappendWith :: Monoid a => a -> a -> a -> a+mappendWith s x y = mconcat [x, s, y]++-- | The free monoid on a semigroup 'a'.+newtype Chunk a = Chunk+  { unChunk :: Maybe a }+  deriving (Eq, Show)++instance Functor Chunk where+  fmap f = Chunk . fmap f . unChunk++instance Applicative Chunk where+  pure = Chunk . pure+  Chunk f <*> Chunk x = Chunk (f <*> x)++instance Monad Chunk where+  return = pure+  m >>= f = Chunk $ unChunk m >>= unChunk . f++instance MonadPlus Chunk where+  mzero = Chunk mzero+  mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk m2)++-- | Given a semigroup structure on 'a', return a monoid structure on 'Chunk a'.+--+-- Note that this is /not/ the same as 'liftA2'.+chunked :: (a -> a -> a)+        -> Chunk a -> Chunk a -> Chunk a+chunked _ (Chunk Nothing) y = y+chunked _ x (Chunk Nothing) = x+chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))++-- | Concatenate a list into a Chunk.  'listToChunk' satisfies:+--+-- > isEmpty . listToChunk = null+-- > listToChunk = mconcat . fmap pure+listToChunk :: Monoid a => [a] -> Chunk a+listToChunk [] = mempty+listToChunk xs = pure (mconcat xs)++instance Monoid a => Monoid (Chunk a) where+  mempty = Chunk Nothing+  mappend = chunked mappend++-- | Part of a constrained comonad instance.+--+-- This is the counit of the adjunction between 'Chunk' and the forgetful+-- functor from monoids to semigroups.  It satisfies:+--+-- > extractChunk . pure = id+-- > extractChunk . fmap pure = id+extractChunk :: Monoid a => Chunk a -> a+extractChunk = fromMaybe mempty . unChunk+-- we could also define:+-- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)+-- duplicate = fmap pure++-- | Concatenate two 'Chunk's with a space in between.  If one is empty, this+-- just returns the other one.+--+-- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty+-- 'Chunk'.+(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc+(<<+>>) = chunked (<+>)++-- | Concatenate two 'Chunk's with a softline in between.  This is exactly like+-- '<<+>>', but uses a softline instead of a space.+(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc+(<</>>) = chunked (</>)++-- | Concatenate 'Chunk's vertically.+vcatChunks :: [Chunk Doc] -> Chunk Doc+vcatChunks = foldr (chunked (.$.)) mempty++-- | Concatenate 'Chunk's vertically separated by empty lines.+vsepChunks :: [Chunk Doc] -> Chunk Doc+vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty++-- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not+-- considered an empty chunk, even though the underlying 'Doc' is empty.+isEmpty :: Chunk a -> Bool+isEmpty = isNothing . unChunk++-- | Convert a 'String' into a 'Chunk'.  This satisfies:+--+-- > isEmpty . stringChunk = null+-- > extractChunk . stringChunk = string+stringChunk :: String -> Chunk Doc+stringChunk "" = mempty+stringChunk s = pure (string s)++-- | Convert a paragraph into a 'Chunk'.  The resulting chunk is composed by the+-- words of the original paragraph separated by softlines, so it will be+-- automatically word-wrapped when rendering the underlying document.+--+-- This satisfies:+--+-- > isEmpty . paragraph = null . words+paragraph :: String -> Chunk Doc+paragraph = foldr (chunked (</>)) mempty+          . map stringChunk+          . words++tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc+tabulate' _ [] = mempty+tabulate' size table = pure $ vcat+  [ indent 2 (fillBreak size key <+> value)+  | (key, value) <- table ]++-- | Display pairs of strings in a table.+tabulate :: [(Doc, Doc)] -> Chunk Doc+tabulate = tabulate' 24
+ Options/Applicative/Help/Core.hs view
@@ -0,0 +1,153 @@+module Options.Applicative.Help.Core (+  cmdDesc,+  briefDesc,+  fullDesc,+  ParserHelp(..),+  helpText,+  headerHelp,+  usageHelp,+  bodyHelp,+  footerHelp,+  parserHelp,+  parserUsage,+  ) where++import Control.Monad (guard)+import Data.List (intersperse, sort)+import Data.Maybe (maybeToList, catMaybes)+import Data.Monoid (Monoid, mempty, mappend, mconcat)++import Options.Applicative.Common+import Options.Applicative.Types+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Chunk++-- | Style for rendering an option.+data OptDescStyle = OptDescStyle+  { descSep :: Doc+  , descHidden :: Bool+  , descSurround :: Bool }++-- | Generate description for a single option.+optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc+optDesc pprefs style info opt =+  let ns = optionNames $ optMain opt+      mv = stringChunk $ optMetaVar opt+      descs = map (string . showOption) (sort ns)+      desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv+      show_opt+        | optVisibility opt == Hidden+        = descHidden style+        | otherwise+        = optVisibility opt == Visible+      suffix+        | hinfoMulti info+        = stringChunk . prefMultiSuffix $ pprefs+        | otherwise+        = mempty+      render chunk+        | not show_opt+        = mempty+        | isEmpty chunk || not (descSurround style)+        = mappend chunk suffix+        | hinfoDefault info+        = mappend (fmap brackets chunk) suffix+        | null (drop 1 descs)+        = mappend chunk suffix+        | otherwise+        = mappend (fmap parens chunk) suffix+  in render desc'++-- | Generate descriptions for commands.+cmdDesc :: Parser a -> Chunk Doc+cmdDesc = mconcat . mapParser desc+  where+    desc _ opt =+      case optMain opt of+        CmdReader cmds p ->+          tabulate [(string cmd, align (extractChunk d))+                   | cmd <- reverse cmds+                   , d <- maybeToList . fmap infoProgDesc $ p cmd ]+        _ -> mempty++-- | Generate a brief help text for a parser.+briefDesc :: ParserPrefs -> Parser a -> Chunk Doc+briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)+  where+    style = OptDescStyle+      { descSep = string "|"+      , descHidden = False+      , descSurround = True }++    fold_tree (Leaf x) = x+    fold_tree (MultNode xs) = foldr (<</>>) mempty . map fold_tree $ xs+    fold_tree (AltNode xs) = alt_node+                           . filter (not . isEmpty)+                           . map fold_tree $ xs++    alt_node :: [Chunk Doc] -> Chunk Doc+    alt_node [n] = n+    alt_node ns = fmap parens+                . foldr (chunked (\x y -> x </> char '|' </> y)) mempty+                $ ns++-- | Generate a full help text for a parser.+fullDesc :: ParserPrefs -> Parser a -> Chunk Doc+fullDesc pprefs = tabulate . catMaybes . mapParser doc+  where+    doc info opt = do+      guard . not . isEmpty $ n+      guard . not . isEmpty $ h+      return (extractChunk n, align . extractChunk $ h <<+>> hdef)+      where+        n = optDesc pprefs style info opt+        h = optHelp $ opt+        hdef = Chunk . fmap show_def . optShowDefault $ opt+        show_def s = parens (string "default:" <+> string s)+    style = OptDescStyle+      { descSep = string ","+      , descHidden = True+      , descSurround = False }++data ParserHelp = ParserHelp+  { helpHeader :: Chunk Doc+  , helpUsage :: Chunk Doc+  , helpBody :: Chunk Doc+  , helpFooter :: Chunk Doc }++instance Monoid ParserHelp where+  mempty = ParserHelp mempty mempty mempty mempty+  mappend (ParserHelp h1 u1 b1 f1) (ParserHelp h2 u2 b2 f2)+    = ParserHelp (mappend h1 h2) (mappend u1 u2)+                 (mappend b1 b2) (mappend f1 f2)++headerHelp :: Chunk Doc -> ParserHelp+headerHelp chunk = ParserHelp chunk mempty mempty mempty++usageHelp :: Chunk Doc -> ParserHelp+usageHelp chunk = ParserHelp mempty chunk mempty mempty++bodyHelp :: Chunk Doc -> ParserHelp+bodyHelp chunk = ParserHelp mempty mempty chunk mempty++footerHelp :: Chunk Doc -> ParserHelp+footerHelp chunk = ParserHelp mempty mempty mempty chunk++helpText :: ParserHelp -> Doc+helpText (ParserHelp h u b f) = extractChunk . vsepChunks $ [h, u, b, f]++-- | Generate the help text for a program.+parserHelp :: ParserPrefs -> Parser a -> ParserHelp+parserHelp pprefs p = bodyHelp . vsepChunks $+  [ with_title "Available options:" (fullDesc pprefs p)+  , with_title "Available commands:" (cmdDesc p) ]+  where+    with_title :: String -> Chunk Doc -> Chunk Doc+    with_title title = fmap (string title .$.)++-- | Generate option summary.+parserUsage :: ParserPrefs -> Parser a -> String -> Doc+parserUsage pprefs p progn = hsep $+  [ string "Usage:"+  , string progn+  , align (extractChunk (briefDesc pprefs p)) ]
+ Options/Applicative/Help/Pretty.hs view
@@ -0,0 +1,10 @@+module Options.Applicative.Help.Pretty+  ( module Text.PrettyPrint.ANSI.Leijen+  , (.$.)+  ) where++import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns)+import qualified Text.PrettyPrint.ANSI.Leijen as PP++(.$.) :: Doc -> Doc -> Doc+(.$.) = (PP.<$>)
Options/Applicative/Types.hs view
@@ -17,7 +17,11 @@   ParserM(..),   Completer(..),   mkCompleter,+  CompletionResult(..),   ParserFailure(..),+  ParserResult(..),+  Args,+  ArgPolicy(..),   OptHelpInfo(..),   OptTree(..), @@ -39,6 +43,9 @@ import Data.Monoid (Monoid(..)) import System.Exit (ExitCode(..)) +import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Chunk+ data ParseError   = ErrorMsg String   | InfoMsg String@@ -50,12 +57,15 @@  -- | A full description for a runnable 'Parser' for a program. data ParserInfo a = ParserInfo-  { infoParser :: Parser a            -- ^ the option parser for the program-  , infoFullDesc :: Bool              -- ^ whether the help text should contain full documentation-  , infoProgDesc :: String            -- ^ brief parser description-  , infoHeader :: String              -- ^ header of the full parser description-  , infoFooter :: String              -- ^ footer of the full parser description-  , infoFailureCode :: Int            -- ^ exit code for a parser failure+  { infoParser :: Parser a    -- ^ the option parser for the program+  , infoFullDesc :: Bool      -- ^ whether the help text should contain full+                              -- documentation+  , infoProgDesc :: Chunk Doc -- ^ brief parser description+  , infoHeader :: Chunk Doc   -- ^ header of the full parser description+  , infoFooter :: Chunk Doc   -- ^ footer of the full parser description+  , infoFailureCode :: Int    -- ^ exit code for a parser failure+  , infoIntersperse :: Bool   -- ^ allow regular options and flags to occur+                              -- after arguments (default: True)   }  instance Functor ParserInfo where@@ -70,8 +80,8 @@                                  -- (default: False)   , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a                                  -- subcommand fails (default: True)-  , prefIntersperse :: Bool      -- ^ allow regular options and flags to occur-                                 -- after arguments (default: True)+  , prefColumns :: Int           -- ^ number of columns in the terminal, used to+                                 -- format the help page (default: 80)   }  data OptName = OptShort !Char@@ -88,7 +98,7 @@ -- | Specification for an individual parser option. data OptProperties = OptProperties   { propVisibility :: OptVisibility       -- ^ whether this flag is shown is the brief description-  , propHelp :: String                    -- ^ help text for this option+  , propHelp :: Chunk Doc                 -- ^ help text for this option   , propMetaVar :: String                 -- ^ metavariable for this option   , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default   }@@ -221,18 +231,25 @@   mappend (Completer c1) (Completer c2) =     Completer $ \s -> (++) <$> c1 s <*> c2 s --- | Result after a parse error.-data ParserFailure = ParserFailure-  { errMessage :: String -> IO String -- ^ Function which takes the program name-                                      -- as input and returns an error message-  , errExitCode :: ExitCode           -- ^ Exit code to use for this error-  }+newtype CompletionResult = CompletionResult+  { execCompletion :: String -> IO String } -instance Error ParserFailure where-  strMsg msg = ParserFailure-    { errMessage = \_ -> return msg-    , errExitCode = ExitFailure 1 }+newtype ParserFailure = ParserFailure+  { execFailure :: String -> (String, ExitCode) } +-- | Result of 'execParserPure'.+data ParserResult a+  = Success a+  | Failure ParserFailure+  | CompletionInvoked CompletionResult++type Args = [String]++data ArgPolicy+  = SkipOpts+  | AllowOpts+  deriving Eq+ data OptHelpInfo = OptHelpInfo   { hinfoMulti :: Bool   , hinfoDefault :: Bool }@@ -246,7 +263,7 @@ optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps -optHelp :: Option a -> String+optHelp :: Option a -> Chunk Doc optHelp  = propHelp . optProps  optMetaVar :: Option a -> String
− Options/Applicative/Utils.hs 
@@ -1,32 +0,0 @@-module Options.Applicative.Utils (-  (<+>),-  vcat,-  tabulate,-  pad-  ) where--import Data.List (intercalate)---- | Concatenate two strings with a space in the middle.-(<+>) :: String -> String -> String-"" <+> s = s-s <+> "" = s-s1 <+> s2 = s1 ++ " " ++ s2---- | Concatenate strings vertically with empty lines in between.-vcat :: [String] -> String-vcat = intercalate "\n\n" . filter (not . null)--tabulate' :: Int -> [(String, String)] -> [String]-tabulate' size table =-  [ "  " ++ pad size key ++ " " ++ value-  | (key, value) <- table ]---- | Display pairs of strings in a table.-tabulate :: [(String, String)] -> [String]-tabulate = tabulate' 24---- | Pad a string to a fixed size with whitespace.-pad :: Int -> String -> String-pad size str = str ++ replicate (size - n `max` 0) ' '-  where n = length str
README.md view
@@ -212,11 +212,17 @@ for which the reader succeeds. For example  ```haskell-argument str ( metavar "FILE" )+argument str (metavar "FILE") ``` -creates an argument accepting any string.+creates an argument accepting any string.  To accept an arbitrary number of+arguments, combine the `argument` builder with either the `many` or `some`+combinator: +```haskell+some (argument str (metavar "FILES..."))+```+ Arguments are only displayed in the brief help text, so there's no need to attach a description to them. They should be manually documented in the program description.@@ -303,39 +309,13 @@ See the haddock documentation for `Options.Applicative.Builder` for a full list of builders and modifiers. -## Arrow interface--It is also possible to use the [Arrow syntax][arrows] to combine basic parsers.--This can be particularly useful when the structure holding parse results is-deeply nested, or when the order of fields differs from the order in which the-parsers should be applied.--Using functions from the `Options.Applicative.Arrows` module, one can write,-for example:--```haskell-data Options = Options-  { optArgs :: [String]-  , optVerbose :: Bool }--opts :: Parser Options-opts = runA $ proc () -> do-  verbosity <- asA (option (short 'v' <> value 0)) -< ()-  let verbose = verbosity > 0-  args <- asA (arguments str idm) -< ()-  returnA -< Options args verbose-```--where parsers are converted to arrows using `asA`, and the resulting composed-arrow is converted back to a `Parser` with `runA`.+## Advanced features -See `tests/Examples/Cabal.hs` for a slightly more elaborate example using the-arrow syntax for defining parsers.+* [Bash completion][bash]+* [Arrow interface][arrows] -Note that the `Arrow` interface is provided only for convenience. The API based-on `Applicative` is just as expressive, although it might be cumbersome to use-in certain cases.+ [bash]: https://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion+ [arrows]: https://github.com/pcapriotti/optparse-applicative/wiki/Arrows  ## How it works
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name:                optparse-applicative-version:             0.7.0.2+version:             0.8.0 synopsis:            Utilities and combinators for parsing command line options description:     Here is a simple example of an applicative option parser:@@ -96,21 +96,26 @@                        Options.Applicative.Common,                        Options.Applicative.Extra,                        Options.Applicative.Help,+                       Options.Applicative.Help.Pretty,+                       Options.Applicative.Help.Chunk,+                       Options.Applicative.Help.Core,                        Options.Applicative.Types,-                       Options.Applicative.Utils-  other-modules:       Options.Applicative.Internal+                       Options.Applicative.Internal   ghc-options:         -Wall   build-depends:       base == 4.*,                        transformers >= 0.2 && < 0.4,-                       process >= 1.0 && < 1.3+                       process >= 1.0 && < 1.3,+                       ansi-wl-pprint >= 0.6 && < 0.7 test-suite tests   type:                exitcode-stdio-1.0   hs-source-dirs:      tests   main-is:             Tests.hs-  ghc-options:         -Wall+  ghc-options:         -Wall -fno-warn-orphans   build-depends:       base == 4.*,                        HUnit == 1.2.*,                        optparse-applicative,+                       QuickCheck == 2.6.*,                        test-framework >= 0.6 && < 0.9,                        test-framework-hunit >= 0.2 && < 0.4,+                       test-framework-quickcheck2 == 0.3.*,                        test-framework-th-prime == 0.0.*
tests/Examples/Cabal.hs view
@@ -118,7 +118,8 @@   returnA -< BuildOpts bdir  pinfo :: ParserInfo Args-pinfo = info parser idm+pinfo = info parser+  ( progDesc "An example modelled on cabal" )  main :: IO () main = do
tests/Examples/Commands.hs view
@@ -16,7 +16,7 @@   deriving Show  hello :: Parser Sample-hello = Hello <$> arguments str (metavar "TARGET...")+hello = Hello <$> many (argument str (metavar "TARGET..."))  sample :: Parser Sample sample = subparser
tests/Tests.hs view
@@ -1,54 +1,71 @@-{-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving,+             TemplateHaskell, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where  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 qualified Examples.Formatting as Formatting  import Control.Monad-import Data.List-import Options.Applicative+import Data.List hiding (group)+import Data.Monoid import System.Exit import Test.HUnit import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.TH.Prime+import Test.QuickCheck (Positive (..))+import Test.QuickCheck.Arbitrary +import Options.Applicative+import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))+import qualified Options.Applicative.Help.Pretty as Doc+import Options.Applicative.Help.Chunk+ #if __GLASGOW_HASKELL__ <= 702 import Data.Monoid (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif -run :: ParserInfo a -> [String] -> Either ParserFailure a+run :: ParserInfo a -> [String] -> ParserResult a run = execParserPure (prefs idm) -assertLeft :: Show b => Either a b -> (a -> Assertion) -> Assertion-assertLeft x f = either f err x-  where-    err b = assertFailure $ "expected Left, got " ++ show b+assertError :: Show a => ParserResult a -> (ParserFailure -> Assertion) -> Assertion+assertError x f = case x of+  Success r -> assertFailure $ "expected failure, got success: " ++ show r+  Failure e -> f e+  CompletionInvoked _ -> assertFailure $ "expected failure, got completion" -assertRight :: Either ParserFailure b -> (b -> Assertion) -> Assertion-assertRight x f = either err f x-  where-    err (ParserFailure e _) = do-      msg <- e "test"-      assertFailure $ "unexpected parse error\n" ++ msg+assertResult :: ParserResult a -> (a -> Assertion) -> Assertion+assertResult x f = case x of+  Success r -> f r+  Failure e -> do+    let (msg, _) = execFailure e "test"+    assertFailure $ "unexpected parse error\n" ++ msg+  CompletionInvoked _ -> assertFailure $ "expected result, got completion"  assertHasLine :: String -> String -> Assertion assertHasLine l s   | l `elem` lines s = return ()   | otherwise = assertFailure $ "expected line:\n\t" ++ l ++ "\nnot found" -checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion-checkHelpText name p args = do-  let result = run p args-  assertLeft result $ \(ParserFailure err code) -> do+checkHelpTextWith :: Show a => ExitCode -> ParserPrefs -> String+                  -> ParserInfo a -> [String] -> Assertion+checkHelpTextWith ecode pprefs name p args = do+  let result = execParserPure pprefs p args+  assertError result $ \(ParserFailure err) -> do     expected <- readFile $ "tests/" ++ name ++ ".err.txt"-    msg <- err name-    expected @=? msg-    ExitFailure 1 @=? code+    let (msg, code) = err name+    expected @=? msg ++ "\n"+    ecode @=? code +checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Assertion+checkHelpText = checkHelpTextWith ExitSuccess (prefs idm)+ case_hello :: Assertion case_hello = checkHelpText "hello" Hello.opts ["--help"] @@ -62,42 +79,41 @@ case_args = do   let result = run Commands.opts ["hello", "foo", "bar"]   case result of-    Left _ ->-      assertFailure "unexpected parse error"-    Right (Commands.Hello args) ->+    Success (Commands.Hello args) ->       ["foo", "bar"] @=? args-    Right Commands.Goodbye ->+    Success Commands.Goodbye ->       assertFailure "unexpected result: Goodbye"+    _ ->+      assertFailure "unexpected parse error"  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) ->+    Success (Commands.Hello xs) ->       assertFailure $ "unexpected result: Hello " ++ show xs-    Right Commands.Goodbye ->+    Success Commands.Goodbye ->       assertFailure "unexpected result: Goodbye"+    _ -> return ()  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) ->+    Success (Commands.Hello args) ->       ["foo", "--bar", "baz"] @=? args-    Right Commands.Goodbye ->+    Success Commands.Goodbye ->       assertFailure "unexpected result: Goodbye"+    _ -> assertFailure "unexpected parse error"  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+    Success xs -> [b, a, b, a, a, b] @=? xs       where a = Alternatives.A             b = Alternatives.B+    _ -> assertFailure "unexpected parse error"  case_show_default :: Assertion case_show_default = do@@ -108,12 +124,13 @@       i = info (p <**> helper) idm       result = run i ["--help"]   case result of-    Left (ParserFailure err _) -> do-      msg <- err "test"+    Failure (ParserFailure err) -> do+      let (msg, _) = err "test"       assertHasLine         "  -n ARG                   set count (default: 0)"         msg-    Right r  -> assertFailure $ "unexpected result: " ++ show r+    Success r -> assertFailure $ "unexpected result: " ++ show r+    CompletionInvoked _ -> assertFailure "unexpected completion"  case_alt_cont :: Assertion case_alt_cont = do@@ -121,8 +138,8 @@       i = info p idm       result = run i ["-a", "-b"]   case result of-    Left _ -> return ()-    Right r -> assertFailure $ "unexpected result: " ++ show r+    Success r -> assertFailure $ "unexpected result: " ++ show r+    _ -> return ()  case_alt_help :: Assertion case_alt_help = do@@ -145,17 +162,17 @@       p2 = subparser (command "b" (info p3 idm))       p1 = subparser (command "c" (info p2 idm))       i = info (p1 <**> helper) idm-  checkHelpText "nested" i ["c", "b"]+  checkHelpTextWith (ExitFailure 1) (prefs idm) "nested" i ["c", "b"]  case_many_args :: Assertion case_many_args = do-  let p = arguments str idm+  let p = many (argument str idm)       i = info p idm       nargs = 20000       result = run i (replicate nargs "foo")   case result of-    Left _ -> assertFailure "unexpected parse error"-    Right xs -> nargs @=? length xs+    Success xs -> nargs @=? length xs+    _ -> assertFailure "unexpected parse error"  case_disambiguate :: Assertion case_disambiguate = do@@ -165,8 +182,8 @@       i = info p idm       result = execParserPure (prefs disambiguate) i ["--f"]   case result of-    Left _ -> assertFailure "unexpected parse error"-    Right val -> 1 @=? val+    Success val -> 1 @=? val+    _ -> assertFailure "unexpected parse error"  case_ambiguous :: Assertion case_ambiguous = do@@ -176,8 +193,8 @@       i = info p idm       result = execParserPure (prefs disambiguate) i ["--ba"]   case result of-    Left _ -> return ()-    Right val -> assertFailure $ "unexpected result " ++ show val+    Success val -> assertFailure $ "unexpected result " ++ show val+    _ -> return ()  case_completion :: Assertion case_completion = do@@ -187,24 +204,24 @@       i = info p idm       result = run i ["--bash-completion-index", "0"]   case result of-    Left (ParserFailure err code) -> do-      ExitSuccess @=? code+    CompletionInvoked (CompletionResult err) -> do       completions <- lines <$> err "test"       ["--foo", "--bar"] @=? completions-    Right val ->-      assertFailure $ "unexpected result " ++ show val+    Failure _ -> assertFailure "unexpected failure"+    Success val -> assertFailure $ "unexpected result " ++ show val  case_bind_usage :: Assertion case_bind_usage = do-  let p = arguments str (metavar "ARGS...")+  let p = many (argument str (metavar "ARGS..."))       i = info (p <**> helper) briefDesc       result = run i ["--help"]   case result of-    Left (ParserFailure err _) -> do-      text <- head . lines <$> err "test"+    Failure (ParserFailure err) -> do+      let text = head . lines . fst $ err "test"       "Usage: test [ARGS...]" @=? text-    Right val ->+    Success val ->       assertFailure $ "unexpected result " ++ show val+    CompletionInvoked _ -> assertFailure "unexpected completion"  case_issue_19 :: Assertion case_issue_19 = do@@ -215,32 +232,32 @@       i = info (p <**> helper) idm       result = run i ["-x", "foo"]   case result of-    Left _ -> assertFailure "unexpected parse error"-    Right r -> Just "foo" @=? r+    Success r -> Just "foo" @=? r+    _ -> assertFailure "unexpected parse error"  case_arguments1_none :: Assertion case_arguments1_none = do-  let p = arguments1 str idm+  let p = some (argument str idm)       i = info (p <**> helper) idm       result = run i []-  assertLeft result $ \(ParserFailure _ _) -> return ()+  assertError result $ \(ParserFailure _) -> return ()  case_arguments1_some :: Assertion case_arguments1_some = do-  let p = arguments1 str idm+  let p = some (argument 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+    Success r -> ["foo", "bar", "baz"] @=? r+    _ -> assertFailure "unexpected parse error"  case_arguments_switch :: Assertion case_arguments_switch = do   let p =  switch (short 'x')-        *> arguments str idm+        *> many (argument str idm)       i = info p idm       result = run i ["--", "-x"]-  assertRight result $ \args -> ["-x"] @=? args+  assertResult result $ \args -> ["-x"] @=? args  case_issue_35 :: Assertion case_issue_35 = do@@ -248,12 +265,9 @@        <|> flag' False (short 'f')       i = info p idm       result = run i []-  case result of-    Left (ParserFailure err _) -> do-      text <- head . lines <$> err "test"-      "Usage: test -f" @=? text-    Right val ->-      assertFailure $ "unexpected result " ++ show val+  assertError result $ \(ParserFailure err) -> do+    let text = head . lines . fst . err $ "test"+    "Usage: test -f" @=? text  case_backtracking :: Assertion case_backtracking = do@@ -263,7 +277,7 @@         <*> switch (short 'b')       i = info (p1 <**> helper) idm       result = execParserPure (prefs noBacktrack) i ["c", "-b"]-  assertLeft result $ \ _ -> return ()+  assertError result $ \ _ -> return ()  case_error_context :: Assertion case_error_context = do@@ -271,16 +285,13 @@              <*> option (long "key")       i = info p idm       result = run i ["--port", "foo", "--key", "291"]-  case result of-    Left (ParserFailure err _) -> do-      msg <- err "test"+  assertError result $ \(ParserFailure err) -> do+      let (msg, _) = err "test"       let errMsg = head $ lines msg       assertBool "no context in error message (option)"                  ("port" `isInfixOf` errMsg)       assertBool "no context in error message (value)"                  ("foo" `isInfixOf` errMsg)-    Right val ->-      assertFailure $ "unexpected result " ++ show val   where     pk :: Int -> Int -> (Int, Int)     pk = (,)@@ -298,7 +309,7 @@           <*> argument (condr odd) idm       i = info p idm       result = run i ["3", "6"]-  assertLeft result $ \_ -> return ()+  assertError result $ \_ -> return ()  case_arg_order_2 :: Assertion case_arg_order_2 = do@@ -309,8 +320,8 @@       i = info p idm       result = run i ["2", "-b", "3", "-a", "6"]   case result of-    Left _ -> assertFailure "unexpected parse error"-    Right res -> (2, 6, 3) @=? res+    Success res -> (2, 6, 3) @=? res+    _ -> assertFailure "unexpected parse error"  case_arg_order_3 :: Assertion case_arg_order_3 = do@@ -321,35 +332,102 @@       i = info p idm       result = run i ["-n", "3", "5"]   case result of-    Left _ ->-      assertFailure "unexpected parse error"-    Right res -> (3, 5) @=? res+    Success res -> (3, 5) @=? res+    _ -> assertFailure "unexpected parse error"  case_issue_47 :: Assertion case_issue_47 = do   let p = nullOption (long "test" <> reader r <> value 9) :: Parser Int       r _ = readerError "error message"       result = run (info p idm) ["--test", "x"]-  assertLeft result $ \(ParserFailure err _) -> do-    text <- head . lines <$> err "test"+  assertError result $ \(ParserFailure err) -> do+    let text = head . lines . fst . err $ "test"     assertBool "no error message"                ("error message" `isInfixOf` text) +case_long_help :: Assertion+case_long_help = do+  let p = Formatting.opts <**> helper+      i = info p+        ( progDesc (concat+            [ "This is a very long program description. "+            , "This text should be automatically wrapped "+            , "to fit the size of the terminal" ]) )+  checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting" i ["--help"]+ case_issue_50 :: Assertion case_issue_50 = do   let p = argument str (metavar "INPUT")           <* switch (long "version")       result = run (info p idm) ["--version", "test"]-  assertRight result $ \r -> "test" @=? r+  assertResult result $ \r -> "test" @=? r  case_intersperse_1 :: Assertion case_intersperse_1 = do-  let p = arguments str (metavar "ARGS")+  let p = many (argument str (metavar "ARGS"))           <* switch (short 'x')-      result = execParserPure (prefs noIntersperse)-                              (info p idm)-                              ["a", "-x", "b"]-  assertRight result $ \args -> ["a", "-x", "b"] @=? args+      result = run (info p noIntersperse)+                 ["a", "-x", "b"]+  assertResult result $ \args -> ["a", "-x", "b"] @=? args++case_intersperse_2 :: Assertion+case_intersperse_2 = do+  let p = subparser+          (  command "run"+             ( info (many (argument str (metavar "OPTIONS")))+                    noIntersperse )+          <> command "test"+             ( info (many (argument str (metavar "ARGS")))+                    idm ) )+      i = info p idm+      result1 = run i ["run", "-x", "foo"]+      result2 = run i ["test", "-x", "bar"]+  assertResult result1 $ \args -> ["-x", "foo"] @=? args+  assertError result2 $ \_ -> return ()++case_issue_52 :: Assertion+case_issue_52 = do+  let p = subparser+        ( metavar "FOO"+        <> command "run" (info (pure "foo") idm) )+      i = info p idm+  assertError (run i []) $ \(ParserFailure err) -> do+    let text = head . lines . fst . err $ "test"+    "Usage: test FOO" @=? text++---++deriving instance Arbitrary a => Arbitrary (Chunk a)+deriving instance Eq SimpleDoc++equalDocs :: Float -> Int -> Doc -> Doc -> Bool+equalDocs f w d1 d2 = Doc.renderPretty f w d1+                   == Doc.renderPretty f w d2++prop_listToChunk_1 :: [String] -> Bool+prop_listToChunk_1 xs = isEmpty (listToChunk xs) == null xs++prop_listToChunk_2 :: [String] -> Bool+prop_listToChunk_2 xs = listToChunk xs == mconcat (fmap pure xs)++prop_extractChunk_1 :: String -> Bool+prop_extractChunk_1 x = extractChunk (pure x) == x++prop_extractChunk_2 :: Chunk String -> Bool+prop_extractChunk_2 x = extractChunk (fmap pure x) == x++prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Bool+prop_stringChunk_1 (Positive f) (Positive w) s =+  equalDocs f w (extractChunk (stringChunk s))+                (Doc.string s)++prop_stringChunk_2 :: String -> Bool+prop_stringChunk_2 s = isEmpty (stringChunk s) == null s++prop_paragraph :: String -> Bool+prop_paragraph s = isEmpty (paragraph s) == null (words s)++---  main :: IO () main = $(defaultMainGenerator)