module Language.Sh.Parser ( parse, hereDocsComplete ) where
import Language.Sh.Parser.Internal
import Language.Sh.Parser.Parsec
import Language.Sh.Syntax
import Language.Sh.Map
import Language.Sh.Compat ( (<=<) )
import Text.ParserCombinators.Parsec.Error ( ParseError )
import Text.ParserCombinators.Parsec ( choice, manyTill, eof, many1,
skipMany, optional,
(<|>), (<?>), many, try, count,
sepBy1, notFollowedBy, lookAhead,
getInput, setInput, runParser
)
import Control.Monad ( unless, when, liftM2, ap, guard )
import Data.List ( (\\) )
import Data.Char ( isDigit )
import Data.Maybe ( isJust, catMaybes )
import Debug.Trace ( trace )
data WordContext = NormalContext | ParameterContext | HereEndContext
deriving ( Enum, Ord, Eq )
delimiters :: WordContext -> String
delimiters NormalContext = "&|;<>()# \t\r\n"
delimiters ParameterContext = "}"
delimiters HereEndContext = delimiters NormalContext
lookaheadNormalDelimiter :: P ()
lookaheadNormalDelimiter = lookAhead $
oneOf (delimiters NormalContext) >> return ()
cnewline :: P ()
cnewline = do newline <|> (do char '#'
skipMany (noneOf "\n\r")
newline <|> eof) <?> ""
spaces
eatNewlines :: P a -> P a
eatNewlines a = do a' <- a
newlines
return a'
statement :: P Statement
statement = do aliasOn
choice [try $ do name <- basicName
spaces >> char '(' >> spaces
char ')' <|> unexpectedNoEOF
spaces >> newlines
FunctionDefinition name
`fmap` compoundStatement
`ap` many redirection
,Compound `fmap` compoundStatement `ap` many redirection
,do s <- statementNoSS
case s of
OrderedStatement [] -> fail "empty statement"
s -> return s
]
statementNoSS :: P Statement
statementNoSS = do aliasOn
choice [expandAlias >> statementNoSS
,try $ do a <- assignment
fmap (addAssignment a) statementNoSS
,try $ do r <- redirection
fmap (addRedirection r) statementNoSS
,simpleStatement]
simpleStatement :: P Statement
simpleStatement = choice [expandAlias >> simpleStatement
,try $ do r <- redirection
fmap (addRedirection r) simpleStatement
,try $ do w <- word NormalContext
fmap (addWord w) simpleStatement
,return $ OrderedStatement []]
expandAlias :: P ()
expandAlias = try $ do (aok,as,ip) <- getAliasInfo
unless aok $ fail ""
a <- many $ noneOf "\\\"'()|&;<> \t\r\n"
case lookup a as of
Nothing -> fail ""
Just s -> injectAlias a s as ip
injectAlias :: String -> String -> [(String,String)] -> Bool -> P ()
injectAlias a s as ip = do i <- getInput
let (h,t) = splitAt 1 i
aOn = if isBlank $ last s
then (Ctl (AliasOn True):)
else id
setInput $ map Chr s ++
Ctl (IncPos ip):h ++
Ctl (Aliases as):
aOn t
setAliasInfo (True,as\\[(a,s)],False)
unless True $
do l <- getInput
setInput l
spaces
pipeline :: P Pipeline
pipeline = (try $ do reservedWord "!"
fmap BangPipeline $ statement `sepBy1` pipe
) <|> (fmap Pipeline $ statement `sepBy1` pipe)
pipe :: P ()
pipe = try $ do char '|'
notFollowedBy $ fmap Chr $ char '|'
spaces
andorlist :: P AndOrList
andorlist = assocL pipeline (try $ (operator "||" >> return (:||:))
<|> (operator "&&" >> return (:&&:)))
Singleton
reservedWord :: String -> P String
reservedWord s = try $ do s' <- string s <?> show s
lookaheadNormalDelimiter <|> eof
spaces
return s'
reservedWord_ :: String -> P ()
reservedWord_ s = reservedWord s >> return ()
isOperator :: String -> Bool
isOperator x = x `elem` [">",">>",">|","<","<>","<<","<<-",">&","<&",
"|","||","&","&&",";",";;","(",")"]
operator :: String -> P String
operator s = try $ do string s
eof <|> (do c <- lookAhead anyChar
guard $ not $ isOperator $ s++[c])
spaces
return s
operator_ :: String -> P ()
operator_ s = operator s >> return ()
inClause :: P [Word]
inClause = choice [try $ do optional sequentialSep
reservedWord "do"
return defaultIn
,do newlines
reservedWord "in" <|> unexpected
ws <- many (word NormalContext)
sequentialSep <|> unexpected
reservedWord "do" <|> unexpected
return ws]
where defaultIn = [[Quoted $ Expand $ SimpleExpansion "@"]]
cases :: P [([Word],[Command])]
cases = manyTill line $ reservedWord "esac"
where line = do ip <- insideParens
if ip then operator_ "(" <|> unexpected
else optional $ operator_ "("
pats <- word NormalContext `sepBy1` operator "|"
operator ")" <|> unexpectedNoEOF
(cmds,_) <- commandsTill dsemi
return (pats,cmds)
dsemi :: P String
dsemi = operator ";;" <|> lookAhead (reservedWord "esac") <?> "`;;' or `esac'"
compoundStatement :: P CompoundStatement
compoundStatement = choice [do reservedWord "for"
name <- basicName <|> unexpectedNoEOF
vallist <- inClause
(cs,_) <- commandsTill (reservedWord "done")
return $ For name vallist cs
,do reservedWord "while"
(cond,_) <- commandsTill $ reservedWord "do"
(code,_) <- commandsTill $ reservedWord "done"
return $ While cond code
,do reservedWord "until"
(cond,_) <- commandsTill $ reservedWord "do"
(code,_) <- commandsTill $ reservedWord "done"
return $ Until cond code
,do reservedWord "if"
parseIf
,do reservedWord "case"
expr <- word NormalContext <|> unexpectedNoEOF
newlines
reservedWord "in" <|> unexpected
newlines
what <- cases
return $ Case expr what
,do operator "("
openParen
cs <- many command
operator ")" <|> unexpected
closeParen
return $ Subshell cs
,do reservedWord "{"
(cs,_) <- commandsTill $ reservedWord "}"
return $ BraceGroup cs
]
parseIf :: P CompoundStatement
parseIf = do (cond,_) <- commandsTill $ reservedWord "then"
(thn,next) <- commandsTill $ choice [reservedWord "elif"
,reservedWord "else"
,reservedWord "fi"]
case next of
"else" -> do (els,_) <- commandsTill $ reservedWord "fi"
return $ If cond thn els
"elif" -> do elif <- parseIf
return $ If cond thn $ compound elif
"fi" -> return $ If cond thn []
where compound x = [Synchronous $ Singleton $ Pipeline [Compound x []]]
command :: P Command
command = do c <- andorlist <?> "list"
t <- commandTerminator <?> "terminator"
return $ if t then Asynchronous c
else Synchronous c
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM cond job = cond >>= (unless `flip` job)
readHDs :: P ()
readHDs = do hd <- nextHereDoc
case hd of
Just s -> readHD s >> readHDs
Nothing -> return ()
sequentialSep :: P ()
sequentialSep = choice [operator ";" >> return ()
,cnewline >> readHDs
,eof >> closeHereDocs
,do unlessM insideParens $ fail ""
lookAhead $ operator ")"
return ()
]
>> newlines
commandTerminator :: P Bool
commandTerminator = (operator "&" >> newlines >> return True)
<|> (sequentialSep >> return False)
<|> (lookAhead (operator_ ";;") >> return False)
<?> "terminator"
manyTill' :: P a -> P end -> P ([a],end)
manyTill' p end = scan
where scan = do e <- end
return ([],e)
<|> do x <- p
(xs,e) <- scan
return ((x:xs),e)
readHD :: String -> P ()
readHD delim = popHereDoc =<< manyTill' (dqLex "\\$`")
(choice [try $ do newline
string delim
newline <|> eof
return True
,eof >> return False])
dqLex :: String -> P Lexeme
dqLex escape = choice [do char '\\'
choice [newline >> dqLex escape
,ql `fmap` oneOf escape
,return $ ql '\\'
]
,Quoted `fmap` expansion
,ql `fmap` anyChar
]
closeHereDocs :: P ()
closeHereDocs = do hd <- nextHereDoc
case hd of
Nothing -> return ()
Just _ -> popHereDoc ([],False) >> closeHereDocs
newlines :: P ()
newlines = (try (skipMany cnewline) <|> return ()) >> spaces
word :: WordContext -> P Word
word context = do ip <- insideParens
let del = (if ip then (')':) else id) $ delimiters context
w <- fmap concat $ word' del <:> many (word' $ del\\"#")
spaces
return w
where word' :: String -> P Word
word' s = choice [do char '\\'
try (newline >> return []) <|>
do c <- anyChar
return [Quote '\\',ql c]
,do char '"'
w <- dqWord
char '"'
return $ Quote '"':w++[Quote '"']
,do char '\''
w <- many $ noneOf "\'"
char '\''
return $ Quote '\'':map ql w++[Quote '\'']
,do when (context==HereEndContext) $ fail ""
one expansion
,do c <- noneOf s
return [Literal c]
] <?> "word"
dqWord :: P Word
dqWord = fmap concat $ many $
choice [do char '\\'
choice [newline >> return []
,map ql `fmap` one (oneOf "\\$`\"")
,return $ [ql '\\']
]
,map Quoted `fmap` one expansion
,map ql `fmap` one (noneOf "\"")
]
isName :: String -> Bool
isName s = case parse' [] (try (only name) <|> only (many1 digit)) s of
Right _ -> True
Left _ -> False
expansion :: P Lexeme
expansion =
choice [do char '$'
choice [try $ do n <- name
return $ Expand $ SimpleExpansion n
,do char '{'
choice [do char '#'
n <- many $ noneOf "}"
char '}'
if isName n
then return $ Expand $ LengthExpansion n
else fatal $
"${#"++n++"}: bad substitution"
,try $ do n <- name
(c,op) <- modifier
rest <- word ParameterContext
char '}' <|> (char ')' >> unexEOF)
return $ Expand $
ModifiedExpansion n op c rest
,do ip <- insideParens
let p = if ip then (')':) else id
n <- many $ noneOf $ p "}"
char '}' <|> (char ')' >> unexEOF)
if isName n
then return $ Expand $ SimpleExpansion n
else fatal $ "${"++n++
"}: bad substitution"]
,do char '('
openParen
l <- choice [do char '('
a <- arithmetic
return $ Expand a
,do c <- commands
char ')'
return $ Expand $ CommandSub c]
closeParen
return l
,return $ Literal '$'
]
,do char '`'
s <- fmap catMaybes $ many $
escape "`$\\" <|> Just `fmap` noneOf "`"
char '`'
(_,as,_) <- getAliasInfo
case parse' as (only commands) s of
Left err -> fatal $ "command substitution: "
++ show (unFatal err)
Right cs -> return $ Expand $ CommandSub cs
]
where unexEOF = fatal "unexpected EOF while looking for matching `}'"
modifier = choice [do c <- zeroOne $ char ':'
op <- oneOf "-=?+"
return (not $ null c,op)
,do op <- oneOf "#%"
c <- zeroOne $ char op
return (not $ null c,op)]
arithmetic :: P Expansion
arithmetic = do w <- arithWord =<< getParenDepth
return $ Arithmetic $ ql '(':w
arithWord :: Int -> P Word
arithWord d0 = aw
where aw = do d <- getParenDepth
if d==d01
then (char ')' >> openParen >> return [])
<|> (openParen >> aw')
else aw'
aw' :: P Word
aw' = choice [do char '\\'
choice [newline >> aw'
,liftM2 (:) (ql `fmap` oneOf "\\$`\"") aw'
,liftM2 (\c r -> ql '\\':ql c:r) anyChar aw']
,do { ex <- expansion; fmap (Quoted ex:) aw' }
,char '(' >> openParen >> (ql '(':) `fmap` aw'
,char ')' >> closeParen >> (ql ')':) `fmap` aw
,liftM2 (:) (ql `fmap` anyChar) aw'
] <?> "arithmetic word"
escape :: String -> P (Maybe Char)
escape s = char '\\' >> choice [newline >> return Nothing
,Just `fmap` oneOf s
,return $ Just '\\']
name :: P String
name = count 1 (oneOf "@*#?-$!" <|> digit) <|>
alphaUnder <:> many alphaUnderNum
<?> "name"
basicName :: P String
basicName = token (alphaUnder <:> many alphaUnderNum) <?> "name"
assignment :: P Assignment
assignment = do var <- basicName <?> "name"
char '='
val <- fmap concat $ zeroOne $ word NormalContext
return $ var := val
<?> "assignment"
redirection :: P Redir
redirection = try (do spaces
d <- many digit
o <- redirOperator
spaces
let fd = if null d then Nothing else Just $ read d
if o `elem` ["<<","<<-"]
then do t <- hereEnd
mkHereDoc o fd t
else do t <- word NormalContext
mkRedir o fd t)
<?> "redirection"
hereEnd :: P String
hereEnd = token $ fromLit `fmap` word HereEndContext
where fromLit [] = ""
fromLit (Quote _:xs) = fromLit xs
fromLit (Quoted q:xs) = fromLit $ q:xs
fromLit (Literal l:xs) = l:fromLit xs
commands :: P [Command]
commands = do newlines
many command
commandsTill :: P String -> P ([Command],String)
commandsTill delim = do rest <- getInput
(c,e) <- manyTill' (eatNewlines command) delim
c' <- expandHereDocs c
return (c',e)
unorderStatements :: [Command] -> [Command]
unorderStatements = mapCommands f
where f :: Statement -> Statement
f (OrderedStatement ts) = let (ws,rs,as) = f' ts
in Statement ws rs as
f s = s
f' [] = ([],[],[])
f' (TWord w:ts) = let (ws,rs,as) = f' ts in (w:ws,rs,as)
f' (TRedir r:ts) = let (ws,rs,as) = f' ts in (ws,r:rs,as)
f' (TAssignment a:ts) = let (ws,rs,as) = f' ts in (ws,rs,a:as)
expandHereDocs :: [Command] -> P [Command]
expandHereDocs c = unorderStatements `fmap` mapCommandsM f c
where f (i :<< s) = mk i id
f (i :<<- s) = mk i stripTabs
f r = return r
stripTabs [] = []
stripTabs (Literal n:Literal '\t':rest)
| n `elem` "\n\r" = stripTabs (Literal n:rest)
stripTabs (x:xs) = x:stripTabs xs
mk i f = do mwb <- nextHDReplacement
case mwb of
Just (w,b) -> return $ Heredoc i b (f w)
Nothing -> return $ Heredoc i False []
hereDocsComplete :: [Command] -> Bool
hereDocsComplete = isJust . mapCommandsM complete
where complete r = case r of
(_:<<_) -> Nothing
(_:<<-_) -> Nothing
Heredoc _ False _ -> Nothing
r -> Just r
only :: P a -> P a
only p = p >>= (\a -> eof >> return a)
parse' :: [(String,String)] -> P a -> String -> Either ParseError a
parse' as p s = runParser p (startState as) "" (map Chr s)
parse :: [(String,String)]
-> String
-> Either (String,Bool) [Command]
parse as s = case parse' as (only commands >>= expandHereDocs) s of
Left err -> case getFatal err of
Just f -> Left (f,True)
Nothing -> Left (show err,False)
Right cs -> Right cs