1 -----------------------------------------------------------------------------
5 -- This is an abstract command-line parser used by both StaticFlags and
8 -- (c) The University of Glasgow 2005
10 -----------------------------------------------------------------------------
12 module CmdLineParser (
13 processArgs, OptKind(..),
14 CmdLineP(..), getCmdLineState, putCmdLineState,
18 EwM, addErr, addWarn, getArg, liftEwM, deprecate
21 #include "HsVersions.h"
31 --------------------------------------------------------
32 -- The Flag and OptKind types
33 --------------------------------------------------------
36 { flagName :: String, -- Flag, without the leading "-"
37 flagOptKind :: OptKind m -- What to do if we see it
40 -------------------------------
41 data OptKind m -- Suppose the flag is -f
42 = NoArg (EwM m ()) -- -f all by itself
43 | HasArg (String -> EwM m ()) -- -farg or -f arg
44 | SepArg (String -> EwM m ()) -- -f arg
45 | Prefix (String -> EwM m ()) -- -farg
46 | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
47 | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
48 | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
49 | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
50 | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
51 | PrefixPred (String -> Bool) (String -> EwM m ())
52 | AnySuffixPred (String -> Bool) (String -> EwM m ())
55 --------------------------------------------------------
57 --------------------------------------------------------
59 type Err = Located String
60 type Warn = Located String
64 -- EwM (short for "errors and warnings monad") is a
65 -- monad transformer for m that adds an (err, warn) state
66 newtype EwM m a = EwM { unEwM :: Located String -- Current arg
68 -> m (Errs, Warns, a) }
70 instance Monad m => Monad (EwM m) where
71 (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w
72 ; unEwM (k r) l e' w' })
73 return v = EwM (\_ e w -> return (e, w, v))
75 setArg :: Located String -> EwM m a -> EwM m a
76 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
78 addErr :: Monad m => String -> EwM m ()
79 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
81 addWarn :: Monad m => String -> EwM m ()
82 addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
84 w = "Warning: " ++ msg
86 deprecate :: Monad m => String -> EwM m ()
89 ; addWarn (arg ++ " is deprecated: " ++ s) }
91 getArg :: Monad m => EwM m String
92 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
94 liftEwM :: Monad m => m a -> EwM m a
95 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
97 -- -----------------------------------------------------------------------------
98 -- A state monad for use in the command-line parser
99 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
101 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
103 instance Monad (CmdLineP s) where
104 return a = CmdLineP $ \s -> (a, s)
105 m >>= k = CmdLineP $ \s -> let
106 (a, s') = runCmdLine m s
107 in runCmdLine (k a) s'
109 getCmdLineState :: CmdLineP s s
110 getCmdLineState = CmdLineP $ \s -> (s,s)
111 putCmdLineState :: s -> CmdLineP s ()
112 putCmdLineState s = CmdLineP $ \_ -> ((),s)
115 --------------------------------------------------------
116 -- Processing arguments
117 --------------------------------------------------------
119 processArgs :: Monad m
120 => [Flag m] -- cmdline parser spec
121 -> [Located String] -- args
123 [Located String], -- spare args
124 [Located String], -- errors
125 [Located String] -- warnings
127 processArgs spec args
128 = do { (errs, warns, spare) <- unEwM (process args [])
129 (panic "processArgs: no arg yet")
131 ; return (spare, bagToList errs, bagToList warns) }
133 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
134 process [] spare = return (reverse spare)
136 process (locArg@(L _ ('-' : arg)) : args) spare =
137 case findArg spec arg of
138 Just (rest, opt_kind) ->
139 case processOneArg opt_kind rest arg args of
140 Left err -> do { setArg locArg $ addErr err
141 ; process args spare }
142 Right (action,rest) -> do { setArg locArg $ action
143 ; process rest spare }
144 Nothing -> process args (locArg : spare)
146 process (arg : args) spare = process args (arg : spare)
149 processOneArg :: OptKind m -> String -> String -> [Located String]
150 -> Either String (EwM m (), [Located String])
151 processOneArg opt_kind rest arg args
152 = let dash_arg = '-' : arg
153 rest_no_eq = dropEq rest
155 NoArg a -> ASSERT(null rest) Right (a, args)
157 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
158 | otherwise -> case args of
159 [] -> missingArgErr dash_arg
160 (L _ arg1:args1) -> Right (f arg1, args1)
162 SepArg f -> case args of
163 [] -> unknownFlagErr dash_arg
164 (L _ arg1:args1) -> Right (f arg1, args1)
166 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
167 | otherwise -> unknownFlagErr dash_arg
169 PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
170 | otherwise -> unknownFlagErr dash_arg
172 PassFlag f | notNull rest -> unknownFlagErr dash_arg
173 | otherwise -> Right (f dash_arg, args)
175 OptIntSuffix f | null rest -> Right (f Nothing, args)
176 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
177 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
179 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
180 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
182 OptPrefix f -> Right (f rest_no_eq, args)
183 AnySuffix f -> Right (f dash_arg, args)
184 AnySuffixPred _ f -> Right (f dash_arg, args)
187 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
189 = case [ (removeSpaces rest, optKind)
191 let optKind = flagOptKind flag,
192 Just rest <- [stripPrefix (flagName flag) arg],
193 arg_ok optKind rest arg ]
198 arg_ok :: OptKind t -> [Char] -> String -> Bool
199 arg_ok (NoArg _) rest _ = null rest
200 arg_ok (HasArg _) _ _ = True
201 arg_ok (SepArg _) rest _ = null rest
202 arg_ok (Prefix _) rest _ = notNull rest
203 arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
204 arg_ok (OptIntSuffix _) _ _ = True
205 arg_ok (IntSuffix _) _ _ = True
206 arg_ok (OptPrefix _) _ _ = True
207 arg_ok (PassFlag _) rest _ = null rest
208 arg_ok (AnySuffix _) _ _ = True
209 arg_ok (AnySuffixPred p _) _ arg = p arg
211 parseInt :: String -> Maybe Int
212 -- Looks for "433" or "=342", with no trailing gubbins
214 -- gibberish => Nothing
215 parseInt s = case reads s of
219 dropEq :: String -> String
220 -- Discards a leading equals sign
224 unknownFlagErr :: String -> Either String a
225 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
227 missingArgErr :: String -> Either String a
228 missingArgErr f = Left ("missing argument for flag: " ++ f)
230 -- ---------------------------------------------------------------------
233 errorsToGhcException :: [Located String] -> GhcException
234 errorsToGhcException errs =
235 let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
236 in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)