diff --git a/Options/Applicative.hs b/Options/Applicative.hs --- a/Options/Applicative.hs +++ b/Options/Applicative.hs @@ -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 diff --git a/Options/Applicative/BashCompletion.hs b/Options/Applicative/BashCompletion.hs new file mode 100644 --- /dev/null +++ b/Options/Applicative/BashCompletion.hs @@ -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 ] diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -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 diff --git a/Options/Applicative/Builder/Completer.hs b/Options/Applicative/Builder/Completer.hs new file mode 100644 --- /dev/null +++ b/Options/Applicative/Builder/Completer.hs @@ -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 diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -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 diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -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 diff --git a/Options/Applicative/Help.hs b/Options/Applicative/Help.hs --- a/Options/Applicative/Help.hs +++ b/Options/Applicative/Help.hs @@ -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 = [] diff --git a/Options/Applicative/Internal.hs b/Options/Applicative/Internal.hs new file mode 100644 --- /dev/null +++ b/Options/Applicative/Internal.hs @@ -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 diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -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 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.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.* diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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)