packages feed

optparse-applicative 0.3.2 → 0.4.0

raw patch · 11 files changed

+553/−131 lines, 11 filesdep +processdep ~basedep ~optparse-applicative

Dependencies added: process

Dependency ranges changed: base, optparse-applicative

Files

Options/Applicative.hs view
@@ -20,6 +20,9 @@   -- | Utilities to build parsers out of basic primitives.   module Options.Applicative.Builder, +  -- | Common completion functions.+  module Options.Applicative.Builder.Completer,+   -- | Utilities to run parsers and display a help text.   module Options.Applicative.Extra,   ) where@@ -29,4 +32,5 @@  import Options.Applicative.Common import Options.Applicative.Builder+import Options.Applicative.Builder.Completer import Options.Applicative.Extra
+ Options/Applicative/BashCompletion.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE PatternGuards #-}+module Options.Applicative.BashCompletion+  ( bashCompletionParser+  ) where++import Control.Applicative+import Data.Foldable (asum)+import Data.List+import Data.Maybe+import System.Exit++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+  where+    failure opts = ParserFailure+      { errMessage = \progn -> unlines <$> opts progn+      , errExitCode = ExitSuccess }++    complParser = asum+      [ failure <$>+        (   bashCompletionQuery parser pprefs+        <$> (many . strOption) (long "bash-completion-word" & internal)+        <*> option (long "bash-completion-index" & internal) )+      , failure <$>+          (bashCompletionScript <$>+            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+  Just (Left (SomeParser p)) -> list_options p+  Just (Right c)             -> run_completer c+  _                          -> return []+  where+    list_options =+        fmap concat+      . sequence+      . 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++    show_name (OptShort c) = '-':[c]+    show_name (OptLong name) = "--" ++ name++    show_names = filter_names . map show_name+    filter_names = return . filter is_completion++    run_completer :: Completer -> IO [String]+    run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))++    (ws', ws'') = splitAt i ws++    is_completion+      | (w:_) <- ws'' = isPrefixOf w+      | otherwise     = const True++    compl = do+      setParser Nothing parser+      runParserFully parser (drop 1 ws')++bashCompletionScript :: String -> String -> IO [String]+bashCompletionScript prog progn = return+  [ "_" ++ progn ++ "()"+  , "{"+  , "    local cmdline"+  , "    CMDLINE=(--bash-completion-index $COMP_CWORD)"+  , ""+  , "    for arg in ${COMP_WORDS[@]}; do"+  , "        CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)"+  , "    done"+  , ""+  , "    COMPREPLY=( $(" ++ prog ++ " \"${CMDLINE[@]}\") )"+  , "}"+  , ""+  , "complete -o filenames -F _" ++ progn ++ " " ++ progn ]
Options/Applicative/Builder.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, EmptyDataDecls #-}+{-# LANGUAGE DeriveFunctor #-} module Options.Applicative.Builder (   -- * Parser builders   --@@ -39,6 +39,9 @@   hidden,   internal,   command,+  completeWith,+  action,+  completer,   idm,   (&), @@ -60,6 +63,7 @@   -- * Builder for 'ParserInfo'   InfoMod,   fullDesc,+  briefDesc,   header,   progDesc,   footer,@@ -69,6 +73,7 @@   -- * Builder for 'ParserPrefs'   PrefsMod,   multiSuffix,+  disambiguate,   prefs   ) where @@ -77,11 +82,13 @@ import Data.Maybe import Data.Monoid +import Options.Applicative.Builder.Completer import Options.Applicative.Common import Options.Applicative.Types  data OptionFields a = OptionFields   { optNames :: [OptName]+  , optCompleter :: Completer   , optReader :: String -> Maybe a }   deriving Functor @@ -94,7 +101,8 @@   { cmdCommands :: [(String, ParserInfo a)] }   deriving Functor -data ArgumentFields a+data ArgumentFields a = ArgumentFields+  { argCompleter :: Completer }   deriving Functor  class HasName f where@@ -106,6 +114,15 @@ 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@@ -196,6 +213,24 @@ command cmd pinfo = fieldMod $ \p ->   p { cmdCommands = (cmd, pinfo) : cmdCommands p } +-- | Add a list of possible completion values.+completeWith :: HasCompleter f => [String] -> Mod f a+completeWith xs = completer (listCompleter xs)++-- | Add a bash completion action. Common actions include @file@ and+-- @directory@. See+-- http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins+-- for a complete list.+action :: HasCompleter f => String -> Mod f a+action act = completer (bashCompleter act)++-- | Add a completer to an argument.+--+-- 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)+ -- parsers --  -- | Base default properties.@@ -240,7 +275,10 @@  -- | Builder for an argument parser. argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a-argument p (Mod _ d g) = mkParser d g (ArgReader p)+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.@@ -251,9 +289,9 @@ -- 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 = args1 <|> pure (fromMaybe [] def)+arguments p m = set_default <$> fromM args   where-    Mod _ (DefaultProp def sdef) g = m+    Mod f (DefaultProp def sdef) g = m     show_def = sdef <*> def      p' ('-':_) = Nothing@@ -262,16 +300,23 @@     props = mkProps mempty g     props' = (mkProps mempty g) { propShowDefault = show_def } -    args1 = ((Just <$> arg') <|> (ddash *> pure Nothing)) `BindP` \x -> case x of-      Nothing -> many arg-      Just a -> fmap (a:) args-    args = args1 <|> pure []+    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 p) props)-    arg' = liftOpt (Option (ArgReader p') props')+    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@@ -310,10 +355,12 @@ -- | Builder for an option with a null reader. A non-trivial reader can be -- added using the 'reader' modifier. nullOption :: Mod OptionFields a -> Parser a-nullOption (Mod f d g) = mkParser d g rdr+nullOption m = mkParser d g rdr   where-    rdr = let fields = f (OptionFields [] disabled)-          in OptReader (optNames fields) (optReader fields)+    Mod f d g = metavar "ARG" <> m+    fields = f (OptionFields [] mempty disabled)+    crdr = CReader (optCompleter fields) (optReader fields)+    rdr = OptReader (optNames fields) crdr  -- | Builder for an option taking a 'String' argument. strOption :: Mod OptionFields String -> Parser String@@ -331,10 +378,14 @@   mempty = InfoMod id   mappend m1 m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1 --- | Specify a full description for this parser.+-- | Show a full description in the help text of this parser. fullDesc :: InfoMod a fullDesc = InfoMod $ \i -> i { infoFullDesc = True } +-- | Only show a brief description in the help text of this parser.+briefDesc :: InfoMod a+briefDesc = InfoMod $ \i -> i { infoFullDesc = False }+ -- | Specify a header for this parser. header :: String -> InfoMod a header s = InfoMod $ \i -> i { infoHeader = s }@@ -373,18 +424,22 @@ multiSuffix :: String -> PrefsMod multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s } +disambiguate :: PrefsMod+disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }+ prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base   where     base = ParserPrefs-      { prefMultiSuffix = "" }+      { prefMultiSuffix = ""+      , prefDisambiguate = False }  -- convenience shortcuts ---- | Trivial option modifier.+-- | Trivial option modifier. idm :: Monoid m => m idm = mempty ---- | Compose modifiers.+-- | Compose modifiers. (&) :: Monoid m => m -> m -> m (&) = mappend
+ Options/Applicative/Builder/Completer.hs view
@@ -0,0 +1,28 @@+module Options.Applicative.Builder.Completer+  ( listIOCompleter+  , listCompleter+  , bashCompleter+  ) where++import Control.Applicative+import Control.Exception (IOException, try)+import Data.List+import Options.Applicative.Types+import System.Process++listIOCompleter :: IO [String] -> Completer+listIOCompleter ss = Completer $ \s ->+  filter (isPrefixOf s) <$> ss++listCompleter :: [String] -> Completer+listCompleter = listIOCompleter . pure++bashCompleter :: String -> Completer+bashCompleter action = Completer $ \word -> do+  let cmd = unwords ["compgen", "-A", action, word]++  result <- tryIO $ readProcess "bash" ["-c", cmd] ""+  return . lines . either (const []) id $ result++tryIO :: IO a -> IO (Either IOException a)+tryIO = try
Options/Applicative/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, PatternGuards #-}+{-# LANGUAGE Rank2Types, PatternGuards, ScopedTypeVariables #-} module Options.Applicative.Common (   -- * Option parsers   --@@ -39,8 +39,6 @@   evalParser,    -- * Low-level utilities-  runP,-  setContext,   mapParser,   treeMapParser,   optionNames@@ -48,11 +46,11 @@  import Control.Applicative import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Error-import Control.Monad.Trans.Writer+import Data.List import Data.Maybe import Data.Monoid++import Options.Applicative.Internal import Options.Applicative.Types  optionNames :: OptReader a -> [OptName]@@ -60,14 +58,15 @@ optionNames (FlagReader names _) = names optionNames _ = [] +isOptionPrefix :: OptName -> OptName -> Bool+isOptionPrefix (OptShort x) (OptShort y) = x == y+isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y+isOptionPrefix _ _ = False+ -- | Create a parser composed of a single option. liftOpt :: Option a -> Parser a liftOpt = OptP -uncons :: [a] -> Maybe (a, [a])-uncons [] = Nothing-uncons (x : xs) = Just (x, xs)- data MatchResult   = NoMatch   | Match (Maybe String)@@ -77,30 +76,31 @@   mappend m@(Match _) _ = m   mappend _ m = m -type Matcher a = [String] -> P (a, [String])+type Matcher m a = [String] -> m (a, [String]) -optMatches :: OptReader a -> String -> Maybe (Matcher a)-optMatches rdr arg = case rdr of-  OptReader names f+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-    , arg1 `elem` names+    , has_name arg1 names     -> Just $ \args -> do-         (arg', args') <- tryP . uncons $ maybeToList val ++ args-         r <- tryP $ f arg'+         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-    , arg1 `elem` names+    , has_name arg1 names     -> Just $ \args -> return (x, args)-  ArgReader f-    | Just result <- f arg+  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+         setContext (Just arg) subp+         runParser (infoParser subp) args   _ -> Nothing   where     parsed@@ -114,52 +114,61 @@           [a] -> Just (OptShort a, Nothing)           (a : rest) -> Just (OptShort a, Just rest)       | otherwise = Nothing--tryP :: Maybe a -> P a-tryP = maybe empty return--runP :: P a -> (Either String a, Context)-runP = runWriter . runErrorT--setContext :: Maybe String -> ParserInfo a -> P ()-setContext name = lift . tell . Context name+    has_name a+      | disambiguate = any (isOptionPrefix a)+      | otherwise = elem a -stepParser :: Parser a -> String -> [String] -> P (Parser a, [String])-stepParser (NilP _) _ _ = empty-stepParser (OptP opt) arg args-  | Just matcher <- optMatches (optMain opt) arg-  = do (r, args') <- matcher 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-  [ stepParser p1 arg args-  , stepParser p2 arg args ]-stepParser (BindP p k) arg args = do-  (p', args') <- stepParser p arg args-  x <- evalParser p'-  return (k x, args')+stepParser :: MonadP m => ParserPrefs -> Parser a -> String -> [String] -> [m (Parser a, [String])]+stepParser _ (NilP _) _ _ = []+stepParser prefs (OptP opt) arg args =+  case optMatches disambiguate (optMain opt) arg of+    Just matcher -> pure $ do+      (r, args') <- matcher args+      return (pure r, args')+    Nothing -> empty+  where+    disambiguate = prefDisambiguate prefs+                && optVisibility opt > Internal+stepParser prefs (MultP p1 p2) arg args = msum+  [ flip map (stepParser prefs p1 arg args) $ \m ->+      do (p1', args') <- m+         return (p1' <*> p2, args')+  , flip map (stepParser prefs p2 arg args) $ \m ->+      do (p2', args') <- m+         return (p1 <*> p2', args') ]+stepParser prefs (AltP p1 p2) arg args = msum+  [ stepParser prefs p1 arg args+  , stepParser prefs p2 arg args ]+stepParser prefs (BindP p k) arg args =+  flip map (stepParser prefs p arg args) $ \m -> do+    (p', args') <- m+    x <- liftMaybe $ 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 -- if any options are missing and don't have a default value.-runParser :: Parser a -> [String] -> P (a, [String])+runParser :: MonadP m => Parser a -> [String] -> m (a, [String]) runParser p args = case args of-  [] -> result+  [] -> exitP p result   (arg : argt) -> do-    x <- catchError (Right <$> stepParser p arg argt)-                    (return . Left)+    prefs <- getPrefs+    x <- tryP $ do_step prefs arg argt     case x of-      Left e -> result <|> throwError e+      Left e -> liftMaybe result <|> errorP e       Right (p', args') -> runParser p' args'   where     result = (,) <$> evalParser p <*> pure args+    do_step prefs arg argt+      | prefDisambiguate prefs+      = case parses of+          [m] -> m+          _   -> empty+      | otherwise+      = msum parses+      where parses = stepParser prefs p arg argt -runParserFully :: Parser a -> [String] -> P a+runParserFully :: MonadP m => Parser a -> [String] -> m a runParserFully p args = do   (r, args') <- runParser p args   guard $ null args'@@ -167,9 +176,9 @@  -- | 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) = tryP r-evalParser (OptP _) = empty+evalParser :: Parser a -> Maybe a+evalParser (NilP r) = r+evalParser (OptP _) = Nothing evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2 evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2 evalParser (BindP p k) = evalParser p >>= evalParser . k@@ -191,16 +200,18 @@ treeMapParser g = simplify . go False False g   where     has_default :: Parser a -> Bool-    has_default p = case runP (evalParser p) of-      (Left _, _) -> False-      (Right _, _) -> True+    has_default p = isJust (evalParser p)      go :: Bool -> Bool        -> (forall x . OptHelpInfo -> Option x -> b)        -> Parser a        -> OptTree b     go _ _ _ (NilP _) = MultNode []-    go m d f (OptP opt) = Leaf (f (OptHelpInfo m d) opt)+    go m d f (OptP opt)+      | optVisibility opt > Internal+      = Leaf (f (OptHelpInfo m d) opt)+      | otherwise+      = MultNode []     go m d f (MultP p1 p2) = MultNode [go m d f p1, go m d f p2]     go m d f (AltP p1 p2) = AltNode [go m d' f p1, go m d' f p2]       where d' = d || has_default p1 || has_default p2
Options/Applicative/Extra.hs view
@@ -6,13 +6,17 @@   helper,   execParser,   execParserPure,+  customExecParser,   usage,   ParserFailure(..),   ) where +import Control.Applicative+import Options.Applicative.BashCompletion import Options.Applicative.Common-import Options.Applicative.Builder+import Options.Applicative.Builder hiding (briefDesc) import Options.Applicative.Help+import Options.Applicative.Internal import Options.Applicative.Utils import Options.Applicative.Types import System.Environment@@ -26,6 +30,7 @@        & short 'h'        & help "Show this help text"        & value id+       & metavar ""        & hidden )  -- | Run a program description.@@ -43,43 +48,55 @@     Right a -> return a     Left failure -> do       progn <- getProgName-      hPutStr stderr (errMessage failure progn)-      exitWith (errExitCode failure)+      let c = errExitCode failure+      msg <- errMessage failure progn+      case c of+        ExitSuccess -> putStr msg+        _           -> hPutStr stderr msg+      exitWith c +data Result a = Result a+              | Extra ParserFailure+ -- | A pure version 'execParser'. execParserPure :: ParserPrefs       -- ^ Global preferences for this parser                -> ParserInfo a      -- ^ Description of the program to run                -> [String]          -- ^ Program arguments                -> Either ParserFailure a execParserPure pprefs pinfo args =-  case runP p of-    (Right a, _) -> Right a+  case runP p pprefs of+    (Right r, _) -> case r of+      Result a -> Right a+      Extra failure -> Left failure     (Left msg, ctx) -> Left ParserFailure       { errMessage = \progn-          -> with_context ctx pinfo $ \name ->-                 parserHelpText pprefs+          -> with_context ctx pinfo $ \names ->+                 return+               . parserHelpText pprefs                . add_error msg-               . add_usage name progn+               . add_usage names progn       , errExitCode = ExitFailure (infoFailureCode pinfo) }   where     parser = infoParser pinfo-    add_usage name progn i = i+    add_usage names progn i = i       { infoHeader = vcat           [ infoHeader i           , usage pprefs (infoParser i) ename ] }       where-        ename = maybe progn (\n -> progn ++ " " ++ n) name+        ename = unwords (progn : names)     add_error msg i = i       { infoHeader = vcat [msg, infoHeader i] }      with_context :: Context                  -> ParserInfo a-                 -> (forall b . Maybe String -> ParserInfo b -> c)+                 -> (forall b . [String] -> ParserInfo b -> c)                  -> c-    with_context NullContext i f = f Nothing i+    with_context NullContext i f = f [] i     with_context (Context n i) _ f = f n i -    p = runParserFully parser args+    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
@@ -59,7 +59,7 @@     desc _ opt       | CmdReader cmds p <- optMain opt       = tabulate [(cmd, d)-                 | cmd <- cmds+                 | cmd <- reverse cmds                  , d <- maybeToList . fmap infoProgDesc $ p cmd ]       | otherwise       = []
+ Options/Applicative/Internal.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE GADTs, FlexibleInstances #-}+module Options.Applicative.Internal+  ( P+  , Context(..)+  , MonadP(..)++  , uncons+  , liftMaybe++  , runP++  , Completion+  , runCompletion+  , SomeParser(..)+  , ComplError(..)+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Error+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Data.Maybe+import Data.Monoid++import Options.Applicative.Types++class (Alternative m, MonadPlus m) => MonadP m where+  setContext :: Maybe String -> ParserInfo a -> m ()+  setParser :: Maybe String -> Parser a -> m ()+  getPrefs :: m ParserPrefs++  missingArgP :: Completer -> m a+  tryP :: m a -> m (Either String a)+  errorP :: String -> m a+  exitP :: Parser b -> Maybe a -> m a++type P = ErrorT String (WriterT Context (Reader ParserPrefs))++data Context where+  Context :: [String] -> ParserInfo a -> Context+  NullContext :: Context++contextNames :: Context -> [String]+contextNames (Context ns _) = ns+contextNames NullContext = []++instance Monoid Context where+  mempty = NullContext+  mappend c (Context ns i) = Context (contextNames c ++ ns) i+  mappend c _ = c++instance MonadP P where+  setContext name = lift . tell . Context (maybeToList name)+  setParser _ _ = return ()+  getPrefs = lift . lift $ ask++  missingArgP _ = empty+  tryP p = lift $ runErrorT p+  exitP _ = maybe mzero return+  errorP = throwError++liftMaybe :: MonadPlus m => Maybe a -> m a+liftMaybe = maybe mzero return++runP :: P a -> ParserPrefs -> (Either String a, Context)+runP = runReader . runWriterT . runErrorT++uncons :: [a] -> Maybe (a, [a])+uncons [] = Nothing+uncons (x : xs) = Just (x, xs)++data SomeParser where+  SomeParser :: Parser a -> SomeParser++data ComplError+  = ComplParseError String+  | ComplExit++instance Error ComplError where+  strMsg = ComplParseError++data ComplResult a+  = ComplParser SomeParser+  | ComplOption Completer+  | ComplResult a++instance Functor ComplResult where+  fmap = liftM++instance Applicative ComplResult where+  pure = ComplResult+  (<*>) = ap++instance Monad ComplResult where+  return = pure+  m >>= f = case m of+    ComplResult r -> f r+    ComplParser p -> ComplParser p+    ComplOption c -> ComplOption c++type Completion = ErrorT String (ReaderT ParserPrefs ComplResult)++instance MonadP Completion where+  setContext _ _ = return ()+  setParser _ _ = return ()+  getPrefs = lift ask++  missingArgP = lift . lift . ComplOption+  tryP p = catchError (Right <$> p) (return . Left)+  exitP p _ = lift . lift . ComplParser $ SomeParser p+  errorP = throwError++runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)+runCompletion 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,20 +1,25 @@-{-# LANGUAGE GADTs, DeriveFunctor #-}+{-# LANGUAGE GADTs, DeriveFunctor, Rank2Types #-} module Options.Applicative.Types (   ParserInfo(..),   ParserPrefs(..),-  Context(..),-  P,    Option(..),   OptName(..),   OptReader(..),   OptProperties(..),   OptVisibility(..),+  CReader(..),   Parser(..),+  ParserM(..),+  Completer(..),   ParserFailure(..),   OptHelpInfo(..),   OptTree(..), +  fromM,+  oneM,+  manyM,+   optVisibility,   optMetaVar,   optHelp,@@ -22,12 +27,9 @@   ) where  import Control.Applicative-import Control.Category import Control.Monad import Control.Monad.Trans.Error-import Control.Monad.Trans.Writer import Data.Monoid-import Prelude hiding ((.), id) import System.Exit  -- | A full description for a runnable 'Parser' for a program.@@ -43,19 +45,9 @@ -- | Global preferences for a top-level 'Parser'. data ParserPrefs = ParserPrefs   { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options+  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations   } -data Context where-  Context :: Maybe String -> ParserInfo a -> Context-  NullContext :: Context--instance Monoid Context where-  mempty = NullContext-  mappend _ c@(Context _ _) = c-  mappend c _ = c--type P = ErrorT String (Writer Context)- data OptName = OptShort !Char              | OptLong !String   deriving (Eq, Ord)@@ -81,11 +73,16 @@   , optProps :: OptProperties            -- ^ properties of this option   } deriving Functor +data CReader a = CReader+  { crCompleter :: Completer+  , crReader :: String -> Maybe a }+  deriving Functor+ -- | An 'OptReader' defines whether an option matches an command line argument. data OptReader a-  = OptReader [OptName] (String -> Maybe a)             -- ^ option reader+  = OptReader [OptName] (CReader a)                     -- ^ option reader   | FlagReader [OptName] !a                             -- ^ flag reader-  | ArgReader (String -> Maybe a)                       -- ^ argument reader+  | ArgReader (CReader a)                               -- ^ argument reader   | CmdReader [String] (String -> Maybe (ParserInfo a)) -- ^ command reader   deriving Functor @@ -108,22 +105,57 @@   pure = NilP . Just   (<*>) = MultP +newtype ParserM r = ParserM+  { runParserM :: forall x . (r -> Parser x) -> Parser x }++instance Monad ParserM where+  return x = ParserM $ \k -> k x+  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)++instance Functor ParserM where+  fmap = liftM++instance Applicative ParserM where+  pure = return+  (<*>) = ap++fromM :: ParserM a -> Parser a+fromM (ParserM f) = f pure++oneM :: Parser a -> ParserM a+oneM p = ParserM (BindP p)++manyM :: Parser a -> ParserM [a]+manyM p = do+  mx <- oneM (optional p)+  case mx of+    Nothing -> return []+    Just x -> (x:) <$> manyM p+ instance Alternative Parser where   empty = NilP Nothing   (<|>) = AltP-  many p = some p <|> pure []-  some p = p `BindP` (\r -> (r:) <$> many p)+  many p = fromM $ manyM p+  some p = fromM $ (:) <$> oneM p <*> manyM p +newtype Completer = Completer+  { runCompleter :: String -> IO [String] }++instance Monoid Completer where+  mempty = Completer $ \_ -> return []+  mappend (Completer c1) (Completer c2) =+    Completer $ \s -> (++) <$> c1 s <*> c2 s+ -- | Result after a parse error. data ParserFailure = ParserFailure-  { errMessage :: String -> String -- ^ Function which takes the program name-                                   -- as input and returns an error message-  , errExitCode :: ExitCode        -- ^ Exit code to use for this error+  { 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   }  instance Error ParserFailure where   strMsg msg = ParserFailure-    { errMessage = \_ -> msg+    { errMessage = \_ -> return msg     , errExitCode = ExitFailure 1 }  data OptHelpInfo = OptHelpInfo
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name:                optparse-applicative-version:             0.3.2+version:             0.4.0 synopsis:            Utilities and combinators for parsing command line options description:     Here is a simple example of an applicative option parser:@@ -76,21 +76,25 @@ library   exposed-modules:     Options.Applicative,                        Options.Applicative.Arrows,-                       Options.Applicative.Common,-                       Options.Applicative.Types,+                       Options.Applicative.BashCompletion,                        Options.Applicative.Builder,-                       Options.Applicative.Utils,+                       Options.Applicative.Builder.Completer,+                       Options.Applicative.Common,                        Options.Applicative.Extra,-                       Options.Applicative.Help+                       Options.Applicative.Help,+                       Options.Applicative.Types,+                       Options.Applicative.Utils+  other-modules:       Options.Applicative.Internal   build-depends:       base == 4.*,-                       transformers >= 0.2 && < 0.4+                       transformers >= 0.2 && < 0.4,+                       process == 1.1.* test-suite tests   type:                exitcode-stdio-1.0   hs-source-dirs:      tests   main-is:             Tests.hs   build-depends:       base == 4.*,                        HUnit == 1.2.*,-                       optparse-applicative == 0.3.*,+                       optparse-applicative,                        test-framework == 0.6.*,                        test-framework-hunit == 0.2.*,                        test-framework-th-prime == 0.0.*
tests/Tests.hs view
@@ -30,7 +30,8 @@   let result = run p args   assertLeft result $ \(ParserFailure err code) -> do     expected <- readFile $ "tests/" ++ name ++ ".err.txt"-    expected @=? err name+    msg <- err name+    expected @=? msg     ExitFailure 1 @=? code  case_hello :: Assertion@@ -92,10 +93,11 @@       i = info (p <**> helper) idm       result = run i ["--help"]   case result of-    Left (ParserFailure err _) ->+    Left (ParserFailure err _) -> do+      msg <- err "test"       assertHasLine-        "  -n                       set count (default: 0)"-        (err "test")+        "  -n ARG                   set count (default: 0)"+        msg     Right r  -> assertFailure $ "unexpected result: " ++ show r  case_alt_cont :: Assertion@@ -121,6 +123,73 @@       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")+      p2 = subparser (command "b" (info p3 idm))+      p1 = subparser (command "c" (info p2 idm))+      i = info (p1 <**> helper) idm+  checkHelpText "nested" i ["c", "b"]++case_many_args :: Assertion+case_many_args = do+  let p = arguments 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++case_disambiguate :: Assertion+case_disambiguate = do+  let p =   flag' (1 :: Int) (long "foo")+        <|> flag' 2 (long "bar")+        <|> flag' 3 (long "baz")+      i = info p idm+      result = execParserPure (prefs disambiguate) i ["--f"]+  case result of+    Left _ -> assertFailure "unexpected parse error"+    Right val -> 1 @=? val++case_ambiguous :: Assertion+case_ambiguous = do+  let p =   flag' (1 :: Int) (long "foo")+        <|> flag' 2 (long "bar")+        <|> flag' 3 (long "baz")+      i = info p idm+      result = execParserPure (prefs disambiguate) i ["--ba"]+  case result of+    Left _ -> return ()+    Right val -> assertFailure $ "unexpected result " ++ show val++case_completion :: Assertion+case_completion = do+  let p = (,)+        <$> strOption (long "foo" & value "")+        <*> strOption (long "bar" & value "")+      i = info p idm+      result = run i ["--bash-completion-index", "0"]+  case result of+    Left (ParserFailure err code) -> do+      ExitSuccess @=? code+      completions <- lines <$> err "test"+      ["--foo", "--bar"] @=? completions+    Right val ->+      assertFailure $ "unexpected result " ++ show val++case_bind_usage :: Assertion+case_bind_usage = do+  let p = arguments str (metavar "ARGS...")+      i = info (p <**> helper) briefDesc+      result = run i ["--help"]+  case result of+    Left (ParserFailure err _) -> do+      text <- head . lines <$> err "test"+      "Usage: test [ARGS...]" @=? text+    Right val ->+      assertFailure $ "unexpected result " ++ show val  main :: IO () main = $(defaultMainGenerator)