module Options.Applicative.Common (
Parser,
liftOpt,
showOption,
ParserInfo(..),
runParser,
runParserFully,
evalParser,
mapParser,
treeMapParser,
optionNames
) where
import Control.Applicative (pure, (<*>), (<$>), (<|>))
import Control.Monad (guard, mzero, msum, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
import Data.List (isPrefixOf)
import Data.Maybe (maybeToList, isJust)
import Data.Monoid (Monoid(..))
import Options.Applicative.Internal
import Options.Applicative.Types
showOption :: OptName -> String
showOption (OptLong n) = "--" ++ n
showOption (OptShort n) = '-' : [n]
optionNames :: OptReader a -> [OptName]
optionNames (OptReader names _ _) = names
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
liftOpt :: Option a -> Parser a
liftOpt = OptP
data MatchResult
= NoMatch
| Match (Maybe String)
instance Monoid MatchResult where
mempty = NoMatch
mappend m@(Match _) _ = m
mappend _ m = m
type Args = [String]
optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (StateT Args m a)
optMatches disambiguate opt arg = case opt of
OptReader names rdr no_arg_err -> do
(arg1, val) <- parsed
guard $ has_name arg1 names
Just $ do
args <- get
let mb_args = uncons $ maybeToList val ++ args
let missing_arg = lift $ missingArgP no_arg_err (crCompleter rdr)
(arg', args') <- maybe missing_arg return mb_args
put args'
case runReadM (crReader rdr arg') of
Left e -> lift $ errorFor arg1 e
Right r -> return r
FlagReader names x -> do
(arg1, Nothing) <- parsed
guard $ has_name arg1 names
Just $ return x
ArgReader rdr -> do
result <- crReader rdr arg
Just $ return result
CmdReader _ f ->
flip fmap (f arg) $ \subp -> StateT $ \args -> do
setContext (Just arg) subp
prefs <- getPrefs
let runSubparser
| prefBacktrack prefs = runParser
| otherwise = \p a
-> (,) <$> runParserFully p a <*> pure []
runSubparser (infoParser subp) args
where
errorFor name (ErrorMsg msg) =
errorP (ErrorMsg ("option " ++ showOption name ++ ": " ++ msg))
errorFor _ e = errorP e
parsed =
case arg of
'-' : '-' : arg1 ->
Just $
case span (/= '=') arg1 of
(_, "") -> (OptLong arg1, Nothing)
(arg1', _ : rest) -> (OptLong arg1', Just rest)
'-' : arg1 ->
case arg1 of
[] -> Nothing
(a : rest) -> Just (OptShort a, if null rest then Nothing else Just rest)
_ -> Nothing
has_name a
| disambiguate = any (isOptionPrefix a)
| otherwise = elem a
isArg :: OptReader a -> Bool
isArg (ArgReader _) = True
isArg _ = False
stepParser :: MonadP m => ParserPrefs -> String -> Parser a
-> NondetT (StateT Args m) (Parser a)
stepParser _ _ (NilP _) = mzero
stepParser prefs arg (OptP opt) = do
when (isArg (optMain opt)) cut
case optMatches disambiguate (optMain opt) arg of
Just matcher -> pure <$> lift matcher
Nothing -> mzero
where
disambiguate = prefDisambiguate prefs
&& optVisibility opt > Internal
stepParser prefs arg (MultP p1 p2) = foldr1 (<!>)
[ do p1' <- stepParser prefs arg p1
return (p1' <*> p2)
, do p2' <- stepParser prefs arg p2
return (p1 <*> p2') ]
stepParser prefs arg (AltP p1 p2) = msum
[ stepParser prefs arg p1
, stepParser prefs arg p2 ]
stepParser prefs arg (BindP p k) = do
p' <- stepParser prefs arg p
x <- hoistMaybe $ evalParser p'
return (k x)
runParser :: MonadP m => Parser a -> Args -> m (a, Args)
runParser p args = case args of
[] -> exitP p result
(arg : argt) -> do
prefs <- getPrefs
x <- do_step prefs arg argt
case x of
Left e -> case (result, e) of
(Just r, ErrorMsg _) -> return r
_ -> errorP e
Right (p', args') -> runParser p' args'
where
result = (,) <$> evalParser p <*> pure args
do_step prefs arg argt = tryP
. (`runStateT` argt)
. (>>= maybe ((lift . parseError) arg) return)
. disamb (not (prefDisambiguate prefs))
$ stepParser prefs arg p
parseError :: MonadP m => String -> m a
parseError arg = errorP . ErrorMsg $ msg
where
msg = case arg of
('-':_) -> "Invalid option `" ++ arg ++ "'"
_ -> "Invalid argument `" ++ arg ++ "'"
runParserFully :: MonadP m => Parser a -> Args -> m a
runParserFully p args = do
(r, args') <- runParser p args
guard $ null args'
return r
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
mapParser :: (forall x. OptHelpInfo -> Option x -> b)
-> Parser a -> [b]
mapParser f = flatten . treeMapParser f
where
flatten (Leaf x) = [x]
flatten (MultNode xs) = xs >>= flatten
flatten (AltNode xs) = xs >>= flatten
treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)
-> Parser a
-> OptTree b
treeMapParser g = simplify . go False False g
where
has_default :: Parser a -> Bool
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)
| 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
go _ d f (BindP p _) = go True d f p
simplify :: OptTree a -> OptTree a
simplify (Leaf x) = Leaf x
simplify (MultNode xs) =
case concatMap (remove_mult . simplify) xs of
[x] -> x
xs' -> MultNode xs'
where
remove_mult (MultNode ts) = ts
remove_mult t = [t]
simplify (AltNode xs) =
case concatMap (remove_alt . simplify) xs of
[] -> MultNode []
[x] -> x
xs' -> AltNode xs'
where
remove_alt (AltNode ts) = ts
remove_alt (MultNode []) = []
remove_alt t = [t]