1{-# LANGUAGE Rank2Types #-} 2module Options.Applicative.Common ( 3 -- * Option parsers 4 -- 5 -- | A 'Parser' is composed of a list of options. Several kinds of options 6 -- are supported: 7 -- 8 -- * Flags: simple no-argument options. When a flag is encountered on the 9 -- command line, its value is returned. 10 -- 11 -- * Options: options with an argument. An option can define a /reader/, 12 -- which converts its argument from String to the desired value, or throws a 13 -- parse error if the argument does not validate correctly. 14 -- 15 -- * Arguments: positional arguments, validated in the same way as option 16 -- arguments. 17 -- 18 -- * Commands. A command defines a completely independent sub-parser. When a 19 -- command is encountered, the whole command line is passed to the 20 -- corresponding parser. 21 -- 22 Parser, 23 liftOpt, 24 showOption, 25 26 -- * Program descriptions 27 -- 28 -- A 'ParserInfo' describes a command line program, used to generate a help 29 -- screen. Two help modes are supported: brief and full. In brief mode, only 30 -- an option and argument summary is displayed, while in full mode each 31 -- available option and command, including hidden ones, is described. 32 -- 33 -- A basic 'ParserInfo' with default values for fields can be created using 34 -- the 'info' function. 35 -- 36 -- A 'ParserPrefs' contains general preferences for all command-line 37 -- options, and can be built with the 'prefs' function. 38 ParserInfo(..), 39 ParserPrefs(..), 40 41 -- * Running parsers 42 runParserInfo, 43 runParserFully, 44 runParserStep, 45 runParser, 46 evalParser, 47 48 -- * Low-level utilities 49 mapParser, 50 treeMapParser, 51 optionNames 52 ) where 53 54import Control.Applicative 55import Control.Monad (guard, mzero, msum, when) 56import Control.Monad.Trans.Class (lift) 57import Control.Monad.Trans.State (StateT(..), get, put, runStateT) 58import Data.List (isPrefixOf) 59import Data.Maybe (maybeToList, isJust, isNothing) 60import Prelude 61 62import Options.Applicative.Internal 63import Options.Applicative.Types 64 65showOption :: OptName -> String 66showOption (OptLong n) = "--" ++ n 67showOption (OptShort n) = '-' : [n] 68 69optionNames :: OptReader a -> [OptName] 70optionNames (OptReader names _ _) = names 71optionNames (FlagReader names _) = names 72optionNames _ = [] 73 74isOptionPrefix :: OptName -> OptName -> Bool 75isOptionPrefix (OptShort x) (OptShort y) = x == y 76isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y 77isOptionPrefix _ _ = False 78 79-- | Create a parser composed of a single option. 80liftOpt :: Option a -> Parser a 81liftOpt = OptP 82 83optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a) 84optMatches disambiguate opt (OptWord arg1 val) = case opt of 85 OptReader names rdr no_arg_err -> do 86 guard $ has_name arg1 names 87 Just $ do 88 args <- get 89 let mb_args = uncons $ maybeToList val ++ args 90 let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr) 91 (arg', args') <- maybe (lift missing_arg) return mb_args 92 put args' 93 lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg' 94 95 FlagReader names x -> do 96 guard $ has_name arg1 names 97 -- #242 Flags/switches succeed incorrectly when given an argument. 98 -- We'll not match a long option for a flag if there's a word attached. 99 -- This was revealing an implementation detail as 100 -- `--foo=val` was being parsed as `--foo -val`, which is gibberish. 101 guard $ isShortName arg1 || isNothing val 102 Just $ do 103 args <- get 104 let val' = ('-' :) <$> val 105 put $ maybeToList val' ++ args 106 return x 107 _ -> Nothing 108 where 109 errorFor name msg = "option " ++ showOption name ++ ": " ++ msg 110 111 has_name a 112 | disambiguate = any (isOptionPrefix a) 113 | otherwise = elem a 114 115isArg :: OptReader a -> Bool 116isArg (ArgReader _) = True 117isArg _ = False 118 119data OptWord = OptWord OptName (Maybe String) 120 121parseWord :: String -> Maybe OptWord 122parseWord ('-' : '-' : w) = Just $ let 123 (opt, arg) = case span (/= '=') w of 124 (_, "") -> (w, Nothing) 125 (w', _ : rest) -> (w', Just rest) 126 in OptWord (OptLong opt) arg 127parseWord ('-' : w) = case w of 128 [] -> Nothing 129 (a : rest) -> Just $ let 130 arg = rest <$ guard (not (null rest)) 131 in OptWord (OptShort a) arg 132parseWord _ = Nothing 133 134searchParser :: Monad m 135 => (forall r . Option r -> NondetT m (Parser r)) 136 -> Parser a -> NondetT m (Parser a) 137searchParser _ (NilP _) = mzero 138searchParser f (OptP opt) = f opt 139searchParser f (MultP p1 p2) = foldr1 (<!>) 140 [ do p1' <- searchParser f p1 141 return (p1' <*> p2) 142 , do p2' <- searchParser f p2 143 return (p1 <*> p2') ] 144searchParser f (AltP p1 p2) = msum 145 [ searchParser f p1 146 , searchParser f p2 ] 147searchParser f (BindP p k) = msum 148 [ do p' <- searchParser f p 149 return $ BindP p' k 150 , case evalParser p of 151 Nothing -> mzero 152 Just aa -> searchParser f (k aa) ] 153 154searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a 155 -> NondetT (StateT Args m) (Parser a) 156searchOpt pprefs w = searchParser $ \opt -> do 157 let disambiguate = prefDisambiguate pprefs 158 && optVisibility opt > Internal 159 case optMatches disambiguate (optMain opt) w of 160 Just matcher -> lift $ fmap pure matcher 161 Nothing -> mzero 162 163searchArg :: MonadP m => ParserPrefs -> String -> Parser a 164 -> NondetT (StateT Args m) (Parser a) 165searchArg prefs arg = 166 searchParser $ \opt -> do 167 when (isArg (optMain opt)) cut 168 case optMain opt of 169 CmdReader _ _ f -> 170 case (f arg, prefBacktrack prefs) of 171 (Just subp, NoBacktrack) -> lift $ do 172 args <- get <* put [] 173 fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext 174 175 (Just subp, Backtrack) -> fmap pure . lift . StateT $ \args -> 176 enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext 177 178 (Just subp, SubparserInline) -> lift $ do 179 lift $ enterContext arg subp 180 return $ infoParser subp 181 182 (Nothing, _) -> mzero 183 ArgReader rdr -> 184 fmap pure . lift . lift $ runReadM (crReader rdr) arg 185 _ -> mzero 186 187stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String 188 -> Parser a -> NondetT (StateT Args m) (Parser a) 189stepParser pprefs AllPositionals arg p = 190 searchArg pprefs arg p 191stepParser pprefs ForwardOptions arg p = case parseWord arg of 192 Just w -> searchOpt pprefs w p <|> searchArg pprefs arg p 193 Nothing -> searchArg pprefs arg p 194stepParser pprefs _ arg p = case parseWord arg of 195 Just w -> searchOpt pprefs w p 196 Nothing -> searchArg pprefs arg p 197 198 199-- | Apply a 'Parser' to a command line, and return a result and leftover 200-- arguments. This function returns an error if any parsing error occurs, or 201-- if any options are missing and don't have a default value. 202runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args) 203runParser policy _ p ("--" : argt) | policy /= AllPositionals 204 = runParser AllPositionals CmdCont p argt 205runParser policy isCmdStart p args = case args of 206 [] -> exitP isCmdStart policy p result 207 (arg : argt) -> do 208 (mp', args') <- do_step arg argt 209 case mp' of 210 Nothing -> hoistMaybe result <|> parseError arg p 211 Just p' -> runParser (newPolicy arg) CmdCont p' args' 212 where 213 result = 214 (,) <$> evalParser p <*> pure args 215 do_step = 216 runParserStep policy p 217 218 newPolicy a = case policy of 219 NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals 220 x -> x 221 222runParserStep :: MonadP m => ArgPolicy -> Parser a -> String -> Args -> m (Maybe (Parser a), Args) 223runParserStep policy p arg args = do 224 prefs <- getPrefs 225 flip runStateT args 226 $ disamb (not (prefDisambiguate prefs)) 227 $ stepParser prefs policy arg p 228 229parseError :: MonadP m => String -> Parser x -> m a 230parseError arg = errorP . UnexpectedError arg . SomeParser 231 232runParserInfo :: MonadP m => ParserInfo a -> Args -> m a 233runParserInfo i = runParserFully (infoPolicy i) (infoParser i) 234 235runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a 236runParserFully policy p args = do 237 (r, args') <- runParser policy CmdStart p args 238 case args' of 239 [] -> return r 240 a:_ -> parseError a (pure ()) 241 242-- | The default value of a 'Parser'. This function returns an error if any of 243-- the options don't have a default value. 244evalParser :: Parser a -> Maybe a 245evalParser (NilP r) = r 246evalParser (OptP _) = Nothing 247evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2 248evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2 249evalParser (BindP p k) = evalParser p >>= evalParser . k 250 251-- | Map a polymorphic function over all the options of a parser, and collect 252-- the results in a list. 253mapParser :: (forall x. ArgumentReachability -> Option x -> b) 254 -> Parser a -> [b] 255mapParser f = flatten . treeMapParser f 256 where 257 flatten (Leaf x) = [x] 258 flatten (MultNode xs) = xs >>= flatten 259 flatten (AltNode _ xs) = xs >>= flatten 260 flatten (BindNode x) = flatten x 261 262-- | Like 'mapParser', but collect the results in a tree structure. 263treeMapParser :: (forall x. ArgumentReachability -> Option x -> b) 264 -> Parser a 265 -> OptTree b 266treeMapParser g = simplify . go False g 267 where 268 has_default :: Parser a -> Bool 269 has_default p = isJust (evalParser p) 270 271 go :: Bool 272 -> (forall x. ArgumentReachability -> Option x -> b) 273 -> Parser a 274 -> OptTree b 275 go _ _ (NilP _) = MultNode [] 276 go r f (OptP opt) 277 | optVisibility opt > Internal 278 = Leaf (f (ArgumentReachability r) opt) 279 | otherwise 280 = MultNode [] 281 go r f (MultP p1 p2) = 282 MultNode [go r f p1, go r' f p2] 283 where r' = r || hasArg p1 284 go r f (AltP p1 p2) = 285 AltNode altNodeType [go r f p1, go r f p2] 286 where 287 -- The 'AltNode' indicates if one of the branches has a default. 288 -- This is used for rendering brackets, as well as filtering 289 -- out optional arguments when generating the "missing:" text. 290 altNodeType = 291 if has_default p1 || has_default p2 292 then MarkDefault 293 else NoDefault 294 295 go r f (BindP p k) = 296 let go' = go r f p 297 in case evalParser p of 298 Nothing -> BindNode go' 299 Just aa -> BindNode (MultNode [ go', go r f (k aa) ]) 300 301 hasArg :: Parser a -> Bool 302 hasArg (NilP _) = False 303 hasArg (OptP p) = (isArg . optMain) p 304 hasArg (MultP p1 p2) = hasArg p1 || hasArg p2 305 hasArg (AltP p1 p2) = hasArg p1 || hasArg p2 306 hasArg (BindP p _) = hasArg p 307 308simplify :: OptTree a -> OptTree a 309simplify (Leaf x) = Leaf x 310simplify (MultNode xs) = 311 case concatMap (remove_mult . simplify) xs of 312 [x] -> x 313 xs' -> MultNode xs' 314 where 315 remove_mult (MultNode ts) = ts 316 remove_mult t = [t] 317simplify (AltNode b xs) = 318 AltNode b (concatMap (remove_alt . simplify) xs) 319 where 320 remove_alt (AltNode _ ts) = ts 321 remove_alt (MultNode []) = [] 322 remove_alt t = [t] 323simplify (BindNode x) = 324 BindNode $ simplify x 325