Rewrite getopts style option parser
This commit is contained in:
parent
8d99926554
commit
f100c2939e
|
@ -30,6 +30,8 @@ import Data.List
|
|||
import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
|
||||
arguments (T_SimpleCommand _ _ (cmd:args)) = args
|
||||
|
||||
-- Is this a type of loop?
|
||||
isLoop t = case t of
|
||||
T_WhileExpression {} -> True
|
||||
|
@ -135,32 +137,91 @@ isUnquotedFlag token = fromMaybe False $ do
|
|||
str <- getLeadingUnquotedString token
|
||||
return $ "-" `isPrefixOf` str
|
||||
|
||||
-- getGnuOpts "erd:u:" will parse a SimpleCommand like
|
||||
-- read -re -d : -u 3 bar
|
||||
-- getGnuOpts "erd:u:" will parse a list of arguments tokens like `read`
|
||||
-- -re -d : -u 3 bar
|
||||
-- into
|
||||
-- Just [("r", -re), ("e", -re), ("d", :), ("u", 3), ("", bar)]
|
||||
-- where flags with arguments map to arguments, while others map to themselves.
|
||||
-- Any unrecognized flag will result in Nothing.
|
||||
getGnuOpts str t = getOpts str $ getAllFlags t
|
||||
getBsdOpts str t = getOpts str $ getLeadingFlags t
|
||||
getOpts :: String -> [(Token, String)] -> Maybe [(String, Token)]
|
||||
getOpts string flags = process flags
|
||||
-- Just [("r", (-re, -re)), ("e", (-re, -re)), ("d", (-d,:)), ("u", (-u,3)), ("", (bar,bar))]
|
||||
--
|
||||
-- Each string flag maps to a tuple of (flag, argument), where argument=flag if it
|
||||
-- doesn't take a specific one.
|
||||
--
|
||||
-- Any unrecognized flag will result in Nothing. The exception is if arbitraryLongOpts
|
||||
-- is set, in which case --anything will map to "anything".
|
||||
getGnuOpts :: String -> [Token] -> Maybe [(String, (Token, Token))]
|
||||
getGnuOpts str args = getOpts (True, False) str [] args
|
||||
|
||||
-- As above, except the first non-arg string will treat the rest as arguments
|
||||
getBsdOpts :: String -> [Token] -> Maybe [(String, (Token, Token))]
|
||||
getBsdOpts str args = getOpts (False, False) str [] args
|
||||
|
||||
-- Tests for this are in Commands.hs where it's more frequently used
|
||||
getOpts ::
|
||||
-- Behavioral config: gnu style, allow arbitrary long options
|
||||
(Bool, Bool)
|
||||
-- A getopts style string
|
||||
-> String
|
||||
-- List of long options and whether they take arguments
|
||||
-> [(String, Bool)]
|
||||
-- List of arguments (excluding command)
|
||||
-> [Token]
|
||||
-- List of flags to tuple of (optionToken, valueToken)
|
||||
-> Maybe [(String, (Token, Token))]
|
||||
|
||||
getOpts (gnu, arbitraryLongOpts) string longopts args = process args
|
||||
where
|
||||
flagList (c:':':rest) = ([c], True) : flagList rest
|
||||
flagList (c:rest) = ([c], False) : flagList rest
|
||||
flagList [] = []
|
||||
flagList [] = longopts
|
||||
flagMap = Map.fromList $ ("", False) : flagList string
|
||||
|
||||
process [] = return []
|
||||
process ((token1, flag):rest1) = do
|
||||
takesArg <- Map.lookup flag flagMap
|
||||
(token, rest) <- if takesArg
|
||||
then case rest1 of
|
||||
(token2, ""):rest2 -> return (token2, rest2)
|
||||
_ -> fail "takesArg without valid arg"
|
||||
else return (token1, rest1)
|
||||
more <- process rest
|
||||
return $ (flag, token) : more
|
||||
process (token:rest) = do
|
||||
case getLiteralStringDef "\0" token of
|
||||
'-':'-':[] -> return $ listToArgs rest
|
||||
'-':'-':word -> do
|
||||
let (name, arg) = span (/= '=') word
|
||||
needsArg <-
|
||||
if arbitraryLongOpts
|
||||
then return $ Map.findWithDefault False name flagMap
|
||||
else Map.lookup name flagMap
|
||||
|
||||
if needsArg && null arg
|
||||
then
|
||||
case rest of
|
||||
(arg:rest2) -> do
|
||||
more <- process rest2
|
||||
return $ (name, (token, arg)) : more
|
||||
_ -> fail "Missing arg"
|
||||
else do
|
||||
more <- process rest
|
||||
-- Consider splitting up token to get arg
|
||||
return $ (name, (token, token)) : more
|
||||
'-':opts -> shortToOpts opts token rest
|
||||
arg ->
|
||||
if gnu
|
||||
then do
|
||||
more <- process rest
|
||||
return $ ("", (token, token)):more
|
||||
else return $ listToArgs (token:rest)
|
||||
|
||||
shortToOpts opts token args =
|
||||
case opts of
|
||||
c:rest -> do
|
||||
needsArg <- Map.lookup [c] flagMap
|
||||
case () of
|
||||
_ | needsArg && null rest -> do
|
||||
(next:restArgs) <- return args
|
||||
more <- process restArgs
|
||||
return $ ([c], (token, next)):more
|
||||
_ | needsArg -> do
|
||||
more <- process args
|
||||
return $ ([c], (token, token)):more
|
||||
_ -> do
|
||||
more <- shortToOpts rest token args
|
||||
return $ ([c], (token, token)):more
|
||||
[] -> process args
|
||||
|
||||
listToArgs = map (\x -> ("", (x, x)))
|
||||
|
||||
-- Is this an expansion of multiple items of an array?
|
||||
isArrayExpansion (T_DollarBraced _ _ l) =
|
||||
|
@ -362,8 +423,8 @@ getCommandNameAndToken direct t = fromMaybe (Nothing, t) $ do
|
|||
"builtin" -> firstArg
|
||||
"command" -> firstArg
|
||||
"exec" -> do
|
||||
opts <- getBsdOpts "cla:" cmd
|
||||
(_, t) <- listToMaybe $ filter (null . fst) opts
|
||||
opts <- getBsdOpts "cla:" args
|
||||
(_, (t, _)) <- listToMaybe $ filter (null . fst) opts
|
||||
return t
|
||||
_ -> fail ""
|
||||
|
||||
|
|
|
@ -2925,8 +2925,8 @@ checkReadWithoutR _ t@T_SimpleCommand {} | t `isUnqualifiedCommand` "read"
|
|||
where
|
||||
flags = getAllFlags t
|
||||
has_t0 = Just "0" == do
|
||||
parsed <- getOpts flagsForRead flags
|
||||
t <- lookup "t" parsed
|
||||
parsed <- getGnuOpts flagsForRead $ arguments t
|
||||
(_, t) <- lookup "t" parsed
|
||||
getLiteralString t
|
||||
|
||||
checkReadWithoutR _ _ = return ()
|
||||
|
@ -3383,7 +3383,7 @@ checkPipeToNowhere params t =
|
|||
|
||||
commandSpecificException name cmd =
|
||||
case name of
|
||||
"du" -> any (`elem` ["exclude-from", "files0-from"]) $ lt $ map snd $ getAllFlags cmd
|
||||
"du" -> any (`elem` ["exclude-from", "files0-from"]) $ map snd $ getAllFlags cmd
|
||||
_ -> False
|
||||
|
||||
warnAboutDupes (n, list@(_:_:_)) =
|
||||
|
|
|
@ -678,13 +678,13 @@ getModifiedVariableCommand base@(T_SimpleCommand id cmdPrefix (T_NormalWord _ (T
|
|||
where
|
||||
parseArgs :: Maybe (Token, Token, String, DataType)
|
||||
parseArgs = do
|
||||
args <- getGnuOpts "d:n:O:s:u:C:c:t" base
|
||||
args <- getGnuOpts "d:n:O:s:u:C:c:t" rest
|
||||
let names = map snd $ filter (\(x,y) -> null x) args
|
||||
if null names
|
||||
then
|
||||
return (base, base, "MAPFILE", DataArray SourceExternal)
|
||||
else do
|
||||
first <- listToMaybe names
|
||||
(_, first) <- listToMaybe names
|
||||
name <- getLiteralString first
|
||||
guard $ isVariableName name
|
||||
return (base, first, name, DataArray SourceExternal)
|
||||
|
|
|
@ -53,8 +53,6 @@ verify :: CommandCheck -> String -> Bool
|
|||
verify f s = producesComments (getChecker [f]) s == Just True
|
||||
verifyNot f s = producesComments (getChecker [f]) s == Just False
|
||||
|
||||
arguments (T_SimpleCommand _ _ (cmd:args)) = args
|
||||
|
||||
commandChecks :: [CommandCheck]
|
||||
commandChecks = [
|
||||
checkTr
|
||||
|
@ -116,6 +114,35 @@ prop_verifyOptionalExamples = all check optionalCommandChecks
|
|||
verify check (cdPositive desc)
|
||||
&& verifyNot check (cdNegative desc)
|
||||
|
||||
-- Run a check against the getopt parser. If it fails, the lists are empty.
|
||||
checkGetOpts str flags args f =
|
||||
flags == actualFlags && args == actualArgs
|
||||
where
|
||||
toTokens = map (T_Literal (Id 0)) . words
|
||||
opts = fromMaybe [] $ f (toTokens str)
|
||||
actualFlags = filter (not . null) $ map fst opts
|
||||
actualArgs = map (\(_, (_, x)) -> onlyLiteralString x) $ filter (null . fst) opts
|
||||
|
||||
-- Short options
|
||||
prop_checkGetOptsS1 = checkGetOpts "-f x" ["f"] [] $ getOpts (True, True) "f:" []
|
||||
prop_checkGetOptsS2 = checkGetOpts "-fx" ["f"] [] $ getOpts (True, True) "f:" []
|
||||
prop_checkGetOptsS3 = checkGetOpts "-f -x" ["f", "x"] [] $ getOpts (True, True) "fx" []
|
||||
prop_checkGetOptsS4 = checkGetOpts "-f -x" ["f"] [] $ getOpts (True, True) "f:" []
|
||||
prop_checkGetOptsS5 = checkGetOpts "-fx" [] [] $ getOpts (True, True) "fx:" []
|
||||
|
||||
-- Long options
|
||||
prop_checkGetOptsL1 = checkGetOpts "--foo=bar baz" ["foo"] ["baz"] $ getOpts (True, False) "" [("foo", True)]
|
||||
prop_checkGetOptsL2 = checkGetOpts "--foo bar baz" ["foo"] ["baz"] $ getOpts (True, False) "" [("foo", True)]
|
||||
prop_checkGetOptsL3 = checkGetOpts "--foo baz" ["foo"] ["baz"] $ getOpts (True, True) "" []
|
||||
prop_checkGetOptsL4 = checkGetOpts "--foo baz" [] [] $ getOpts (True, False) "" []
|
||||
|
||||
-- Know when to terminate
|
||||
prop_checkGetOptsT1 = checkGetOpts "-a x -b" ["a", "b"] ["x"] $ getOpts (True, True) "ab" []
|
||||
prop_checkGetOptsT2 = checkGetOpts "-a x -b" ["a"] ["x","-b"] $ getOpts (False, True) "ab" []
|
||||
prop_checkGetOptsT3 = checkGetOpts "-a -- -b" ["a"] ["-b"] $ getOpts (True, True) "ab" []
|
||||
prop_checkGetOptsT4 = checkGetOpts "-a -- -b" ["a", "b"] [] $ getOpts (True, True) "a:b" []
|
||||
|
||||
|
||||
buildCommandMap :: [CommandCheck] -> Map.Map CommandName (Token -> Analysis)
|
||||
buildCommandMap = foldl' addCheck Map.empty
|
||||
where
|
||||
|
@ -694,8 +721,8 @@ checkReadExpansions = CommandCheck (Exactly "read") check
|
|||
where
|
||||
options = getGnuOpts flagsForRead
|
||||
getVars cmd = fromMaybe [] $ do
|
||||
opts <- options cmd
|
||||
return [y | (x,y) <- opts, null x || x == "a"]
|
||||
opts <- options $ arguments cmd
|
||||
return [y | (x,(_, y)) <- opts, null x || x == "a"]
|
||||
|
||||
check cmd = mapM_ warning $ getVars cmd
|
||||
warning t = sequence_ $ do
|
||||
|
@ -1070,8 +1097,8 @@ prop_checkSudoArgs7 = verifyNot checkSudoArgs "sudo docker export foo"
|
|||
checkSudoArgs = CommandCheck (Basename "sudo") f
|
||||
where
|
||||
f t = sequence_ $ do
|
||||
opts <- parseOpts t
|
||||
let nonFlags = [x | ("",x) <- opts]
|
||||
opts <- parseOpts $ arguments t
|
||||
let nonFlags = [x | ("",(x, _)) <- opts]
|
||||
commandArg <- nonFlags !!! 0
|
||||
command <- getLiteralString commandArg
|
||||
guard $ command `elem` builtins
|
||||
|
|
Loading…
Reference in New Issue