mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-09-11 10:45:25 +03:00
First cut at ReadM shakeup
This commit is contained in:
parent
ff58895437
commit
f3e7b0011c
@ -114,6 +114,7 @@ module Options.Applicative (
|
||||
HasCompleter,
|
||||
HasValue,
|
||||
HasMetavar,
|
||||
|
||||
-- ** Readers
|
||||
--
|
||||
-- | A reader is used by the 'option' and 'argument' builders to parse
|
||||
|
@ -92,7 +92,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
|
||||
-- For options and flags, ensure that the user
|
||||
-- hasn't disabled them with `--`.
|
||||
opt_completions argPolicy hinfo opt = case optMain opt of
|
||||
OptReader ns _ _
|
||||
OptReader ns _
|
||||
| argPolicy /= AllPositionals
|
||||
-> return . add_opt_help opt $ show_names ns
|
||||
| otherwise
|
||||
|
@ -189,7 +189,8 @@ helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }
|
||||
|
||||
-- | Specify the error to display when no argument is provided to this option.
|
||||
noArgError :: ParseError -> Mod OptionFields a
|
||||
noArgError e = fieldMod $ \p -> p { optNoArgError = const e }
|
||||
noArgError = const mempty
|
||||
{-# WARNING noArgError "This builder no longer has any effect. Please examine the ReadM documentation" #-}
|
||||
|
||||
-- | Specify a metavariable for the argument.
|
||||
--
|
||||
@ -337,8 +338,7 @@ switch = flag False True
|
||||
-- 'infoOption' instead.
|
||||
abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
|
||||
abortOption err m = option (readerAbort err) . (`mappend` m) $ mconcat
|
||||
[ noArgError err
|
||||
, value id
|
||||
[ value id
|
||||
, metavar "" ]
|
||||
|
||||
-- | An option that always fails and displays a message.
|
||||
@ -365,9 +365,9 @@ option :: ReadM a -> Mod OptionFields a -> Parser a
|
||||
option r m = mkParser d g rdr
|
||||
where
|
||||
Mod f d g = metavar "ARG" `mappend` m
|
||||
fields = f (OptionFields [] mempty ExpectsArgError)
|
||||
fields = f (OptionFields [] mempty)
|
||||
crdr = CReader (optCompleter fields) r
|
||||
rdr = OptReader (optNames fields) crdr (optNoArgError fields)
|
||||
rdr = OptReader (optNames fields) crdr
|
||||
|
||||
-- | Modifier for 'ParserInfo'.
|
||||
newtype InfoMod a = InfoMod
|
||||
|
@ -33,8 +33,7 @@ import Options.Applicative.Types
|
||||
|
||||
data OptionFields a = OptionFields
|
||||
{ optNames :: [OptName]
|
||||
, optCompleter :: Completer
|
||||
, optNoArgError :: String -> ParseError }
|
||||
, optCompleter :: Completer }
|
||||
|
||||
data FlagFields a = FlagFields
|
||||
{ flagNames :: [OptName]
|
||||
@ -160,9 +159,10 @@ mkParser :: DefaultProp a
|
||||
-> (OptProperties -> OptProperties)
|
||||
-> OptReader a
|
||||
-> Parser a
|
||||
mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def
|
||||
where
|
||||
opt = mkOption d g rdr
|
||||
mkParser d@(DefaultProp def _) g rdr =
|
||||
maybe opt (\def' -> opt <|> pure def') def
|
||||
where
|
||||
opt = liftOpt $ mkOption d g rdr
|
||||
|
||||
mkOption :: DefaultProp a
|
||||
-> (OptProperties -> OptProperties)
|
||||
|
@ -66,7 +66,7 @@ showOption (OptLong n) = "--" ++ n
|
||||
showOption (OptShort n) = '-' : [n]
|
||||
|
||||
optionNames :: OptReader a -> [OptName]
|
||||
optionNames (OptReader names _ _) = names
|
||||
optionNames (OptReader names _) = names
|
||||
optionNames (FlagReader names _) = names
|
||||
optionNames _ = []
|
||||
|
||||
@ -82,8 +82,8 @@ liftOpt = OptP
|
||||
argMatches :: MonadP m => OptReader a -> String
|
||||
-> Maybe (StateT Args m a)
|
||||
argMatches opt arg = case opt of
|
||||
ArgReader rdr -> Just . lift $
|
||||
runReadM (crReader rdr) arg
|
||||
ArgReader rdr -> Just $ StateT $ \args ->
|
||||
execReadM (crReader rdr) (arg : args)
|
||||
CmdReader _ _ f ->
|
||||
flip fmap (f arg) $ \subp -> StateT $ \args -> do
|
||||
prefs <- getPrefs
|
||||
@ -97,15 +97,11 @@ argMatches opt arg = case opt of
|
||||
|
||||
optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
|
||||
optMatches disambiguate opt (OptWord arg1 val) = case opt of
|
||||
OptReader names rdr no_arg_err -> do
|
||||
OptReader names rdr -> do
|
||||
guard $ has_name arg1 names
|
||||
Just $ do
|
||||
args <- get
|
||||
let mb_args = uncons $ maybeToList val ++ args
|
||||
let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr)
|
||||
(arg', args') <- maybe (lift missing_arg) return mb_args
|
||||
put args'
|
||||
lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'
|
||||
return $ StateT $ \args -> do
|
||||
let mb_args = maybeToList val ++ args
|
||||
execReadM (withReadM (errorFor arg1) (crReader rdr)) mb_args
|
||||
|
||||
FlagReader names x -> do
|
||||
guard $ has_name arg1 names
|
||||
|
@ -258,7 +258,7 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
-- reader also ensure that it can be immediately
|
||||
-- reachable from where the error was given.
|
||||
opt_completions hinfo opt = case optMain opt of
|
||||
OptReader ns _ _ -> fmap showOption ns
|
||||
OptReader ns _ -> fmap showOption ns
|
||||
FlagReader ns _ -> fmap showOption ns
|
||||
ArgReader _ -> []
|
||||
CmdReader _ ns _ | hinfoUnreachableArgs hinfo
|
||||
|
@ -7,6 +7,7 @@ module Options.Applicative.Internal
|
||||
, hoistMaybe
|
||||
, hoistEither
|
||||
, runReadM
|
||||
, execReadM
|
||||
, withReadM
|
||||
|
||||
, runP
|
||||
@ -30,9 +31,9 @@ import Prelude
|
||||
import Control.Monad (MonadPlus(..), liftM, ap, guard)
|
||||
import Control.Monad.Trans.Class (MonadTrans, lift)
|
||||
import Control.Monad.Trans.Except
|
||||
(runExcept, runExceptT, withExcept, ExceptT(..), throwE, catchE)
|
||||
(runExceptT, ExceptT(..), throwE, catchE)
|
||||
import Control.Monad.Trans.Reader
|
||||
(mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
|
||||
(runReader, runReaderT, Reader, ReaderT, ask)
|
||||
import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
|
||||
|
||||
import Options.Applicative.Types
|
||||
@ -96,11 +97,14 @@ uncons :: [a] -> Maybe (a, [a])
|
||||
uncons [] = Nothing
|
||||
uncons (x : xs) = Just (x, xs)
|
||||
|
||||
runReadM :: MonadP m => ReadM a -> String -> m a
|
||||
runReadM (ReadM r) s = hoistEither . runExcept $ runReaderT r s
|
||||
execReadM :: MonadP m => ReadM a -> [String] -> m (a, [String])
|
||||
execReadM (ReadM r) s = hoistEither $ r s
|
||||
|
||||
withReadM :: (String -> String) -> ReadM a -> ReadM a
|
||||
withReadM f = ReadM . mapReaderT (withExcept f') . unReadM
|
||||
withReadM f (ReadM r)= ReadM $ \input ->
|
||||
case r input of
|
||||
Left e -> Left (f' e)
|
||||
Right x -> Right x
|
||||
where
|
||||
f' (ErrorMsg err) = ErrorMsg (f err)
|
||||
f' e = e
|
||||
|
@ -45,9 +45,6 @@ module Options.Applicative.Types (
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (ap, liftM, MonadPlus, mzero, mplus)
|
||||
import Control.Monad.Trans.Except (Except, throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Reader (ReaderT, ask)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import Data.Semigroup hiding (Option)
|
||||
import Prelude
|
||||
@ -157,16 +154,17 @@ instance Show (Option a) where
|
||||
instance Functor Option where
|
||||
fmap f (Option m p) = Option (fmap f m) p
|
||||
|
||||
-- | A newtype over 'ReaderT String Except', used by option readers.
|
||||
newtype ReadM a = ReadM
|
||||
{ unReadM :: ReaderT String (Except ParseError) a }
|
||||
newtype ReadM a = ReadM { runReadM :: [String] -> Either ParseError (a, [String]) }
|
||||
|
||||
instance Functor ReadM where
|
||||
fmap f (ReadM r) = ReadM (fmap f r)
|
||||
fmap f (ReadM r) = ReadM $ \input ->
|
||||
case r input of
|
||||
Right (a, rest) -> Right (f a, rest)
|
||||
Left err -> Left err
|
||||
|
||||
instance Applicative ReadM where
|
||||
pure = ReadM . pure
|
||||
ReadM x <*> ReadM y = ReadM $ x <*> y
|
||||
pure a = ReadM $ \inputs -> Right (a, inputs)
|
||||
(<*>) = ap
|
||||
|
||||
instance Alternative ReadM where
|
||||
empty = mzero
|
||||
@ -174,23 +172,31 @@ instance Alternative ReadM where
|
||||
|
||||
instance Monad ReadM where
|
||||
return = pure
|
||||
ReadM r >>= f = ReadM $ r >>= unReadM . f
|
||||
ReadM r >>= f = ReadM $ \inputs -> do
|
||||
(a, rest) <- r inputs
|
||||
runReadM (f a) rest
|
||||
|
||||
fail = Fail.fail
|
||||
|
||||
instance Fail.MonadFail ReadM where
|
||||
fail = readerError
|
||||
|
||||
instance MonadPlus ReadM where
|
||||
mzero = ReadM mzero
|
||||
mplus (ReadM x) (ReadM y) = ReadM $ mplus x y
|
||||
mzero = ReadM $ const (Left UnknownError)
|
||||
mplus (ReadM x) (ReadM y) = ReadM $ \input ->
|
||||
case x input of
|
||||
Right res -> Right res
|
||||
Left _ -> y input
|
||||
|
||||
-- | Return the value being read.
|
||||
readerAsk :: ReadM String
|
||||
readerAsk = ReadM ask
|
||||
readerAsk = ReadM $ \input -> case input of
|
||||
x:xs -> Right (x, xs)
|
||||
[] -> Left (ErrorMsg "expected an argument")
|
||||
|
||||
-- | Abort option reader by exiting with a 'ParseError'.
|
||||
readerAbort :: ParseError -> ReadM a
|
||||
readerAbort = ReadM . lift . throwE
|
||||
readerAbort e = ReadM $ \_ -> Left e
|
||||
|
||||
-- | Abort option reader by exiting with an error message.
|
||||
readerError :: String -> ReadM a
|
||||
@ -205,7 +211,7 @@ instance Functor CReader where
|
||||
|
||||
-- | An 'OptReader' defines whether an option matches an command line argument.
|
||||
data OptReader a
|
||||
= OptReader [OptName] (CReader a) (String -> ParseError)
|
||||
= OptReader [OptName] (CReader a)
|
||||
-- ^ option reader
|
||||
| FlagReader [OptName] !a
|
||||
-- ^ flag reader
|
||||
@ -215,7 +221,7 @@ data OptReader a
|
||||
-- ^ command reader
|
||||
|
||||
instance Functor OptReader where
|
||||
fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
|
||||
fmap f (OptReader ns cr) = OptReader ns (fmap f cr)
|
||||
fmap f (FlagReader ns x) = FlagReader ns (f x)
|
||||
fmap f (ArgReader cr) = ArgReader (fmap f cr)
|
||||
fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)
|
||||
|
Loading…
Reference in New Issue
Block a user