module Options.Applicative.Common (
Parser,
liftOpt,
ParserInfo(..),
runParser,
runParserFully,
evalParser,
mapParser,
treeMapParser,
optionNames
) where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Monoid
import Options.Applicative.Internal
import Options.Applicative.Types
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 Matcher m a = [String] -> m (a, [String])
optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (Matcher m a)
optMatches disambiguate opt arg = case opt of
OptReader names rdr
| Just (arg1, val) <- parsed
, has_name arg1 names
-> Just $ \args -> do
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
FlagReader names x
| Just (arg1, Nothing) <- parsed
, has_name arg1 names
-> Just $ \args -> return (x, args)
ArgReader rdr
| Just result <- crReader rdr arg
-> Just $ \args -> return (result, args)
CmdReader _ f
| Just subp <- f arg
-> Just $ \args -> do
setContext (Just arg) subp
runParser (infoParser subp) 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
has_name a
| disambiguate = any (isOptionPrefix a)
| otherwise = elem a
stepParser :: MonadP m => ParserPrefs -> Parser a -> String -> [String] -> [m (Parser a, [String])]
stepParser _ (NilP _) _ _ = []
stepParser prefs (OptP opt) arg args =
case optMatches disambiguate (optMain opt) arg of
Just matcher -> pure $ do
(r, args') <- matcher args
return (pure r, args')
Nothing -> empty
where
disambiguate = prefDisambiguate prefs
&& optVisibility opt > Internal
stepParser prefs (MultP p1 p2) arg args = msum
[ flip map (stepParser prefs p1 arg args) $ \m ->
do (p1', args') <- m
return (p1' <*> p2, args')
, flip map (stepParser prefs p2 arg args) $ \m ->
do (p2', args') <- m
return (p1 <*> p2', args') ]
stepParser prefs (AltP p1 p2) arg args = msum
[ stepParser prefs p1 arg args
, stepParser prefs p2 arg args ]
stepParser prefs (BindP p k) arg args =
flip map (stepParser prefs p arg args) $ \m -> do
(p', args') <- m
x <- liftMaybe $ evalParser p'
return (k x, args')
runParser :: MonadP m => Parser a -> [String] -> m (a, [String])
runParser p args = case args of
[] -> exitP p result
(arg : argt) -> do
prefs <- getPrefs
x <- tryP $ do_step prefs arg argt
case x of
Left e -> liftMaybe result <|> errorP e
Right (p', args') -> runParser p' args'
where
result = (,) <$> evalParser p <*> pure args
do_step prefs arg argt
| prefDisambiguate prefs
= case parses of
[m] -> m
_ -> empty
| otherwise
= msum parses
where parses = stepParser prefs p arg argt
runParserFully :: MonadP m => Parser a -> [String] -> 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]