Rewrite getopts style option parser

This commit is contained in:
Vidar Holen 2020-10-18 20:36:48 -07:00
parent 8d99926554
commit f100c2939e
4 changed files with 120 additions and 32 deletions

View File

@ -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 ""

View File

@ -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@(_:_:_)) =

View File

@ -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)

View File

@ -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