1{-# LANGUAGE CPP #-}
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
14module 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      deprecate
25    ) where
26
27#include "GhclibHsVersions.h"
28
29import GHC.Prelude
30
31import GHC.Utils.Misc
32import GHC.Utils.Outputable
33import GHC.Utils.Panic
34import GHC.Data.Bag
35import GHC.Types.SrcLoc
36import GHC.Utils.Json
37
38import Data.Function
39import Data.List (sortBy, intercalate, stripPrefix)
40
41import Control.Monad (liftM, ap)
42
43--------------------------------------------------------
44--         The Flag and OptKind types
45--------------------------------------------------------
46
47data 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
53defFlag :: String -> OptKind m -> Flag m
54defFlag name optKind = Flag name optKind AllModes
55
56defGhcFlag :: String -> OptKind m -> Flag m
57defGhcFlag name optKind = Flag name optKind OnlyGhc
58
59defGhciFlag :: String -> OptKind m -> Flag m
60defGhciFlag name optKind = Flag name optKind OnlyGhci
61
62defHiddenFlag :: String -> OptKind m -> Flag m
63defHiddenFlag name optKind = Flag name optKind HiddenFlag
64
65-- | GHC flag modes describing when a flag has an effect.
66data 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
72data 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.
92data WarnReason
93  = NoReason
94  | ReasonDeprecatedFlag
95  | ReasonUnrecognisedFlag
96  deriving (Eq, Show)
97
98instance Outputable WarnReason where
99  ppr = text . show
100
101instance ToJson WarnReason where
102  json NoReason = JSNull
103  json reason   = JSString $ show reason
104
105-- | A command-line error message
106newtype Err  = Err { errMsg :: Located String }
107
108-- | A command-line warning message and the reason it arose
109data Warn = Warn
110  {   warnReason :: WarnReason,
111      warnMsg    :: Located String
112  }
113
114type Errs  = Bag Err
115type Warns = Bag Warn
116
117-- EwM ("errors and warnings monad") is a monad
118-- transformer for m that adds an (err, warn) state
119newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
120                              -> Errs -> Warns
121                              -> m (Errs, Warns, a) }
122
123instance Monad m => Functor (EwM m) where
124    fmap = liftM
125
126instance Monad m => Applicative (EwM m) where
127    pure v = EwM (\_ e w -> return (e, w, v))
128    (<*>) = ap
129
130instance 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
134runEwM :: EwM m a -> m (Errs, Warns, a)
135runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
136
137setArg :: Located String -> EwM m () -> EwM m ()
138setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
139
140addErr :: Monad m => String -> EwM m ()
141addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
142
143addWarn :: Monad m => String -> EwM m ()
144addWarn = addFlagWarn NoReason
145
146addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
147addFlagWarn reason msg = EwM $
148  (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
149
150deprecate :: Monad m => String -> EwM m ()
151deprecate s = do
152    arg <- getArg
153    addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
154
155getArg :: Monad m => EwM m String
156getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
157
158getCurLoc :: Monad m => EwM m SrcSpan
159getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
160
161liftEwM :: Monad m => m a -> EwM m a
162liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
163
164
165--------------------------------------------------------
166-- A state monad for use in the command-line parser
167--------------------------------------------------------
168
169-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
170newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
171    deriving (Functor)
172
173instance Applicative (CmdLineP s) where
174    pure a = CmdLineP $ \s -> (a, s)
175    (<*>) = ap
176
177instance Monad (CmdLineP s) where
178    m >>= k = CmdLineP $ \s ->
179                  let (a, s') = runCmdLine m s
180                  in runCmdLine (k a) s'
181
182
183getCmdLineState :: CmdLineP s s
184getCmdLineState   = CmdLineP $ \s -> (s,s)
185putCmdLineState :: s -> CmdLineP s ()
186putCmdLineState s = CmdLineP $ \_ -> ((),s)
187
188
189--------------------------------------------------------
190--         Processing arguments
191--------------------------------------------------------
192
193processArgs :: Monad m
194            => [Flag m]               -- cmdline parser spec
195            -> [Located String]       -- args
196            -> m ( [Located String],  -- spare args
197                   [Err],  -- errors
198                   [Warn] ) -- warnings
199processArgs 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
225processOneArg :: OptKind m -> String -> String -> [Located String]
226              -> Either String (EwM m (), [Located String])
227processOneArg 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 #9776
239        SepArg f -> case args of
240                        []               -> missingArgErr dash_arg
241                        (L _ arg1:args1) -> Right (f arg1, args1)
242
243        -- See #12625
244        Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
245                 | otherwise          -> missingArgErr  dash_arg
246
247        PassFlag f  | notNull rest -> unknownFlagErr dash_arg
248                    | otherwise    -> Right (f dash_arg, args)
249
250        OptIntSuffix f | null rest                     -> Right (f Nothing,  args)
251                       | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
252                       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
253
254        IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
255                    | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
256
257        WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)
258                     | otherwise -> Left ("malformed natural argument in " ++ dash_arg)
259
260        FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
261                      | otherwise -> Left ("malformed float argument in " ++ dash_arg)
262
263        OptPrefix f       -> Right (f rest_no_eq, args)
264        AnySuffix f       -> Right (f dash_arg, args)
265
266findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
267findArg 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
278arg_ok :: OptKind t -> [Char] -> String -> Bool
279arg_ok (NoArg           _)  rest _   = null rest
280arg_ok (HasArg          _)  _    _   = True
281arg_ok (SepArg          _)  rest _   = null rest
282arg_ok (Prefix          _)  _    _   = True -- Missing argument checked for in processOneArg t
283                                            -- to improve error message (#12625)
284arg_ok (OptIntSuffix    _)  _    _   = True
285arg_ok (IntSuffix       _)  _    _   = True
286arg_ok (WordSuffix      _)  _    _   = True
287arg_ok (FloatSuffix     _)  _    _   = True
288arg_ok (OptPrefix       _)  _    _   = True
289arg_ok (PassFlag        _)  rest _   = null rest
290arg_ok (AnySuffix       _)  _    _   = True
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
297parseInt :: String -> Maybe Int
298parseInt s = case reads s of
299                 ((n,""):_) -> Just n
300                 _          -> Nothing
301
302parseWord :: String -> Maybe Word
303parseWord s = case reads s of
304                 ((n,""):_) -> Just n
305                 _          -> Nothing
306
307parseFloat :: String -> Maybe Float
308parseFloat s = case reads s of
309                   ((n,""):_) -> Just n
310                   _          -> Nothing
311
312-- | Discards a leading equals sign
313dropEq :: String -> String
314dropEq ('=' : s) = s
315dropEq s         = s
316
317unknownFlagErr :: String -> Either String a
318unknownFlagErr f = Left ("unrecognised flag: " ++ f)
319
320missingArgErr :: String -> Either String a
321missingArgErr f = Left ("missing argument for flag: " ++ f)
322
323--------------------------------------------------------
324-- Utils
325--------------------------------------------------------
326
327
328-- See Note [Handling errors when parsing flags]
329errorsToGhcException :: [(String,    -- Location
330                          String)]   -- Error
331                     -> GhcException
332errorsToGhcException errs =
333    UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
334
335{- Note [Handling errors when parsing commandline flags]
336
337Parsing of static and mode flags happens before any session is started, i.e.,
338before the first call to 'GHC.withGhc'. Therefore, to report errors for
339invalid usage of these two types of flags, we can not call any function that
340needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
341is not set either). So we always print "on the commandline" as the location,
342which is true except for Api users, which is probably ok.
343
344When reporting errors for invalid usage of dynamic flags we /can/ make use of
345DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
346
347Before, we called unsafeGlobalDynFlags when an invalid (combination of)
348flag(s) was given on the commandline, resulting in panics (#9963).
349-}
350