module Options.Applicative.Common (
Parser,
liftOpt,
ParserInfo(..),
runParser,
runParserFully,
evalParser,
runP,
setContext,
mapParser,
optionNames
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Error
import Control.Monad.Trans.Writer
import Data.Lens.Common
import Data.Maybe
import Data.Monoid
import Options.Applicative.Types
optionNames :: OptReader a -> [OptName]
optionNames (OptReader names _) = names
optionNames (FlagReader names _) = names
optionNames _ = []
liftOpt :: Option r a -> Parser a
liftOpt opt = ConsP (fmap const opt) (pure ())
uncons :: [a] -> Maybe (a, [a])
uncons [] = Nothing
uncons (x : xs) = Just (x, xs)
data MatchResult
= NoMatch
| Match (Maybe String)
instance Monoid MatchResult where
mempty = NoMatch
mappend m@(Match _) _ = m
mappend _ m = m
type Matcher a = [String] -> P (a, [String])
optMatches :: OptReader a -> String -> Maybe (Matcher a)
optMatches rdr arg = case rdr of
OptReader names f
| Just (arg1, val) <- parsed
, arg1 `elem` names
-> Just $ \args -> do
(arg', args') <- tryP . uncons $ maybeToList val ++ args
r <- tryP $ f arg'
return (r, args')
| otherwise -> Nothing
FlagReader names x
| Just (arg1, Nothing) <- parsed
, arg1 `elem` names
-> Just $ \args -> return (x, args)
ArgReader f
| Just result <- f arg
-> Just $ \args -> return (result, args)
CmdReader _ f
| Just subp <- f arg
-> Just $ \args -> do
setContext (Just arg) subp
runParser (subp^.infoParser) args
_ -> Nothing
where
parsed
| '-' : '-' : arg1 <- arg
= case span (/= '=') arg1 of
(_, "") -> Just (OptLong arg1, Nothing)
(arg1', _ : rest) -> Just (OptLong arg1', Just rest)
| '-' : arg1 <- arg
= case arg1 of
[] -> Nothing
[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
stepParser :: Parser a -> String -> [String] -> P (Parser a, [String])
stepParser (NilP _) _ _ = empty
stepParser (ConsP opt p) arg args
| Just matcher <- optMatches (opt^.optMain) arg
= do (r, args') <- matcher args
liftOpt' <- getL optCont opt r
return (liftOpt' <*> p, args')
| otherwise
= do (p', args') <- stepParser p arg args
return (ConsP opt p', args')
runParser :: Parser a -> [String] -> P (a, [String])
runParser p args = case args of
[] -> result
(arg : argt) -> do
x <- catchError (Right <$> stepParser p arg argt)
(return . Left)
case x of
Left e -> result <|> throwError e
Right (p', args') -> runParser p' args'
where
result = (,) <$> evalParser p <*> pure args
runParserFully :: Parser a -> [String] -> P a
runParserFully p args = do
(r, args') <- runParser p args
guard $ null args'
return r
evalParser :: Parser a -> P a
evalParser (NilP r) = pure r
evalParser (ConsP opt p) = tryP (opt^.optDefault) <*> evalParser p
mapParser :: (forall r x . Option r x -> b)
-> Parser a
-> [b]
mapParser _ (NilP _) = []
mapParser f (ConsP opt p) = f opt : mapParser f p