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 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 | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn 81 | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn 82 | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn 83 84 85-------------------------------------------------------- 86-- The EwM monad 87-------------------------------------------------------- 88 89-- | Used when filtering warnings: if a reason is given 90-- it can be filtered out when displaying. 91data WarnReason 92 = NoReason 93 | ReasonDeprecatedFlag 94 | ReasonUnrecognisedFlag 95 deriving (Eq, Show) 96 97instance Outputable WarnReason where 98 ppr = text . show 99 100instance ToJson WarnReason where 101 json NoReason = JSNull 102 json reason = JSString $ show reason 103 104-- | A command-line error message 105newtype Err = Err { errMsg :: Located String } 106 107-- | A command-line warning message and the reason it arose 108data Warn = Warn 109 { warnReason :: WarnReason, 110 warnMsg :: Located String 111 } 112 113type Errs = Bag Err 114type Warns = Bag Warn 115 116-- EwM ("errors and warnings monad") is a monad 117-- transformer for m that adds an (err, warn) state 118newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg 119 -> Errs -> Warns 120 -> m (Errs, Warns, a) } 121 122instance Monad m => Functor (EwM m) where 123 fmap = liftM 124 125instance Monad m => Applicative (EwM m) where 126 pure v = EwM (\_ e w -> return (e, w, v)) 127 (<*>) = ap 128 129instance Monad m => Monad (EwM m) where 130 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w 131 unEwM (k r) l e' w') 132 133runEwM :: EwM m a -> m (Errs, Warns, a) 134runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag 135 136setArg :: Located String -> EwM m () -> EwM m () 137setArg l (EwM f) = EwM (\_ es ws -> f l es ws) 138 139addErr :: Monad m => String -> EwM m () 140addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) 141 142addWarn :: Monad m => String -> EwM m () 143addWarn = addFlagWarn NoReason 144 145addFlagWarn :: Monad m => WarnReason -> String -> EwM m () 146addFlagWarn reason msg = EwM $ 147 (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) 148 149deprecate :: Monad m => String -> EwM m () 150deprecate s = do 151 arg <- getArg 152 addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) 153 154getArg :: Monad m => EwM m String 155getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) 156 157getCurLoc :: Monad m => EwM m SrcSpan 158getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) 159 160liftEwM :: Monad m => m a -> EwM m a 161liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) 162 163 164-------------------------------------------------------- 165-- A state monad for use in the command-line parser 166-------------------------------------------------------- 167 168-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) 169newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } 170 deriving (Functor) 171 172instance Applicative (CmdLineP s) where 173 pure a = CmdLineP $ \s -> (a, s) 174 (<*>) = ap 175 176instance Monad (CmdLineP s) where 177 m >>= k = CmdLineP $ \s -> 178 let (a, s') = runCmdLine m s 179 in runCmdLine (k a) s' 180 181 182getCmdLineState :: CmdLineP s s 183getCmdLineState = CmdLineP $ \s -> (s,s) 184putCmdLineState :: s -> CmdLineP s () 185putCmdLineState s = CmdLineP $ \_ -> ((),s) 186 187 188-------------------------------------------------------- 189-- Processing arguments 190-------------------------------------------------------- 191 192processArgs :: Monad m 193 => [Flag m] -- cmdline parser spec 194 -> [Located String] -- args 195 -> m ( [Located String], -- spare args 196 [Err], -- errors 197 [Warn] ) -- warnings 198processArgs spec args = do 199 (errs, warns, spare) <- runEwM action 200 return (spare, bagToList errs, bagToList warns) 201 where 202 action = process args [] 203 204 -- process :: [Located String] -> [Located String] -> EwM m [Located String] 205 process [] spare = return (reverse spare) 206 207 process (locArg@(L _ ('-' : arg)) : args) spare = 208 case findArg spec arg of 209 Just (rest, opt_kind) -> 210 case processOneArg opt_kind rest arg args of 211 Left err -> 212 let b = process args spare 213 in (setArg locArg $ addErr err) >> b 214 215 Right (action,rest) -> 216 let b = process rest spare 217 in (setArg locArg $ action) >> b 218 219 Nothing -> process args (locArg : spare) 220 221 process (arg : args) spare = process args (arg : spare) 222 223 224processOneArg :: OptKind m -> String -> String -> [Located String] 225 -> Either String (EwM m (), [Located String]) 226processOneArg opt_kind rest arg args 227 = let dash_arg = '-' : arg 228 rest_no_eq = dropEq rest 229 in case opt_kind of 230 NoArg a -> ASSERT(null rest) Right (a, args) 231 232 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) 233 | otherwise -> case args of 234 [] -> missingArgErr dash_arg 235 (L _ arg1:args1) -> Right (f arg1, args1) 236 237 -- See #9776 238 SepArg f -> case args of 239 [] -> missingArgErr dash_arg 240 (L _ arg1:args1) -> Right (f arg1, args1) 241 242 -- See #12625 243 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) 244 | otherwise -> missingArgErr dash_arg 245 246 PassFlag f | notNull rest -> unknownFlagErr dash_arg 247 | otherwise -> Right (f dash_arg, args) 248 249 OptIntSuffix f | null rest -> Right (f Nothing, args) 250 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) 251 | otherwise -> Left ("malformed integer argument in " ++ dash_arg) 252 253 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) 254 | otherwise -> Left ("malformed integer argument in " ++ dash_arg) 255 256 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) 257 | otherwise -> Left ("malformed float argument in " ++ dash_arg) 258 259 OptPrefix f -> Right (f rest_no_eq, args) 260 AnySuffix f -> Right (f dash_arg, args) 261 262findArg :: [Flag m] -> String -> Maybe (String, OptKind m) 263findArg spec arg = 264 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag 265 [ (removeSpaces rest, optKind) 266 | flag <- spec, 267 let optKind = flagOptKind flag, 268 Just rest <- [stripPrefix (flagName flag) arg], 269 arg_ok optKind rest arg ] 270 of 271 [] -> Nothing 272 (one:_) -> Just one 273 274arg_ok :: OptKind t -> [Char] -> String -> Bool 275arg_ok (NoArg _) rest _ = null rest 276arg_ok (HasArg _) _ _ = True 277arg_ok (SepArg _) rest _ = null rest 278arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t 279 -- to improve error message (#12625) 280arg_ok (OptIntSuffix _) _ _ = True 281arg_ok (IntSuffix _) _ _ = True 282arg_ok (FloatSuffix _) _ _ = True 283arg_ok (OptPrefix _) _ _ = True 284arg_ok (PassFlag _) rest _ = null rest 285arg_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 292parseInt :: String -> Maybe Int 293parseInt s = case reads s of 294 ((n,""):_) -> Just n 295 _ -> Nothing 296 297parseFloat :: String -> Maybe Float 298parseFloat s = case reads s of 299 ((n,""):_) -> Just n 300 _ -> Nothing 301 302-- | Discards a leading equals sign 303dropEq :: String -> String 304dropEq ('=' : s) = s 305dropEq s = s 306 307unknownFlagErr :: String -> Either String a 308unknownFlagErr f = Left ("unrecognised flag: " ++ f) 309 310missingArgErr :: String -> Either String a 311missingArgErr f = Left ("missing argument for flag: " ++ f) 312 313-------------------------------------------------------- 314-- Utils 315-------------------------------------------------------- 316 317 318-- See Note [Handling errors when parsing flags] 319errorsToGhcException :: [(String, -- Location 320 String)] -- Error 321 -> GhcException 322errorsToGhcException errs = 323 UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] 324 325{- Note [Handling errors when parsing commandline flags] 326 327Parsing of static and mode flags happens before any session is started, i.e., 328before the first call to 'GHC.withGhc'. Therefore, to report errors for 329invalid usage of these two types of flags, we can not call any function that 330needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags 331is not set either). So we always print "on the commandline" as the location, 332which is true except for Api users, which is probably ok. 333 334When reporting errors for invalid usage of dynamic flags we /can/ make use of 335DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. 336 337Before, we called unsafeGlobalDynFlags when an invalid (combination of) 338flag(s) was given on the commandline, resulting in panics (#9963). 339-} 340