never executed always true always false
1
2 {-# LANGUAGE DeriveFunctor #-}
3
4 -------------------------------------------------------------------------------
5 --
6 -- | Command-line parser
7 --
8 -- This is an abstract command-line parser used by DynFlags.
9 --
10 -- (c) The University of Glasgow 2005
11 --
12 -------------------------------------------------------------------------------
13
14 module GHC.Driver.CmdLine
15 (
16 processArgs, OptKind(..), GhcFlagMode(..),
17 CmdLineP(..), getCmdLineState, putCmdLineState,
18 Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
19 errorsToGhcException,
20
21 Err(..), Warn(..), WarnReason(..),
22
23 EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM
24 ) where
25
26 import GHC.Prelude
27
28 import GHC.Utils.Misc
29 import GHC.Utils.Outputable
30 import GHC.Utils.Panic
31 import GHC.Utils.Panic.Plain
32 import GHC.Data.Bag
33 import GHC.Types.SrcLoc
34 import GHC.Utils.Json
35
36 import GHC.Types.Error ( DiagnosticReason(..) )
37
38 import Data.Function
39 import Data.List (sortBy, intercalate, stripPrefix)
40
41 import Control.Monad (liftM, ap)
42
43 --------------------------------------------------------
44 -- The Flag and OptKind types
45 --------------------------------------------------------
46
47 data Flag m = Flag
48 { flagName :: String, -- Flag, without the leading "-"
49 flagOptKind :: OptKind m, -- What to do if we see it
50 flagGhcMode :: GhcFlagMode -- Which modes this flag affects
51 }
52
53 defFlag :: String -> OptKind m -> Flag m
54 defFlag name optKind = Flag name optKind AllModes
55
56 defGhcFlag :: String -> OptKind m -> Flag m
57 defGhcFlag name optKind = Flag name optKind OnlyGhc
58
59 defGhciFlag :: String -> OptKind m -> Flag m
60 defGhciFlag name optKind = Flag name optKind OnlyGhci
61
62 defHiddenFlag :: String -> OptKind m -> Flag m
63 defHiddenFlag name optKind = Flag name optKind HiddenFlag
64
65 -- | GHC flag modes describing when a flag has an effect.
66 data GhcFlagMode
67 = OnlyGhc -- ^ The flag only affects the non-interactive GHC
68 | OnlyGhci -- ^ The flag only affects the interactive GHC
69 | AllModes -- ^ The flag affects multiple ghc modes
70 | HiddenFlag -- ^ This flag should not be seen in cli completion
71
72 data OptKind m -- Suppose the flag is -f
73 = NoArg (EwM m ()) -- -f all by itself
74 | HasArg (String -> EwM m ()) -- -farg or -f arg
75 | SepArg (String -> EwM m ()) -- -f arg
76 | Prefix (String -> EwM m ()) -- -farg
77 | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
78 | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
79 | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
80 | WordSuffix (Word -> EwM m ()) -- -f or -f=n; pass n to fn
81 | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn
82 | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
83 | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
84
85
86 --------------------------------------------------------
87 -- The EwM monad
88 --------------------------------------------------------
89
90 -- | Used when filtering warnings: if a reason is given
91 -- it can be filtered out when displaying.
92 data WarnReason
93 = NoReason
94 | ReasonDeprecatedFlag
95 | ReasonUnrecognisedFlag
96 deriving (Eq, Show)
97
98 instance Outputable WarnReason where
99 ppr = text . show
100
101 instance ToJson WarnReason where
102 json NoReason = JSNull
103 json reason = JSString $ show reason
104
105 -- | A command-line error message
106 newtype Err = Err { errMsg :: Located String }
107
108 -- | A command-line warning message and the reason it arose
109 data Warn = Warn
110 { warnReason :: DiagnosticReason,
111 warnMsg :: Located String
112 }
113
114 type Errs = Bag Err
115 type Warns = Bag Warn
116
117 -- EwM ("errors and warnings monad") is a monad
118 -- transformer for m that adds an (err, warn) state
119 newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
120 -> Errs -> Warns
121 -> m (Errs, Warns, a) }
122
123 instance Monad m => Functor (EwM m) where
124 fmap = liftM
125
126 instance Monad m => Applicative (EwM m) where
127 pure v = EwM (\_ e w -> return (e, w, v))
128 (<*>) = ap
129
130 instance Monad m => Monad (EwM m) where
131 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
132 unEwM (k r) l e' w')
133
134 runEwM :: EwM m a -> m (Errs, Warns, a)
135 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
136
137 setArg :: Located String -> EwM m () -> EwM m ()
138 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
139
140 addErr :: Monad m => String -> EwM m ()
141 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
142
143 addWarn :: Monad m => String -> EwM m ()
144 addWarn = addFlagWarn WarningWithoutFlag
145
146 addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m ()
147 addFlagWarn reason msg = EwM $
148 (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
149
150 getArg :: Monad m => EwM m String
151 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
152
153 getCurLoc :: Monad m => EwM m SrcSpan
154 getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
155
156 liftEwM :: Monad m => m a -> EwM m a
157 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
158
159
160 --------------------------------------------------------
161 -- A state monad for use in the command-line parser
162 --------------------------------------------------------
163
164 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
165 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
166 deriving (Functor)
167
168 instance Applicative (CmdLineP s) where
169 pure a = CmdLineP $ \s -> (a, s)
170 (<*>) = ap
171
172 instance Monad (CmdLineP s) where
173 m >>= k = CmdLineP $ \s ->
174 let (a, s') = runCmdLine m s
175 in runCmdLine (k a) s'
176
177
178 getCmdLineState :: CmdLineP s s
179 getCmdLineState = CmdLineP $ \s -> (s,s)
180 putCmdLineState :: s -> CmdLineP s ()
181 putCmdLineState s = CmdLineP $ \_ -> ((),s)
182
183
184 --------------------------------------------------------
185 -- Processing arguments
186 --------------------------------------------------------
187
188 processArgs :: Monad m
189 => [Flag m] -- cmdline parser spec
190 -> [Located String] -- args
191 -> m ( [Located String], -- spare args
192 [Err], -- errors
193 [Warn] ) -- warnings
194 processArgs spec args = do
195 (errs, warns, spare) <- runEwM action
196 return (spare, bagToList errs, bagToList warns)
197 where
198 action = process args []
199
200 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
201 process [] spare = return (reverse spare)
202
203 process (locArg@(L _ ('-' : arg)) : args) spare =
204 case findArg spec arg of
205 Just (rest, opt_kind) ->
206 case processOneArg opt_kind rest arg args of
207 Left err ->
208 let b = process args spare
209 in (setArg locArg $ addErr err) >> b
210
211 Right (action,rest) ->
212 let b = process rest spare
213 in (setArg locArg $ action) >> b
214
215 Nothing -> process args (locArg : spare)
216
217 process (arg : args) spare = process args (arg : spare)
218
219
220 processOneArg :: OptKind m -> String -> String -> [Located String]
221 -> Either String (EwM m (), [Located String])
222 processOneArg opt_kind rest arg args
223 = let dash_arg = '-' : arg
224 rest_no_eq = dropEq rest
225 in case opt_kind of
226 NoArg a -> assert (null rest) Right (a, args)
227
228 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
229 | otherwise -> case args of
230 [] -> missingArgErr dash_arg
231 (L _ arg1:args1) -> Right (f arg1, args1)
232
233 -- See #9776
234 SepArg f -> case args of
235 [] -> missingArgErr dash_arg
236 (L _ arg1:args1) -> Right (f arg1, args1)
237
238 -- See #12625
239 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
240 | otherwise -> missingArgErr dash_arg
241
242 PassFlag f | notNull rest -> unknownFlagErr dash_arg
243 | otherwise -> Right (f dash_arg, args)
244
245 OptIntSuffix f | null rest -> Right (f Nothing, args)
246 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
247 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
248
249 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
250 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
251
252 WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)
253 | otherwise -> Left ("malformed natural argument in " ++ dash_arg)
254
255 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
256 | otherwise -> Left ("malformed float argument in " ++ dash_arg)
257
258 OptPrefix f -> Right (f rest_no_eq, args)
259 AnySuffix f -> Right (f dash_arg, args)
260
261 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
262 findArg spec arg =
263 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
264 [ (removeSpaces rest, optKind)
265 | flag <- spec,
266 let optKind = flagOptKind flag,
267 Just rest <- [stripPrefix (flagName flag) arg],
268 arg_ok optKind rest arg ]
269 of
270 [] -> Nothing
271 (one:_) -> Just one
272
273 arg_ok :: OptKind t -> [Char] -> String -> Bool
274 arg_ok (NoArg _) rest _ = null rest
275 arg_ok (HasArg _) _ _ = True
276 arg_ok (SepArg _) rest _ = null rest
277 arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t
278 -- to improve error message (#12625)
279 arg_ok (OptIntSuffix _) _ _ = True
280 arg_ok (IntSuffix _) _ _ = True
281 arg_ok (WordSuffix _) _ _ = True
282 arg_ok (FloatSuffix _) _ _ = True
283 arg_ok (OptPrefix _) _ _ = True
284 arg_ok (PassFlag _) rest _ = null rest
285 arg_ok (AnySuffix _) _ _ = True
286
287 -- | Parse an Int
288 --
289 -- Looks for "433" or "=342", with no trailing gubbins
290 -- * n or =n => Just n
291 -- * gibberish => Nothing
292 parseInt :: String -> Maybe Int
293 parseInt s = case reads s of
294 ((n,""):_) -> Just n
295 _ -> Nothing
296
297 parseWord :: String -> Maybe Word
298 parseWord 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 -}