1{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification #-}
2module Options.Applicative.Types (
3  ParseError(..),
4  ParserInfo(..),
5  ParserPrefs(..),
6
7  Option(..),
8  OptName(..),
9  isShortName,
10  isLongName,
11
12  OptReader(..),
13  OptProperties(..),
14  OptVisibility(..),
15  Backtracking(..),
16  ReadM(..),
17  readerAsk,
18  readerAbort,
19  readerError,
20  CReader(..),
21  Parser(..),
22  ParserM(..),
23  Completer(..),
24  mkCompleter,
25  CompletionResult(..),
26  ParserFailure(..),
27  ParserResult(..),
28  overFailure,
29  Args,
30  ArgPolicy(..),
31  ArgumentReachability(..),
32  AltNodeType(..),
33  OptTree(..),
34  ParserHelp(..),
35  SomeParser(..),
36  Context(..),
37  IsCmdStart(..),
38
39  fromM,
40  oneM,
41  manyM,
42  someM,
43
44  filterOptional,
45  optVisibility,
46  optMetaVar,
47  optHelp,
48  optShowDefault,
49  optDescMod
50  ) where
51
52import Control.Applicative
53import Control.Monad (ap, liftM, MonadPlus, mzero, mplus)
54import Control.Monad.Trans.Except (Except, throwE)
55import Control.Monad.Trans.Class (lift)
56import Control.Monad.Trans.Reader (ReaderT, ask)
57import qualified Control.Monad.Fail as Fail
58import Data.Semigroup hiding (Option)
59import Prelude
60
61import System.Exit (ExitCode(..))
62
63import Options.Applicative.Help.Types
64import Options.Applicative.Help.Pretty
65import Options.Applicative.Help.Chunk
66
67
68data ParseError
69  = ErrorMsg String
70  | InfoMsg String
71  | ShowHelpText (Maybe String)
72  | UnknownError
73  | MissingError IsCmdStart SomeParser
74  | ExpectsArgError String
75  | UnexpectedError String SomeParser
76
77data IsCmdStart = CmdStart | CmdCont
78  deriving Show
79
80instance Monoid ParseError where
81  mempty = UnknownError
82  mappend = (<>)
83
84instance Semigroup ParseError where
85  m <> UnknownError = m
86  _ <> m = m
87
88-- | A full description for a runnable 'Parser' for a program.
89data ParserInfo a = ParserInfo
90  { infoParser :: Parser a    -- ^ the option parser for the program
91  , infoFullDesc :: Bool      -- ^ whether the help text should contain full
92                              -- documentation
93  , infoProgDesc :: Chunk Doc -- ^ brief parser description
94  , infoHeader :: Chunk Doc   -- ^ header of the full parser description
95  , infoFooter :: Chunk Doc   -- ^ footer of the full parser description
96  , infoFailureCode :: Int    -- ^ exit code for a parser failure
97  , infoPolicy :: ArgPolicy   -- ^ allow regular options and flags to occur
98                              -- after arguments (default: InterspersePolicy)
99  }
100
101instance Functor ParserInfo where
102  fmap f i = i { infoParser = fmap f (infoParser i) }
103
104data Backtracking
105  = Backtrack
106  | NoBacktrack
107  | SubparserInline
108  deriving (Eq, Show)
109
110-- | Global preferences for a top-level 'Parser'.
111data ParserPrefs = ParserPrefs
112  { prefMultiSuffix :: String     -- ^ metavar suffix for multiple options
113  , prefDisambiguate :: Bool      -- ^ automatically disambiguate abbreviations
114                                  -- (default: False)
115  , prefShowHelpOnError :: Bool   -- ^ always show help text on parse errors
116                                  -- (default: False)
117  , prefShowHelpOnEmpty :: Bool   -- ^ show the help text for a command or subcommand
118                                  -- if it fails with no input (default: False)
119  , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a
120                                  -- subcommand fails (default: Backtrack)
121  , prefColumns :: Int            -- ^ number of columns in the terminal, used to
122                                  -- format the help page (default: 80)
123  , prefHelpLongEquals :: Bool    -- ^ when displaying long names in usage and help,
124                                  -- use an '=' sign for long names, rather than a
125                                  -- single space (default: False)
126  , prefHelpShowGlobal :: Bool    -- ^ when displaying subparsers' usage help,
127                                  -- show parent options under a "global options"
128                                  -- section (default: True)
129  } deriving (Eq, Show)
130
131data OptName = OptShort !Char
132             | OptLong !String
133  deriving (Eq, Ord, Show)
134
135isShortName :: OptName -> Bool
136isShortName (OptShort _) = True
137isShortName (OptLong _)  = False
138
139isLongName :: OptName -> Bool
140isLongName = not . isShortName
141
142-- | Visibility of an option in the help text.
143data OptVisibility
144  = Internal          -- ^ does not appear in the help text at all
145  | Hidden            -- ^ only visible in the full description
146  | Visible           -- ^ visible both in the full and brief descriptions
147  deriving (Eq, Ord, Show)
148
149-- | Specification for an individual parser option.
150data OptProperties = OptProperties
151  { propVisibility :: OptVisibility       -- ^ whether this flag is shown in the brief description
152  , propHelp :: Chunk Doc                 -- ^ help text for this option
153  , propMetaVar :: String                 -- ^ metavariable for this option
154  , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default
155  , propShowGlobal :: Bool                -- ^ whether the option is presented in global options text
156  , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description
157  }
158
159instance Show OptProperties where
160  showsPrec p (OptProperties pV pH pMV pSD pSG _)
161    = showParen (p >= 11)
162    $ showString "OptProperties { propVisibility = " . shows pV
163    . showString ", propHelp = " . shows pH
164    . showString ", propMetaVar = " . shows pMV
165    . showString ", propShowDefault = " . shows pSD
166    . showString ", propShowGlobal = " . shows pSG
167    . showString ", propDescMod = _ }"
168
169-- | A single option of a parser.
170data Option a = Option
171  { optMain :: OptReader a               -- ^ reader for this option
172  , optProps :: OptProperties            -- ^ properties of this option
173  }
174
175data SomeParser = forall a . SomeParser (Parser a)
176
177-- | Subparser context, containing the 'name' of the subparser and its parser info.
178--   Used by parserFailure to display relevant usage information when parsing inside a subparser fails.
179data Context = forall a. Context String (ParserInfo a)
180
181instance Show (Option a) where
182    show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"
183
184instance Functor Option where
185  fmap f (Option m p) = Option (fmap f m) p
186
187-- | A newtype over 'ReaderT String Except', used by option readers.
188newtype ReadM a = ReadM
189  { unReadM :: ReaderT String (Except ParseError) a }
190
191instance Functor ReadM where
192  fmap f (ReadM r) = ReadM (fmap f r)
193
194instance Applicative ReadM where
195  pure = ReadM . pure
196  ReadM x <*> ReadM y = ReadM $ x <*> y
197
198instance Alternative ReadM where
199  empty = mzero
200  (<|>) = mplus
201
202instance Monad ReadM where
203  return = pure
204  ReadM r >>= f = ReadM $ r >>= unReadM . f
205
206#if !(MIN_VERSION_base(4,13,0))
207  fail = Fail.fail
208#endif
209
210instance Fail.MonadFail ReadM where
211  fail = readerError
212
213instance MonadPlus ReadM where
214  mzero = ReadM mzero
215  mplus (ReadM x) (ReadM y) = ReadM $ mplus x y
216
217-- | Return the value being read.
218readerAsk :: ReadM String
219readerAsk = ReadM ask
220
221-- | Abort option reader by exiting with a 'ParseError'.
222readerAbort :: ParseError -> ReadM a
223readerAbort = ReadM . lift . throwE
224
225-- | Abort option reader by exiting with an error message.
226readerError :: String -> ReadM a
227readerError = readerAbort . ErrorMsg
228
229data CReader a = CReader
230  { crCompleter :: Completer
231  , crReader :: ReadM a }
232
233instance Functor CReader where
234  fmap f (CReader c r) = CReader c (fmap f r)
235
236-- | An 'OptReader' defines whether an option matches an command line argument.
237data OptReader a
238  = OptReader [OptName] (CReader a) (String -> ParseError)
239  -- ^ option reader
240  | FlagReader [OptName] !a
241  -- ^ flag reader
242  | ArgReader (CReader a)
243  -- ^ argument reader
244  | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))
245  -- ^ command reader
246
247instance Functor OptReader where
248  fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
249  fmap f (FlagReader ns x) = FlagReader ns (f x)
250  fmap f (ArgReader cr) = ArgReader (fmap f cr)
251  fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)
252
253-- | A @Parser a@ is an option parser returning a value of type 'a'.
254data Parser a
255  = NilP (Maybe a)
256  | OptP (Option a)
257  | forall x . MultP (Parser (x -> a)) (Parser x)
258  | AltP (Parser a) (Parser a)
259  | forall x . BindP (Parser x) (x -> Parser a)
260
261instance Functor Parser where
262  fmap f (NilP x) = NilP (fmap f x)
263  fmap f (OptP opt) = OptP (fmap f opt)
264  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2
265  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)
266  fmap f (BindP p k) = BindP p (fmap f . k)
267
268instance Applicative Parser where
269  pure = NilP . Just
270  (<*>) = MultP
271
272newtype ParserM r = ParserM
273  { runParserM :: forall x . (r -> Parser x) -> Parser x }
274
275instance Monad ParserM where
276  return = pure
277  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)
278
279instance Functor ParserM where
280  fmap = liftM
281
282instance Applicative ParserM where
283  pure x = ParserM $ \k -> k x
284  (<*>) = ap
285
286fromM :: ParserM a -> Parser a
287fromM (ParserM f) = f pure
288
289oneM :: Parser a -> ParserM a
290oneM p = ParserM (BindP p)
291
292manyM :: Parser a -> ParserM [a]
293manyM p = do
294  mx <- oneM (optional p)
295  case mx of
296    Nothing -> return []
297    Just x -> (x:) <$> manyM p
298
299someM :: Parser a -> ParserM [a]
300someM p = (:) <$> oneM p <*> manyM p
301
302instance Alternative Parser where
303  empty = NilP Nothing
304  (<|>) = AltP
305  many = fromM . manyM
306  some = fromM . someM
307
308-- | A shell complete function.
309newtype Completer = Completer
310  { runCompleter :: String -> IO [String] }
311
312-- | Smart constructor for a 'Completer'
313mkCompleter :: (String -> IO [String]) -> Completer
314mkCompleter = Completer
315
316instance Semigroup Completer where
317  (Completer c1) <> (Completer c2) =
318    Completer $ \s -> (++) <$> c1 s <*> c2 s
319
320instance Monoid Completer where
321  mempty = Completer $ \_ -> return []
322  mappend = (<>)
323
324newtype CompletionResult = CompletionResult
325  { execCompletion :: String -> IO String }
326
327instance Show CompletionResult where
328  showsPrec p _ = showParen (p > 10) $
329    showString "CompletionResult _"
330
331newtype ParserFailure h = ParserFailure
332  { execFailure :: String -> (h, ExitCode, Int) }
333
334instance Show h => Show (ParserFailure h) where
335  showsPrec p (ParserFailure f)
336    = showParen (p > 10)
337    $ showString "ParserFailure"
338    . showsPrec 11 (f "<program>")
339
340instance Functor ParserFailure where
341  fmap f (ParserFailure err) = ParserFailure $ \progn ->
342    let (h, exit, cols) = err progn in (f h, exit, cols)
343
344-- | Result of 'execParserPure'.
345data ParserResult a
346  = Success a
347  | Failure (ParserFailure ParserHelp)
348  | CompletionInvoked CompletionResult
349  deriving Show
350
351instance Functor ParserResult where
352  fmap f (Success a) = Success (f a)
353  fmap _ (Failure f) = Failure f
354  fmap _ (CompletionInvoked c) = CompletionInvoked c
355
356overFailure :: (ParserHelp -> ParserHelp)
357            -> ParserResult a -> ParserResult a
358overFailure f (Failure failure) = Failure $ fmap f failure
359overFailure _ r = r
360
361instance Applicative ParserResult where
362  pure = Success
363  Success f <*> r = fmap f r
364  Failure f <*> _ = Failure f
365  CompletionInvoked c <*> _ = CompletionInvoked c
366
367instance Monad ParserResult where
368  return = pure
369  Success x >>= f = f x
370  Failure f >>= _ = Failure f
371  CompletionInvoked c >>= _ = CompletionInvoked c
372
373type Args = [String]
374
375-- | Policy for how to handle options within the parse
376data ArgPolicy
377  = Intersperse
378  -- ^ The default policy, options and arguments can
379  --   be interspersed.
380  --   A `--` option can be passed to ensure all following
381  --   commands are treated as arguments.
382  | NoIntersperse
383  -- ^ Options must all come before arguments, once a
384  --   single positional argument or subcommand is parsed,
385  --   all remaining arguments are treated as positionals.
386  --   A `--` option can be passed if the first positional
387  --   one needs starts with `-`.
388  | AllPositionals
389  -- ^ No options are parsed at all, all arguments are
390  --   treated as positionals.
391  --   Is the policy used after `--` is encountered.
392  | ForwardOptions
393  -- ^ Options and arguments can be interspersed, but if
394  --   a given option is not found, it is treated as a
395  --   positional argument. This is sometimes useful if
396  --   one is passing through most options to another tool,
397  --   but are supplying just a few of their own options.
398  deriving (Eq, Ord, Show)
399
400newtype ArgumentReachability = ArgumentReachability
401  { argumentIsUnreachable :: Bool -- ^ If the result is a positional, if it can't be
402                                  --    accessed in the current parser position ( first arg )
403  } deriving (Eq, Show)
404
405-- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed
406-- with brackets around it.
407data AltNodeType = MarkDefault | NoDefault
408  deriving (Show, Eq)
409
410data OptTree a
411  = Leaf a
412  | MultNode [OptTree a]
413  | AltNode AltNodeType [OptTree a]
414  | BindNode (OptTree a)
415  deriving Show
416
417filterOptional :: OptTree a -> OptTree a
418filterOptional t = case t of
419  Leaf a
420    -> Leaf a
421  MultNode xs
422    -> MultNode (map filterOptional xs)
423  AltNode MarkDefault _
424    -> AltNode MarkDefault []
425  AltNode NoDefault xs
426    -> AltNode NoDefault (map filterOptional xs)
427  BindNode xs
428    -> BindNode (filterOptional xs)
429
430optVisibility :: Option a -> OptVisibility
431optVisibility = propVisibility . optProps
432
433optHelp :: Option a -> Chunk Doc
434optHelp  = propHelp . optProps
435
436optMetaVar :: Option a -> String
437optMetaVar = propMetaVar . optProps
438
439optShowDefault :: Option a -> Maybe String
440optShowDefault = propShowDefault . optProps
441
442optDescMod :: Option a -> Maybe ( Doc -> Doc )
443optDescMod = propDescMod . optProps
444