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