module ShellCheck.ASTLib where

import ShellCheck.AST

import Control.Monad.Writer

import Control.Monad

import Data.Char

import Data.Functor

import Data.Functor.Identity

import Data.List

import Data.Maybe

import qualified Data.Map as Map

arguments (T_SimpleCommand _ _ (cmd:args)) = args

isLoop t = case t of

T_WhileExpression {} -> True

T_UntilExpression {} -> True

T_ForIn {} -> True

T_ForArithmetic {} -> True

T_SelectIn {} -> True

_ -> False

willSplit x =

case x of

T_DollarBraced {} -> True

T_DollarExpansion {} -> True

T_Backticked {} -> True

T_BraceExpansion {} -> True

T_Glob {} -> True

T_Extglob {} -> True

T_DoubleQuoted _ l -> any willBecomeMultipleArgs l

T_NormalWord _ l -> any willSplit l

_ -> False

isGlob T_Extglob {} = True

isGlob T_Glob {} = True

isGlob (T_NormalWord _ l) = any isGlob l

isGlob _ = False

isConstant token =

case token of

-- This ignores some cases like ~"foo":

T_NormalWord _ (T_Literal _ ('~':_) : _) -> False

T_NormalWord _ l -> all isConstant l

T_DoubleQuoted _ l -> all isConstant l

T_SingleQuoted _ _ -> True

T_Literal _ _ -> True

_ -> False

isEmpty token =

case token of

T_NormalWord _ l -> all isEmpty l

T_DoubleQuoted _ l -> all isEmpty l

T_SingleQuoted _ "" -> True

T_Literal _ "" -> True

_ -> False

oversimplify token =

case token of

(T_NormalWord _ l) -> [concat (concatMap oversimplify l)]

(T_DoubleQuoted _ l) -> [concat (concatMap oversimplify l)]

(T_SingleQuoted _ s) -> [s]

(T_DollarBraced _ _ _) -> ["${VAR}"]

(T_DollarArithmetic _ _) -> ["${VAR}"]

(T_DollarExpansion _ _) -> ["${VAR}"]

(T_Backticked _ _) -> ["${VAR}"]

(T_Glob _ s) -> [s]

(T_Pipeline _ _ [x]) -> oversimplify x

(T_Literal _ x) -> [x]

(T_ParamSubSpecialChar _ x) -> [x]

(T_SimpleCommand _ vars words) -> concatMap oversimplify words

(T_Redirecting _ _ foo) -> oversimplify foo

(T_DollarSingleQuoted _ s) -> [s]

(T_Annotation _ _ s) -> oversimplify s

-- Workaround for let "foo = bar" parsing

(TA_Sequence _ [TA_Expansion _ v]) -> concatMap oversimplify v

_ -> []

getFlagsUntil stopCondition (T_SimpleCommand _ _ (_:args)) =

let tokenAndText = map (\x -> (x, concat $ oversimplify x)) args

(flagArgs, rest) = break (stopCondition . snd) tokenAndText

in

concatMap flag flagArgs ++ map (\(t, _) -> (t, "")) rest

where

flag (x, '-':'-':arg) = [ (x, takeWhile (/= '=') arg) ]

flag (x, '-':args) = map (\v -> (x, [v])) args

flag (x, _) = [ (x, "") ]

getFlagsUntil _ _ = error "Internal shellcheck error, please report! (getFlags on non-command)"

getAllFlags :: Token -> [(Token, String)]

getAllFlags = getFlagsUntil (== "--")

getLeadingFlags = getFlagsUntil (\x -> x == "--" || (not $ "-" `isPrefixOf` x))

hasFlag cmd str = str `elem` (map snd $ getAllFlags cmd)

isFlag token =

case getWordParts token of

T_Literal _ ('-':_) : _ -> True

_ -> False

isUnquotedFlag token = fromMaybe False $ do

str <- getLeadingUnquotedString token

return $ "-" `isPrefixOf` str

getGnuOpts :: String -> [Token] -> Maybe [(String, (Token, Token))]

getGnuOpts str args = getOpts (True, False) str [] args

getBsdOpts :: String -> [Token] -> Maybe [(String, (Token, Token))]

getBsdOpts str args = getOpts (False, False) str [] args

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 [] = longopts

flagMap = Map.fromList $ ("", False) : flagList string

process [] = return []

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

isArrayExpansion (T_DollarBraced _ _ l) =

let string = concat $ oversimplify l in

"@" `isPrefixOf` string ||

not ("#" `isPrefixOf` string) && "[@]" `isInfixOf` string

isArrayExpansion _ = False

mayBecomeMultipleArgs t = willBecomeMultipleArgs t || f t

where

f (T_DollarBraced _ _ l) =

let string = concat $ oversimplify l in

"!" `isPrefixOf` string

f (T_DoubleQuoted _ parts) = any f parts

f (T_NormalWord _ parts) = any f parts

f _ = False

willBecomeMultipleArgs t = willConcatInAssignment t || f t

where

f T_Extglob {} = True

f T_Glob {} = True

f T_BraceExpansion {} = True

f (T_DoubleQuoted _ parts) = any f parts

f (T_NormalWord _ parts) = any f parts

f _ = False

willConcatInAssignment token =

case token of

t@T_DollarBraced {} -> isArrayExpansion t

(T_DoubleQuoted _ parts) -> any willConcatInAssignment parts

(T_NormalWord _ parts) -> any willConcatInAssignment parts

_ -> False

getLiteralString :: Token -> Maybe String

getLiteralString = getLiteralStringExt (const Nothing)

getLiteralStringDef :: String -> Token -> String

getLiteralStringDef x = runIdentity . getLiteralStringExt (const $ return x)

onlyLiteralString :: Token -> String

onlyLiteralString = getLiteralStringDef ""

getUnquotedLiteral (T_NormalWord _ list) =

concat <$> mapM str list

where

str (T_Literal _ s) = return s

str _ = Nothing

getUnquotedLiteral _ = Nothing

getTrailingUnquotedLiteral :: Token -> Maybe Token

getTrailingUnquotedLiteral t =

case t of

(T_NormalWord _ list@(_:_)) ->

from (last list)

_ -> Nothing

where

from t =

case t of

T_Literal {} -> return t

_ -> Nothing

getLeadingUnquotedString :: Token -> Maybe String

getLeadingUnquotedString t =

case t of

T_NormalWord _ ((T_Literal _ s) : _) -> return s

_ -> Nothing

getGlobOrLiteralString = getLiteralStringExt f

where

f (T_Glob _ str) = return str

f _ = Nothing

getLiteralStringExt :: Monad m => (Token -> m String) -> Token -> m String

getLiteralStringExt more = g

where

allInList = fmap concat . mapM g

g (T_DoubleQuoted _ l) = allInList l

g (T_DollarDoubleQuoted _ l) = allInList l

g (T_NormalWord _ l) = allInList l

g (TA_Expansion _ l) = allInList l

g (T_SingleQuoted _ s) = return s

g (T_Literal _ s) = return s

g (T_ParamSubSpecialChar _ s) = return s

g (T_DollarSingleQuoted _ s) = return $ decodeEscapes s

g x = more x

-- Bash style $'..' decoding

decodeEscapes ('\\':c:cs) =

case c of

'a' -> '\a' : rest

'b' -> '\b' : rest

'e' -> '\x1B' : rest

'f' -> '\f' : rest

'n' -> '\n' : rest

'r' -> '\r' : rest

't' -> '\t' : rest

'v' -> '\v' : rest

'\'' -> '\'' : rest

'"' -> '"' : rest

'\\' -> '\\' : rest

'x' ->

case cs of

(x:y:more) ->

if isHexDigit x && isHexDigit y

then chr (16*(digitToInt x) + (digitToInt y)) : rest

else '\\':c:rest

_ | isOctDigit c ->

let digits = take 3 $ takeWhile isOctDigit (c:cs)

num = parseOct digits

in (if num < 256 then chr num else '?') : rest

_ -> '\\' : c : rest

where

rest = decodeEscapes cs

parseOct = f 0

where

f n "" = n

f n (c:rest) = f (n * 8 + digitToInt c) rest

decodeEscapes (c:cs) = c : decodeEscapes cs

decodeEscapes [] = []

isLiteral t = isJust $ getLiteralString t

getWordParts (T_NormalWord _ l) = concatMap getWordParts l

getWordParts (T_DoubleQuoted _ l) = l

getWordParts (TA_Expansion _ l) = concatMap getWordParts l

getWordParts other = [other]

braceExpand (T_NormalWord id list) = take 1000 $ do

items <- mapM part list

return $ T_NormalWord id items

where

part (T_BraceExpansion id items) = do

item <- items

braceExpand item

part x = return x

getCommand t =

case t of

T_Redirecting _ _ w -> getCommand w

T_SimpleCommand _ _ (w:_) -> return t

T_Annotation _ _ t -> getCommand t

_ -> Nothing

getCommandName :: Token -> Maybe String

getCommandName = fst . getCommandNameAndToken False

getCommandArgv t = do

(T_SimpleCommand _ _ args@(_:_)) <- getCommand t

return args

getCommandTokenOrThis = snd . getCommandNameAndToken False

getCommandNameAndToken :: Bool -> Token -> (Maybe String, Token)

getCommandNameAndToken direct t = fromMaybe (Nothing, t) $ do

cmd@(T_SimpleCommand _ _ (w:rest)) <- getCommand t

s <- getLiteralString w

return $ fromMaybe (Just s, w) $ do

guard $ not direct

actual <- getEffectiveCommandToken s cmd rest

return (getLiteralString actual, actual)

where

getEffectiveCommandToken str cmd args =

let

firstArg = do

arg <- listToMaybe args

guard . not $ isFlag arg

return arg

in

case str of

"busybox" -> firstArg

"builtin" -> firstArg

"command" -> firstArg

"exec" -> do

opts <- getBsdOpts "cla:" args

(_, (t, _)) <- listToMaybe $ filter (null . fst) opts

return t

_ -> fail ""

getCommandNameFromExpansion :: Token -> Maybe String

getCommandNameFromExpansion t =

case t of

T_DollarExpansion _ [c] -> extract c

T_Backticked _ [c] -> extract c

T_DollarBraceCommandExpansion _ [c] -> extract c

_ -> Nothing

where

extract (T_Pipeline _ _ [cmd]) = getCommandName cmd

extract _ = Nothing

getCommandBasename = fmap basename . getCommandName

basename = reverse . takeWhile (/= '/') . reverse

isAssignment t =

case t of

T_Redirecting _ _ w -> isAssignment w

T_SimpleCommand _ (w:_) [] -> True

T_Assignment {} -> True

T_Annotation _ _ w -> isAssignment w

_ -> False

isOnlyRedirection t =

case t of

T_Pipeline _ _ [x] -> isOnlyRedirection x

T_Annotation _ _ w -> isOnlyRedirection w

T_Redirecting _ (_:_) c -> isOnlyRedirection c

T_SimpleCommand _ [] [] -> True

_ -> False

isFunction t = case t of T_Function {} -> True; _ -> False

isFunctionLike t =

case t of

T_Function {} -> True

T_BatsTest {} -> True

_ -> False

isBraceExpansion t = case t of T_BraceExpansion {} -> True; _ -> False

getCommandSequences :: Token -> [[Token]]

getCommandSequences t =

case t of

T_Script _ _ cmds -> [cmds]

T_BraceGroup _ cmds -> [cmds]

T_Subshell _ cmds -> [cmds]

T_WhileExpression _ cond cmds -> [cond, cmds]

T_UntilExpression _ cond cmds -> [cond, cmds]

T_ForIn _ _ _ cmds -> [cmds]

T_ForArithmetic _ _ _ _ cmds -> [cmds]

T_IfExpression _ thens elses -> (concatMap (\(a,b) -> [a,b]) thens) ++ [elses]

T_Annotation _ _ t -> getCommandSequences t

T_DollarExpansion _ cmds -> [cmds]

T_DollarBraceCommandExpansion _ cmds -> [cmds]

T_Backticked _ cmds -> [cmds]

_ -> []

getAssociativeArrays t =

nub . execWriter $ doAnalysis f t

where

f :: Token -> Writer [String] ()

f t@T_SimpleCommand {} = sequence_ $ do

name <- getCommandName t

let assocNames = ["declare","local","typeset"]

guard $ name `elem` assocNames

let flags = getAllFlags t

guard $ "A" `elem` map snd flags

let args = [arg | (arg, "") <- flags]

let names = mapMaybe (getLiteralStringExt nameAssignments) args

return $ tell names

f _ = return ()

nameAssignments t =

case t of

T_Assignment _ _ name _ _ -> return name

_ -> Nothing

data PseudoGlob = PGAny | PGMany | PGChar Char

deriving (Eq, Show)

wordToPseudoGlob :: Token -> [PseudoGlob]

wordToPseudoGlob = fromMaybe [PGMany] . wordToPseudoGlob' False

wordToExactPseudoGlob :: Token -> Maybe [PseudoGlob]

wordToExactPseudoGlob = wordToPseudoGlob' True

wordToPseudoGlob' :: Bool -> Token -> Maybe [PseudoGlob]

wordToPseudoGlob' exact word =

simplifyPseudoGlob <$> toGlob word

where

toGlob :: Token -> Maybe [PseudoGlob]

toGlob word =

case word of

T_NormalWord _ (T_Literal _ ('~':str):rest) -> do

guard $ not exact

let this = (PGMany : (map PGChar $ dropWhile (/= '/') str))

tail <- concat <$> (mapM f $ concatMap getWordParts rest)

return $ this ++ tail

_ -> concat <$> (mapM f $ getWordParts word)

f x = case x of

T_Literal _ s -> return $ map PGChar s

T_SingleQuoted _ s -> return $ map PGChar s

T_Glob _ "?" -> return [PGAny]

T_Glob _ "*" -> return [PGMany]

T_Glob _ ('[':_) | not exact -> return [PGAny]

_ -> if exact then fail "" else return [PGMany]

simplifyPseudoGlob :: [PseudoGlob] -> [PseudoGlob]

simplifyPseudoGlob = f

where

f [] = []

f (x@(PGChar _) : rest ) = x : f rest

f list =

let (anys, rest) = span (\x -> x == PGMany || x == PGAny) list in

order anys ++ f rest

order s = let (any, many) = partition (== PGAny) s in

any ++ take 1 many

pseudoGlobsCanOverlap :: [PseudoGlob] -> [PseudoGlob] -> Bool

pseudoGlobsCanOverlap = matchable

where

matchable x@(xf:xs) y@(yf:ys) =

case (xf, yf) of

(PGMany, _) -> matchable x ys || matchable xs y

(_, PGMany) -> matchable x ys || matchable xs y

(PGAny, _) -> matchable xs ys

(_, PGAny) -> matchable xs ys

(_, _) -> xf == yf && matchable xs ys

matchable [] [] = True

matchable (PGMany : rest) [] = matchable rest []

matchable (_:_) [] = False

matchable [] r = matchable r []

pseudoGlobIsSuperSetof :: [PseudoGlob] -> [PseudoGlob] -> Bool

pseudoGlobIsSuperSetof = matchable

where

matchable x@(xf:xs) y@(yf:ys) =

case (xf, yf) of

(PGMany, PGMany) -> matchable x ys

(PGMany, _) -> matchable x ys || matchable xs y

(_, PGMany) -> False

(PGAny, _) -> matchable xs ys

(_, PGAny) -> False

(_, _) -> xf == yf && matchable xs ys

matchable [] [] = True

matchable (PGMany : rest) [] = matchable rest []

matchable _ _ = False

wordsCanBeEqual x y = pseudoGlobsCanOverlap (wordToPseudoGlob x) (wordToPseudoGlob y)

isQuoteableExpansion t = case t of

T_DollarBraced {} -> True

_ -> isCommandSubstitution t

isCommandSubstitution t = case t of

T_DollarExpansion {} -> True

T_DollarBraceCommandExpansion {} -> True

T_Backticked {} -> True

_ -> False

isStringExpansion t = isCommandSubstitution t || case t of

T_DollarArithmetic {} -> True

T_DollarBraced {} -> not (isArrayExpansion t)

_ -> False

isAnnotationIgnoringCode code t =

case t of

T_Annotation _ anns _ -> any hasNum anns

_ -> False

where

hasNum (DisableComment from to) = code >= from && code < to

hasNum _ = False