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  OptHelpInfo(..),
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
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  } deriving (Eq, Show)
127
128data OptName = OptShort !Char
129             | OptLong !String
130  deriving (Eq, Ord, Show)
131
132isShortName :: OptName -> Bool
133isShortName (OptShort _) = True
134isShortName (OptLong _)  = False
135
136isLongName :: OptName -> Bool
137isLongName = not . isShortName
138
139-- | Visibility of an option in the help text.
140data OptVisibility
141  = Internal          -- ^ does not appear in the help text at all
142  | Hidden            -- ^ only visible in the full description
143  | Visible           -- ^ visible both in the full and brief descriptions
144  deriving (Eq, Ord, Show)
145
146-- | Specification for an individual parser option.
147data OptProperties = OptProperties
148  { propVisibility :: OptVisibility       -- ^ whether this flag is shown in the brief description
149  , propHelp :: Chunk Doc                 -- ^ help text for this option
150  , propMetaVar :: String                 -- ^ metavariable for this option
151  , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default
152  , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description
153  }
154
155instance Show OptProperties where
156  showsPrec p (OptProperties pV pH pMV pSD _)
157    = showParen (p >= 11)
158    $ showString "OptProperties { propVisibility = " . shows pV
159    . showString ", propHelp = " . shows pH
160    . showString ", propMetaVar = " . shows pMV
161    . showString ", propShowDefault = " . shows pSD
162    . showString ", propDescMod = _ }"
163
164-- | A single option of a parser.
165data Option a = Option
166  { optMain :: OptReader a               -- ^ reader for this option
167  , optProps :: OptProperties            -- ^ properties of this option
168  }
169
170data SomeParser = forall a . SomeParser (Parser a)
171
172-- | Subparser context, containing the 'name' of the subparser, and its parser info.
173--   Used by parserFailure to display relevant usage information when parsing inside a subparser fails.
174data Context = forall a . Context String (ParserInfo a)
175
176instance Show (Option a) where
177    show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"
178
179instance Functor Option where
180  fmap f (Option m p) = Option (fmap f m) p
181
182-- | A newtype over 'ReaderT String Except', used by option readers.
183newtype ReadM a = ReadM
184  { unReadM :: ReaderT String (Except ParseError) a }
185
186instance Functor ReadM where
187  fmap f (ReadM r) = ReadM (fmap f r)
188
189instance Applicative ReadM where
190  pure = ReadM . pure
191  ReadM x <*> ReadM y = ReadM $ x <*> y
192
193instance Alternative ReadM where
194  empty = mzero
195  (<|>) = mplus
196
197instance Monad ReadM where
198  return = pure
199  ReadM r >>= f = ReadM $ r >>= unReadM . f
200
201#if !(MIN_VERSION_base(4,13,0))
202  fail = Fail.fail
203#endif
204
205instance Fail.MonadFail ReadM where
206  fail = readerError
207
208instance MonadPlus ReadM where
209  mzero = ReadM mzero
210  mplus (ReadM x) (ReadM y) = ReadM $ mplus x y
211
212-- | Return the value being read.
213readerAsk :: ReadM String
214readerAsk = ReadM ask
215
216-- | Abort option reader by exiting with a 'ParseError'.
217readerAbort :: ParseError -> ReadM a
218readerAbort = ReadM . lift . throwE
219
220-- | Abort option reader by exiting with an error message.
221readerError :: String -> ReadM a
222readerError = readerAbort . ErrorMsg
223
224data CReader a = CReader
225  { crCompleter :: Completer
226  , crReader :: ReadM a }
227
228instance Functor CReader where
229  fmap f (CReader c r) = CReader c (fmap f r)
230
231-- | An 'OptReader' defines whether an option matches an command line argument.
232data OptReader a
233  = OptReader [OptName] (CReader a) (String -> ParseError)
234  -- ^ option reader
235  | FlagReader [OptName] !a
236  -- ^ flag reader
237  | ArgReader (CReader a)
238  -- ^ argument reader
239  | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))
240  -- ^ command reader
241
242instance Functor OptReader where
243  fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
244  fmap f (FlagReader ns x) = FlagReader ns (f x)
245  fmap f (ArgReader cr) = ArgReader (fmap f cr)
246  fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)
247
248-- | A @Parser a@ is an option parser returning a value of type 'a'.
249data Parser a
250  = NilP (Maybe a)
251  | OptP (Option a)
252  | forall x . MultP (Parser (x -> a)) (Parser x)
253  | AltP (Parser a) (Parser a)
254  | forall x . BindP (Parser x) (x -> Parser a)
255
256instance Functor Parser where
257  fmap f (NilP x) = NilP (fmap f x)
258  fmap f (OptP opt) = OptP (fmap f opt)
259  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2
260  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)
261  fmap f (BindP p k) = BindP p (fmap f . k)
262
263instance Applicative Parser where
264  pure = NilP . Just
265  (<*>) = MultP
266
267newtype ParserM r = ParserM
268  { runParserM :: forall x . (r -> Parser x) -> Parser x }
269
270instance Monad ParserM where
271  return = pure
272  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)
273
274instance Functor ParserM where
275  fmap = liftM
276
277instance Applicative ParserM where
278  pure x = ParserM $ \k -> k x
279  (<*>) = ap
280
281fromM :: ParserM a -> Parser a
282fromM (ParserM f) = f pure
283
284oneM :: Parser a -> ParserM a
285oneM p = ParserM (BindP p)
286
287manyM :: Parser a -> ParserM [a]
288manyM p = do
289  mx <- oneM (optional p)
290  case mx of
291    Nothing -> return []
292    Just x -> (x:) <$> manyM p
293
294someM :: Parser a -> ParserM [a]
295someM p = (:) <$> oneM p <*> manyM p
296
297instance Alternative Parser where
298  empty = NilP Nothing
299  (<|>) = AltP
300  many p = fromM $ manyM p
301  some p = fromM $ (:) <$> oneM p <*> manyM p
302
303-- | A shell complete function.
304newtype Completer = Completer
305  { runCompleter :: String -> IO [String] }
306
307-- | Smart constructor for a 'Completer'
308mkCompleter :: (String -> IO [String]) -> Completer
309mkCompleter = Completer
310
311instance Semigroup Completer where
312  (Completer c1) <> (Completer c2) =
313    Completer $ \s -> (++) <$> c1 s <*> c2 s
314
315instance Monoid Completer where
316  mempty = Completer $ \_ -> return []
317  mappend = (<>)
318
319newtype CompletionResult = CompletionResult
320  { execCompletion :: String -> IO String }
321
322instance Show CompletionResult where
323  showsPrec p _ = showParen (p > 10) $
324    showString "CompletionResult _"
325
326newtype ParserFailure h = ParserFailure
327  { execFailure :: String -> (h, ExitCode, Int) }
328
329instance Show h => Show (ParserFailure h) where
330  showsPrec p (ParserFailure f)
331    = showParen (p > 10)
332    $ showString "ParserFailure "
333    . showsPrec 11 (f "<program>")
334
335instance Functor ParserFailure where
336  fmap f (ParserFailure err) = ParserFailure $ \progn ->
337    let (h, exit, cols) = err progn in (f h, exit, cols)
338
339-- | Result of 'execParserPure'.
340data ParserResult a
341  = Success a
342  | Failure (ParserFailure ParserHelp)
343  | CompletionInvoked CompletionResult
344  deriving Show
345
346instance Functor ParserResult where
347  fmap f (Success a) = Success (f a)
348  fmap _ (Failure f) = Failure f
349  fmap _ (CompletionInvoked c) = CompletionInvoked c
350
351overFailure :: (ParserHelp -> ParserHelp)
352            -> ParserResult a -> ParserResult a
353overFailure f (Failure failure) = Failure $ fmap f failure
354overFailure _ r = r
355
356instance Applicative ParserResult where
357  pure = Success
358  Success f <*> r = fmap f r
359  Failure f <*> _ = Failure f
360  CompletionInvoked c <*> _ = CompletionInvoked c
361
362instance Monad ParserResult where
363  return = pure
364  Success x >>= f = f x
365  Failure f >>= _ = Failure f
366  CompletionInvoked c >>= _ = CompletionInvoked c
367
368type Args = [String]
369
370-- | Policy for how to handle options within the parse
371data ArgPolicy
372  = Intersperse
373  -- ^ The default policy, options and arguments can
374  --   be interspersed.
375  --   A `--` option can be passed to ensure all following
376  --   commands are treated as arguments.
377  | NoIntersperse
378  -- ^ Options must all come before arguments, once a
379  --   single positional argument or subcommand is parsed,
380  --   all remaining arguments are treated as positionals.
381  --   A `--` option can be passed if the first positional
382  --   one needs starts with `-`.
383  | AllPositionals
384  -- ^ No options are parsed at all, all arguments are
385  --   treated as positionals.
386  --   Is the policy used after `--` is encountered.
387  | ForwardOptions
388  -- ^ Options and arguments can be interspersed, but if
389  --   a given option is not found, it is treated as a
390  --   positional argument. This is sometimes useful if
391  --   one is passing through most options to another tool,
392  --   but are supplying just a few of their own options.
393  deriving (Eq, Ord, Show)
394
395data OptHelpInfo = OptHelpInfo
396  { hinfoMulti :: Bool           -- ^ Whether this is part of a many or some (approximately)
397  , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be
398                                 --   accessed in the current parser position ( first arg )
399  } deriving (Eq, Show)
400
401-- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed
402-- with brackets around it.
403data AltNodeType = MarkDefault | NoDefault
404  deriving (Show, Eq)
405
406data OptTree a
407  = Leaf a
408  | MultNode [OptTree a]
409  | AltNode AltNodeType [OptTree a]
410  deriving Show
411
412filterOptional :: OptTree a -> OptTree a
413filterOptional t = case t of
414  Leaf a
415    -> Leaf a
416  MultNode xs
417    -> MultNode (map filterOptional xs)
418  AltNode MarkDefault _
419    -> AltNode MarkDefault []
420  AltNode NoDefault xs
421    -> AltNode NoDefault (map filterOptional xs)
422
423optVisibility :: Option a -> OptVisibility
424optVisibility = propVisibility . optProps
425
426optHelp :: Option a -> Chunk Doc
427optHelp  = propHelp . optProps
428
429optMetaVar :: Option a -> String
430optMetaVar = propMetaVar . optProps
431
432optShowDefault :: Option a -> Maybe String
433optShowDefault = propShowDefault . optProps
434
435optDescMod :: Option a -> Maybe ( Doc -> Doc )
436optDescMod = propDescMod . optProps
437