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
|
-----------------------------------------------------------------------------
--
-- Command-line parser
--
-- This is an abstract command-line parser used by both StaticFlags and
-- DynFlags.
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------
module CmdLineParser (
processArgs, OptKind(..),
CmdLineP(..), getCmdLineState, putCmdLineState
) where
#include "HsVersions.h"
import Util ( maybePrefixMatch, notNull, removeSpaces )
#ifdef DEBUG
import Panic ( assertPanic )
#endif
data OptKind m
= NoArg (m ()) -- flag with no argument
| HasArg (String -> m ()) -- flag has an argument (maybe prefix)
| SepArg (String -> m ()) -- flag has a separate argument
| Prefix (String -> m ()) -- flag is a prefix only
| OptPrefix (String -> m ()) -- flag may be a prefix
| AnySuffix (String -> m ()) -- flag is a prefix, pass whole arg to fn
| PassFlag (String -> m ()) -- flag with no arg, pass flag to fn
| PrefixPred (String -> Bool) (String -> m ())
| AnySuffixPred (String -> Bool) (String -> m ())
processArgs :: Monad m
=> [(String, OptKind m)] -- cmdline parser spec
-> [String] -- args
-> m (
[String], -- spare args
[String] -- errors
)
processArgs spec args = process spec args [] []
where
process _spec [] spare errs =
return (reverse spare, reverse errs)
process spec args@(('-':arg):args') spare errs =
case findArg spec arg of
Just (rest,action) ->
case processOneArg action rest args of
Left err -> process spec args' spare (err:errs)
Right (action,rest) -> do
action >> process spec rest spare errs
Nothing ->
process spec args' (('-':arg):spare) errs
process spec (arg:args) spare errs =
process spec args (arg:spare) errs
processOneArg :: OptKind m -> String -> [String]
-> Either String (m (), [String])
processOneArg action rest (dash_arg@('-':arg):args) =
case action of
NoArg a -> ASSERT(null rest) Right (a, args)
HasArg f ->
if rest /= ""
then Right (f rest, args)
else case args of
[] -> missingArgErr dash_arg
(arg1:args1) -> Right (f arg1, args1)
SepArg f ->
case args of
[] -> unknownFlagErr dash_arg
(arg1:args1) -> Right (f arg1, args1)
Prefix f ->
if rest /= ""
then Right (f rest, args)
else unknownFlagErr dash_arg
PrefixPred p f ->
if rest /= ""
then Right (f rest, args)
else unknownFlagErr dash_arg
OptPrefix f -> Right (f rest, args)
AnySuffix f -> Right (f dash_arg, args)
AnySuffixPred p f -> Right (f dash_arg, args)
PassFlag f ->
if rest /= ""
then unknownFlagErr dash_arg
else Right (f dash_arg, args)
findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
findArg spec arg
= case [ (removeSpaces rest, k)
| (pat,k) <- spec,
Just rest <- [maybePrefixMatch pat arg],
arg_ok k rest arg ]
of
[] -> Nothing
(one:_) -> Just one
arg_ok (NoArg _) rest arg = null rest
arg_ok (HasArg _) rest arg = True
arg_ok (SepArg _) rest arg = null rest
arg_ok (Prefix _) rest arg = notNull rest
arg_ok (PrefixPred p _) rest arg = notNull rest && p rest
arg_ok (OptPrefix _) rest arg = True
arg_ok (PassFlag _) rest arg = null rest
arg_ok (AnySuffix _) rest arg = True
arg_ok (AnySuffixPred p _) rest arg = p arg
unknownFlagErr :: String -> Either String a
unknownFlagErr f = Left ("unrecognised flag: " ++ f)
missingArgErr :: String -> Either String a
missingArgErr f = Left ("missing argument for flag: " ++ f)
-- -----------------------------------------------------------------------------
-- A state monad for use in the command-line parser
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
instance Monad (CmdLineP s) where
return a = CmdLineP $ \s -> (a, s)
m >>= k = CmdLineP $ \s -> let
(a, s') = runCmdLine m s
in runCmdLine (k a) s'
getCmdLineState = CmdLineP $ \s -> (s,s)
putCmdLineState s = CmdLineP $ \_ -> ((),s)
|
