driver: use PROGBITS type for .debug-ghc-link-info section
[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 both StaticFlags and
8 -- DynFlags.
9 --
10 -- (c) The University of Glasgow 2005
11 --
12 -------------------------------------------------------------------------------
13
14 module CmdLineParser
15 (
16 processArgs, OptKind(..), GhcFlagMode(..),
17 CmdLineP(..), getCmdLineState, putCmdLineState,
18 Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
19 errorsToGhcException,
20
21 EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
22 ) where
23
24 #include "HsVersions.h"
25
26 import Util
27 import Outputable
28 import Panic
29 import Bag
30 import SrcLoc
31
32 import Data.Function
33 import Data.List
34
35 import Control.Monad (liftM, ap)
36 #if __GLASGOW_HASKELL__ < 709
37 import Control.Applicative (Applicative(..))
38 #endif
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 type Err = Located String
89 type Warn = Located String
90 type Errs = Bag Err
91 type Warns = Bag Warn
92
93 -- EwM ("errors and warnings monad") is a monad
94 -- transformer for m that adds an (err, warn) state
95 newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
96 -> Errs -> Warns
97 -> m (Errs, Warns, a) }
98
99 instance Monad m => Functor (EwM m) where
100 fmap = liftM
101
102 instance Monad m => Applicative (EwM m) where
103 pure v = EwM (\_ e w -> return (e, w, v))
104 (<*>) = ap
105
106 instance Monad m => Monad (EwM m) where
107 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
108 unEwM (k r) l e' w')
109 return = pure
110
111 runEwM :: EwM m a -> m (Errs, Warns, a)
112 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
113
114 setArg :: Located String -> EwM m () -> EwM m ()
115 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
116
117 addErr :: Monad m => String -> EwM m ()
118 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
119
120 addWarn :: Monad m => String -> EwM m ()
121 addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ()))
122
123 deprecate :: Monad m => String -> EwM m ()
124 deprecate s = do
125 arg <- getArg
126 addWarn (arg ++ " is deprecated: " ++ s)
127
128 getArg :: Monad m => EwM m String
129 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
130
131 getCurLoc :: Monad m => EwM m SrcSpan
132 getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
133
134 liftEwM :: Monad m => m a -> EwM m a
135 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
136
137
138 --------------------------------------------------------
139 -- A state monad for use in the command-line parser
140 --------------------------------------------------------
141
142 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
143 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
144
145 instance Functor (CmdLineP s) where
146 fmap = liftM
147
148 instance Applicative (CmdLineP s) where
149 pure a = CmdLineP $ \s -> (a, s)
150 (<*>) = ap
151
152 instance Monad (CmdLineP s) where
153 m >>= k = CmdLineP $ \s ->
154 let (a, s') = runCmdLine m s
155 in runCmdLine (k a) s'
156
157 return = pure
158
159 getCmdLineState :: CmdLineP s s
160 getCmdLineState = CmdLineP $ \s -> (s,s)
161 putCmdLineState :: s -> CmdLineP s ()
162 putCmdLineState s = CmdLineP $ \_ -> ((),s)
163
164
165 --------------------------------------------------------
166 -- Processing arguments
167 --------------------------------------------------------
168
169 processArgs :: Monad m
170 => [Flag m] -- cmdline parser spec
171 -> [Located String] -- args
172 -> m ( [Located String], -- spare args
173 [Located String], -- errors
174 [Located String] ) -- warnings
175 processArgs spec args = do
176 (errs, warns, spare) <- runEwM action
177 return (spare, bagToList errs, bagToList warns)
178 where
179 action = process args []
180
181 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
182 process [] spare = return (reverse spare)
183
184 process (locArg@(L _ ('-' : arg)) : args) spare =
185 case findArg spec arg of
186 Just (rest, opt_kind) ->
187 case processOneArg opt_kind rest arg args of
188 Left err ->
189 let b = process args spare
190 in (setArg locArg $ addErr err) >> b
191
192 Right (action,rest) ->
193 let b = process rest spare
194 in (setArg locArg $ action) >> b
195
196 Nothing -> process args (locArg : spare)
197
198 process (arg : args) spare = process args (arg : spare)
199
200
201 processOneArg :: OptKind m -> String -> String -> [Located String]
202 -> Either String (EwM m (), [Located String])
203 processOneArg opt_kind rest arg args
204 = let dash_arg = '-' : arg
205 rest_no_eq = dropEq rest
206 in case opt_kind of
207 NoArg a -> ASSERT(null rest) Right (a, args)
208
209 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
210 | otherwise -> case args of
211 [] -> missingArgErr dash_arg
212 (L _ arg1:args1) -> Right (f arg1, args1)
213
214 -- See Trac #9776
215 SepArg f -> case args of
216 [] -> missingArgErr dash_arg
217 (L _ arg1:args1) -> Right (f arg1, args1)
218
219 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
220 | otherwise -> unknownFlagErr dash_arg
221
222 PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
223 | otherwise -> unknownFlagErr dash_arg
224
225 PassFlag f | notNull rest -> unknownFlagErr dash_arg
226 | otherwise -> Right (f dash_arg, args)
227
228 OptIntSuffix f | null rest -> Right (f Nothing, args)
229 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
230 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
231
232 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
233 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
234
235 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
236 | otherwise -> Left ("malformed float argument in " ++ dash_arg)
237
238 OptPrefix f -> Right (f rest_no_eq, args)
239 AnySuffix f -> Right (f dash_arg, args)
240 AnySuffixPred _ f -> Right (f dash_arg, args)
241
242 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
243 findArg spec arg =
244 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
245 [ (removeSpaces rest, optKind)
246 | flag <- spec,
247 let optKind = flagOptKind flag,
248 Just rest <- [stripPrefix (flagName flag) arg],
249 arg_ok optKind rest arg ]
250 of
251 [] -> Nothing
252 (one:_) -> Just one
253
254 arg_ok :: OptKind t -> [Char] -> String -> Bool
255 arg_ok (NoArg _) rest _ = null rest
256 arg_ok (HasArg _) _ _ = True
257 arg_ok (SepArg _) rest _ = null rest
258 arg_ok (Prefix _) rest _ = notNull rest
259 arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
260 arg_ok (OptIntSuffix _) _ _ = True
261 arg_ok (IntSuffix _) _ _ = True
262 arg_ok (FloatSuffix _) _ _ = True
263 arg_ok (OptPrefix _) _ _ = True
264 arg_ok (PassFlag _) rest _ = null rest
265 arg_ok (AnySuffix _) _ _ = True
266 arg_ok (AnySuffixPred p _) _ arg = p arg
267
268 -- | Parse an Int
269 --
270 -- Looks for "433" or "=342", with no trailing gubbins
271 -- * n or =n => Just n
272 -- * gibberish => Nothing
273 parseInt :: String -> Maybe Int
274 parseInt s = case reads s of
275 ((n,""):_) -> Just n
276 _ -> Nothing
277
278 parseFloat :: String -> Maybe Float
279 parseFloat s = case reads s of
280 ((n,""):_) -> Just n
281 _ -> Nothing
282
283 -- | Discards a leading equals sign
284 dropEq :: String -> String
285 dropEq ('=' : s) = s
286 dropEq s = s
287
288 unknownFlagErr :: String -> Either String a
289 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
290
291 missingArgErr :: String -> Either String a
292 missingArgErr f = Left ("missing argument for flag: " ++ f)
293
294 --------------------------------------------------------
295 -- Utils
296 --------------------------------------------------------
297
298
299 -- See Note [Handling errors when parsing flags]
300 errorsToGhcException :: [(String, -- Location
301 String)] -- Error
302 -> GhcException
303 errorsToGhcException errs =
304 UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
305
306 {- Note [Handling errors when parsing commandline flags]
307
308 Parsing of static and mode flags happens before any session is started, i.e.,
309 before the first call to 'GHC.withGhc'. Therefore, to report errors for
310 invalid usage of these two types of flags, we can not call any function that
311 needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
312 is not set either). So we always print "on the commandline" as the location,
313 which is true except for Api users, which is probably ok.
314
315 When reporting errors for invalid usage of dynamic flags we /can/ make use of
316 DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
317
318 Before, we called unsafeGlobalDynFlags when an invalid (combination of)
319 flag(s) was given on the commandline, resulting in panics (#9963).
320 -}