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