First cut at ReadM shakeup

Options/Applicative.hs

@@ -114,6 +114,7 @@ module Options.Applicative (
   HasCompleter,
   HasValue,
   HasMetavar,
+
   -- ** Readers
   --
   -- | A reader is used by the 'option' and 'argument' builders to parse

Options/Applicative/BashCompletion.hs

@@ -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

Options/Applicative/Builder.hs

@@ -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

Options/Applicative/Builder/Internal.hs

@@ -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)

Options/Applicative/Common.hs

@@ -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

Options/Applicative/Extra.hs

@@ -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

Options/Applicative/Internal.hs

@@ -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

Options/Applicative/Types.hs

@@ -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)