Implement completion with completers.

Options/Applicative/BashCompletion.hs

@@ -32,8 +32,9 @@ bashCompletionParser parser = complParser
 
 bashCompletionQuery :: Parser a -> [String] -> Int -> String -> IO [String]
 bashCompletionQuery parser ws i _ = case runCompletion compl parser of
-  (Left ComplExit, SomeParser p, _) -> list_options p
-  _ -> return []
+  Just (Left (SomeParser p)) -> list_options p
+  Just (Right c)             -> run_completer c
+  _                          -> return []
   where
     list_options =
         fmap concat

Options/Applicative/Common.hs

@@ -79,7 +79,8 @@ optMatches opt arg = case opt of
     | Just (arg1, val) <- parsed
     , arg1 `elem` names
     -> Just $ \args -> do
-         (arg', args') <- liftMaybe . uncons $ maybeToList val ++ args
+         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
@@ -136,14 +137,12 @@ stepParser (BindP p k) arg args = do
 -- if any options are missing and don't have a default value.
 runParser :: MonadP m => Parser a -> [String] -> m (a, [String])
 runParser p args = case args of
-  [] -> maybe exitP return result
+  [] -> maybe (exitP p) return result
   (arg : argt) -> do
     x <- tryP (stepParser p arg argt)
     case x of
       Left e -> liftMaybe result <|> errorP e
-      Right (p', args') -> do
-        setParser (Just arg) p'
-        runParser p' args'
+      Right (p', args') -> runParser p' args'
   where
     result = (,) <$> evalParser p <*> pure args
 

Options/Applicative/Internal.hs

@@ -13,7 +13,6 @@ module Options.Applicative.Internal
   , runCompletion
   , SomeParser(..)
   , ComplError(..)
-  , exitCompletion
   ) where
 
 import Control.Applicative
@@ -33,9 +32,10 @@ class (Alternative m, MonadPlus m) => MonadP m where
   setContext :: Maybe String -> ParserInfo a -> m ()
   setParser :: Maybe String -> Parser a -> m ()
 
+  missingArgP :: Completer -> m a
   tryP :: m a -> m (Either (PError m) a)
   errorP :: PError m -> m a
-  exitP :: m a
+  exitP :: Parser b -> m a
 
 type P = ErrorT String (Writer Context)
 
@@ -54,9 +54,9 @@ instance MonadP P where
   setContext name = lift . tell . Context name
   setParser _ _ = return ()
 
-
+  missingArgP _ = empty
   tryP p = lift $ runErrorT p
-  exitP = mzero
+  exitP _ = mzero
   errorP = throwError
 
 liftMaybe :: MonadPlus m => Maybe a -> m a
@@ -83,29 +83,43 @@ data ComplError
 instance Error ComplError where
   strMsg = ComplParseError
 
-type Completion = ErrorT ComplError (State ComplState)
+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 (StateT ComplState ComplResult)
 
 instance MonadP Completion where
-  type PError Completion = ComplError
+  type PError Completion = String
 
   setContext val i = setParser val (infoParser i)
   setParser val p = lift . modify $ \s -> s
     { complParser = SomeParser p
     , complArg = fromMaybe "" val }
 
-  tryP p = do
-    r <- lift $ runErrorT p
-    case r of
-      Left e@(ComplParseError _) -> return (Left e)
-      Left e -> throwError e
-      Right x -> return (Right x)
-  exitP = throwError ComplExit
+  missingArgP = lift . lift . ComplOption
+  tryP p = catchError (Right <$> p) (return . Left)
+  exitP = lift . lift . ComplParser . SomeParser
   errorP = throwError
 
-runCompletion :: Completion r -> Parser a -> (Either ComplError r, SomeParser, String)
-runCompletion c p = case runState (runErrorT c) s of
-  (r, s') -> (r, complParser s', complArg s')
+runCompletion :: Completion r -> Parser a -> Maybe (Either SomeParser Completer)
+runCompletion c p = case runStateT (runErrorT c) s of
+  ComplResult _ -> Nothing
+  ComplParser p' -> Just $ Left p'
+  ComplOption compl -> Just $ Right compl
   where s = ComplState (SomeParser p) ""
-
-exitCompletion :: Completion ()
-exitCompletion = throwError ComplExit