Make -w less aggressive (Trac #12056)
[ghc.git] / compiler / main / CmdLineParser.hs
1 {-# LANGUAGE CPP #-}
2
3 -------------------------------------------------------------------------------
4 --
5 -- | Command-line parser
6 --
7 -- This is an abstract command-line parser used by DynFlags.
8 --
9 -- (c) The University of Glasgow 2005
10 --
11 -------------------------------------------------------------------------------
12
13 module CmdLineParser
14 (
15 processArgs, OptKind(..), GhcFlagMode(..),
16 CmdLineP(..), getCmdLineState, putCmdLineState,
17 Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
18 errorsToGhcException,
19
20 Err(..), Warn(..), WarnReason(..),
21
22 EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,
23 deprecate
24 ) where
25
26 #include "HsVersions.h"
27
28 import Util
29 import Outputable
30 import Panic
31 import Bag
32 import SrcLoc
33 import Json
34
35 import Data.Function
36 import Data.List
37
38 import Control.Monad (liftM, ap)
39
40 --------------------------------------------------------
41 -- The Flag and OptKind types
42 --------------------------------------------------------
43
44 data Flag m = Flag
45 { flagName :: String, -- Flag, without the leading "-"
46 flagOptKind :: OptKind m, -- What to do if we see it
47 flagGhcMode :: GhcFlagMode -- Which modes this flag affects
48 }
49
50 defFlag :: String -> OptKind m -> Flag m
51 defFlag name optKind = Flag name optKind AllModes
52
53 defGhcFlag :: String -> OptKind m -> Flag m
54 defGhcFlag name optKind = Flag name optKind OnlyGhc
55
56 defGhciFlag :: String -> OptKind m -> Flag m
57 defGhciFlag name optKind = Flag name optKind OnlyGhci
58
59 defHiddenFlag :: String -> OptKind m -> Flag m
60 defHiddenFlag name optKind = Flag name optKind HiddenFlag
61
62 -- | GHC flag modes describing when a flag has an effect.
63 data GhcFlagMode
64 = OnlyGhc -- ^ The flag only affects the non-interactive GHC
65 | OnlyGhci -- ^ The flag only affects the interactive GHC
66 | AllModes -- ^ The flag affects multiple ghc modes
67 | HiddenFlag -- ^ This flag should not be seen in cli completion
68
69 data OptKind m -- Suppose the flag is -f
70 = NoArg (EwM m ()) -- -f all by itself
71 | HasArg (String -> EwM m ()) -- -farg or -f arg
72 | SepArg (String -> EwM m ()) -- -f arg
73 | Prefix (String -> EwM m ()) -- -farg
74 | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
75 | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
76 | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
77 | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn
78 | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
79 | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
80 | PrefixPred (String -> Bool) (String -> EwM m ())
81 | AnySuffixPred (String -> Bool) (String -> EwM m ())
82
83
84 --------------------------------------------------------
85 -- The EwM monad
86 --------------------------------------------------------
87
88 -- | Used when filtering warnings: if a reason is given
89 -- it can be filtered out when displaying.
90 data WarnReason
91 = NoReason
92 | ReasonDeprecatedFlag
93 | ReasonUnrecognisedFlag
94 deriving (Eq, Show)
95
96 instance Outputable WarnReason where
97 ppr = text . show
98
99 instance ToJson WarnReason where
100 json NoReason = JSNull
101 json reason = JSString $ show reason
102
103 -- | A command-line error message
104 newtype Err = Err { errMsg :: Located String }
105
106 -- | A command-line warning message and the reason it arose
107 data Warn = Warn
108 { warnReason :: WarnReason,
109 warnMsg :: Located String
110 }
111
112 type Errs = Bag Err
113 type Warns = Bag Warn
114
115 -- EwM ("errors and warnings monad") is a monad
116 -- transformer for m that adds an (err, warn) state
117 newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
118 -> Errs -> Warns
119 -> m (Errs, Warns, a) }
120
121 instance Monad m => Functor (EwM m) where
122 fmap = liftM
123
124 instance Monad m => Applicative (EwM m) where
125 pure v = EwM (\_ e w -> return (e, w, v))
126 (<*>) = ap
127
128 instance Monad m => Monad (EwM m) where
129 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
130 unEwM (k r) l e' w')
131
132 runEwM :: EwM m a -> m (Errs, Warns, a)
133 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
134
135 setArg :: Located String -> EwM m () -> EwM m ()
136 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
137
138 addErr :: Monad m => String -> EwM m ()
139 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
140
141 addWarn :: Monad m => String -> EwM m ()
142 addWarn = addFlagWarn NoReason
143
144 addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
145 addFlagWarn reason msg = EwM $
146 (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
147
148 deprecate :: Monad m => String -> EwM m ()
149 deprecate s = do
150 arg <- getArg
151 addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
152
153 getArg :: Monad m => EwM m String
154 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
155
156 getCurLoc :: Monad m => EwM m SrcSpan
157 getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
158
159 liftEwM :: Monad m => m a -> EwM m a
160 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
161
162
163 --------------------------------------------------------
164 -- A state monad for use in the command-line parser
165 --------------------------------------------------------
166
167 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
168 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
169
170 instance Functor (CmdLineP s) where
171 fmap = liftM
172
173 instance Applicative (CmdLineP s) where
174 pure a = CmdLineP $ \s -> (a, s)
175 (<*>) = ap
176
177 instance Monad (CmdLineP s) where
178 m >>= k = CmdLineP $ \s ->
179 let (a, s') = runCmdLine m s
180 in runCmdLine (k a) s'
181
182
183 getCmdLineState :: CmdLineP s s
184 getCmdLineState = CmdLineP $ \s -> (s,s)
185 putCmdLineState :: s -> CmdLineP s ()
186 putCmdLineState s = CmdLineP $ \_ -> ((),s)
187
188
189 --------------------------------------------------------
190 -- Processing arguments
191 --------------------------------------------------------
192
193 processArgs :: Monad m
194 => [Flag m] -- cmdline parser spec
195 -> [Located String] -- args
196 -> m ( [Located String], -- spare args
197 [Err], -- errors
198 [Warn] ) -- warnings
199 processArgs spec args = do
200 (errs, warns, spare) <- runEwM action
201 return (spare, bagToList errs, bagToList warns)
202 where
203 action = process args []
204
205 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
206 process [] spare = return (reverse spare)
207
208 process (locArg@(L _ ('-' : arg)) : args) spare =
209 case findArg spec arg of
210 Just (rest, opt_kind) ->
211 case processOneArg opt_kind rest arg args of
212 Left err ->
213 let b = process args spare
214 in (setArg locArg $ addErr err) >> b
215
216 Right (action,rest) ->
217 let b = process rest spare
218 in (setArg locArg $ action) >> b
219
220 Nothing -> process args (locArg : spare)
221
222 process (arg : args) spare = process args (arg : spare)
223
224
225 processOneArg :: OptKind m -> String -> String -> [Located String]
226 -> Either String (EwM m (), [Located String])
227 processOneArg opt_kind rest arg args
228 = let dash_arg = '-' : arg
229 rest_no_eq = dropEq rest
230 in case opt_kind of
231 NoArg a -> ASSERT(null rest) Right (a, args)
232
233 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
234 | otherwise -> case args of
235 [] -> missingArgErr dash_arg
236 (L _ arg1:args1) -> Right (f arg1, args1)
237
238 -- See Trac #9776
239 SepArg f -> case args of
240 [] -> missingArgErr dash_arg
241 (L _ arg1:args1) -> Right (f arg1, args1)
242
243 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
244 | otherwise -> unknownFlagErr dash_arg
245
246 PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
247 | otherwise -> unknownFlagErr dash_arg
248
249 PassFlag f | notNull rest -> unknownFlagErr dash_arg
250 | otherwise -> Right (f dash_arg, args)
251
252 OptIntSuffix f | null rest -> Right (f Nothing, args)
253 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
254 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
255
256 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
257 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
258
259 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
260 | otherwise -> Left ("malformed float argument in " ++ dash_arg)
261
262 OptPrefix f -> Right (f rest_no_eq, args)
263 AnySuffix f -> Right (f dash_arg, args)
264 AnySuffixPred _ f -> Right (f dash_arg, args)
265
266 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
267 findArg spec arg =
268 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
269 [ (removeSpaces rest, optKind)
270 | flag <- spec,
271 let optKind = flagOptKind flag,
272 Just rest <- [stripPrefix (flagName flag) arg],
273 arg_ok optKind rest arg ]
274 of
275 [] -> Nothing
276 (one:_) -> Just one
277
278 arg_ok :: OptKind t -> [Char] -> String -> Bool
279 arg_ok (NoArg _) rest _ = null rest
280 arg_ok (HasArg _) _ _ = True
281 arg_ok (SepArg _) rest _ = null rest
282 arg_ok (Prefix _) rest _ = notNull rest
283 arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
284 arg_ok (OptIntSuffix _) _ _ = True
285 arg_ok (IntSuffix _) _ _ = True
286 arg_ok (FloatSuffix _) _ _ = True
287 arg_ok (OptPrefix _) _ _ = True
288 arg_ok (PassFlag _) rest _ = null rest
289 arg_ok (AnySuffix _) _ _ = True
290 arg_ok (AnySuffixPred p _) _ arg = p arg
291
292 -- | Parse an Int
293 --
294 -- Looks for "433" or "=342", with no trailing gubbins
295 -- * n or =n => Just n
296 -- * gibberish => Nothing
297 parseInt :: String -> Maybe Int
298 parseInt s = case reads s of
299 ((n,""):_) -> Just n
300 _ -> Nothing
301
302 parseFloat :: String -> Maybe Float
303 parseFloat s = case reads s of
304 ((n,""):_) -> Just n
305 _ -> Nothing
306
307 -- | Discards a leading equals sign
308 dropEq :: String -> String
309 dropEq ('=' : s) = s
310 dropEq s = s
311
312 unknownFlagErr :: String -> Either String a
313 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
314
315 missingArgErr :: String -> Either String a
316 missingArgErr f = Left ("missing argument for flag: " ++ f)
317
318 --------------------------------------------------------
319 -- Utils
320 --------------------------------------------------------
321
322
323 -- See Note [Handling errors when parsing flags]
324 errorsToGhcException :: [(String, -- Location
325 String)] -- Error
326 -> GhcException
327 errorsToGhcException errs =
328 UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
329
330 {- Note [Handling errors when parsing commandline flags]
331
332 Parsing of static and mode flags happens before any session is started, i.e.,
333 before the first call to 'GHC.withGhc'. Therefore, to report errors for
334 invalid usage of these two types of flags, we can not call any function that
335 needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
336 is not set either). So we always print "on the commandline" as the location,
337 which is true except for Api users, which is probably ok.
338
339 When reporting errors for invalid usage of dynamic flags we /can/ make use of
340 DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
341
342 Before, we called unsafeGlobalDynFlags when an invalid (combination of)
343 flag(s) was given on the commandline, resulting in panics (#9963).
344 -}