LslPlus-0.4.3: src/Language/Lsl/Parse.hs
{-# OPTIONS_GHC -XDeriveDataTypeable #-}
{-# OPTIONS_GHC -XQuasiQuotes #-}
module Language.Lsl.Parse(
alternateScriptParser,
alternateModuleParser,
parseScript,
parseModule,
exprParser,
parseType,
parseScriptFromString,
parseModuleFromString,
parseScriptFromStringAQ,
parseModuleFromStringAQ,
ParseError,
SourcePos,
errorMessages,
errorPos,
showErrorMessages,
sourceLine,
sourceColumn,
sourceName
) where
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import Data.Data
import Data.Char(digitToInt)
import Data.List(intersperse)
import Language.Lsl.Internal.Pragmas(Pragma(..))
import Language.Lsl.Syntax(Expr(..),Statement(..),Func(..),FuncDec(..),Handler(Handler),State(..),Ctx(..),
TextLocation(..),SourceContext(..),LSLType(..),
Component(..),Var(..),LModule(..),LSLScript(..),GlobDef(..),goodHandlers,nullCtx)
import Text.ParserCombinators.Parsec hiding (State)
import qualified Text.ParserCombinators.ParsecExtras.Token as P
import Text.ParserCombinators.ParsecExtras.Language( javaStyle, emptyDef )
import Text.ParserCombinators.Parsec.Error
import Text.ParserCombinators.Parsec.Pos
import Text.Here
import Debug.Trace
data ParseState = ParseState {
atStart :: !Bool,
initialComment :: !String,
parseAntiQuotations :: !Bool,
pendingPragmas :: ![Pragma],
trailingWS :: !String,
leadingWS :: !String,
preWSPos :: !(Maybe SourcePos)
}
getAQState = getState >>= return . parseAntiQuotations
newAQState = ParseState {
atStart = True,
initialComment = "",
parseAntiQuotations = True,
pendingPragmas = [],
trailingWS = "",
leadingWS = "",
preWSPos = Nothing }
newNoAQState = ParseState {
atStart = True,
initialComment = "",
parseAntiQuotations = False,
pendingPragmas = [],
trailingWS = "",
leadingWS = "",
preWSPos = Nothing }
data WS = WSSimple { wsText :: String } | WSSingle { wsText :: String } | WSMulti { wsText :: String }
deriving Show
custWS simpleSpace oneLineComment multiLineComment = do
startPos <- getPosition
st <- getState
ws <- many ((simpleSpace >>= return . WSSimple) <|>
(oneLineComment >>= return . WSSingle) <|>
(multiLineComment >>= return . WSMulti) <?> "")
let (trailing,leading) = if atStart st then ([],ws) else extractTrailing ws
let pragmas = foldl extractPragma [] leading
let (initComment,leading') = if atStart st
then findInitialComment True [] leading
else (initialComment st, leading)
setState st { atStart = False,
initialComment = initComment,
pendingPragmas = pragmas,
trailingWS = wsCat trailing,
leadingWS = wsCat leading',
preWSPos = Just startPos }
where wsCat = concatMap showWS
showWS (WSSimple txt) = txt
showWS (WSSingle txt) = "//" ++ txt
showWS (WSMulti txt) = "/*" ++ txt ++ "*/"
extractTrailing [] = ([],[])
extractTrailing (WSSimple txt:rest) =
case break (=='\n') txt of
(ttxt,[]) -> let (t,rest') = extractTrailing rest in (WSSimple ttxt:t,rest')
([],mtxt) -> ([],WSSimple mtxt:rest)
(ttxt,mtxt) -> ([WSSimple ttxt],WSSimple mtxt:rest)
extractTrailing (ws@(WSSingle txt):rest) = ([ws],rest)
extractTrailing (ws@(WSMulti txt):rest) | '\n' `elem` txt = ([ws],rest)
| otherwise = let (t,rest') = extractTrailing rest in (ws:t,rest')
extractPragma ps (WSSingle txt) = maybe ps (:ps) (parsePragma txt)
extractPragma ps _ = ps
findInitialComment :: Bool -> [WS] -> [WS] -> (String,[WS])
findInitialComment _ rleading [] = ("",reverse rleading)
findInitialComment onNewLine rleading (ws@(WSSimple txt):wss)
| null txt = findInitialComment onNewLine rleading wss
| (onNewLine && newlines txt > 0) || newlines txt > 1 = (wsCat (reverse (ws:rleading)), wss)
| otherwise = findInitialComment (last txt == '\n') (ws:rleading) wss
findInitialComment onNewLine rleading (ws:wss) = findInitialComment False (ws:rleading) wss
newlines s = length [ c | c <- s, c == '\n']
parsePragma :: String -> Maybe Pragma
parsePragma txt =
case parse parser "" txt of
Left _ -> Nothing
Right p -> Just p
where
pragmaStyle = emptyDef { P.reservedNames = ["pragma","inline","noinlining"], P.commentLine = "--" }
lexer :: P.TokenParser ()
lexer = P.makeTokenParser pragmaStyle
reserved = P.reserved lexer
ws = P.whiteSpace lexer
parser = do
ws
reserved "pragma"
pragma <- (reserved "inline" >> return PragmaInline) <|> (reserved "noinlining" >> return PragmaNoInline)
eof
return pragma
getPreWSPos = getState >>= return . preWSPos
-- get the position after the last non-whitespace character parsed so far
getEndPosition = getPreWSPos >>= maybe getPosition return
getTrailingWS = getState >>= return . trailingWS
getLeadingWS = getState >>= return . leadingWS
-- define basic rules for lexical analysis
lslStyle = javaStyle
{ P.reservedOpNames= ["*","/","+","++","-","--","^","&","&&",
"|","||","==","=","!=","<","<=",">=",">",
"<<",">>","!","%","~","@","+=","-=","*=","/=","%="],
P.reservedNames = ["state","default","string","integer","list","vector","rotation","key","float","if","else",
"while","for","do","jump","return","default", "$import", "$module","quaternion"],
P.caseSensitive = True,
P.identStart = letter <|> char '_',
P.opLetter = oneOf "*/+:!#$%&*+/=?@\\^|-~",
P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~",
P.custWhiteSpace = Just custWS }
lexer :: P.TokenParser ParseState
lexer = P.makeTokenParser lslStyle
identLetter = P.identLetter lslStyle
identifier = P.identifier lexer
reserved = P.reserved lexer
operator = P.operator lexer
reservedOp = P.reservedOp lexer
charLiteral = P.charLiteral lexer
-- stringLiteral = P.stringLiteral lexer
natural = P.natural lexer
integer = P.integer lexer
float = P.float lexer
--naturalOrFloat = P.naturalOrFloat lexer
decimal = P.decimal lexer
hexadecimal = P.hexadecimal lexer
octal = P.octal lexer
symbol = P.symbol lexer
lexeme = P.lexeme lexer
whiteSpace = P.whiteSpace lexer
parens = P.parens lexer
braces = P.braces lexer
angles = P.angles lexer
brackets = P.brackets lexer
semi = P.semi lexer
comma = P.comma lexer
colon = P.colon lexer
dot = P.dot lexer
semiSep = P.semiSep lexer
semiSep1 = P.semiSep1 lexer
commaSep = P.commaSep lexer
commaSep1 = P.commaSep1 lexer
decimalFraction w = do char '.'
fracPart True w
fracPart reqDigit w = do digits <- (if reqDigit then many1 else many) digit <?> "fractional part of decimal"
p <- option 1.0 expon
return $ p * (w + (foldr (\ b d -> (b + d) / 10.0) 0 $ map (fromIntegral.digitToInt) digits))
expon :: GenParser Char st Double
expon = do oneOf "eE"
s <- option '+' (oneOf "+-")
let k x = if s == '+' then x else 1/x
digits <- many1 digit <?> "exponent"
let p = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt digits
return (k (10^p))
hex = do oneOf "xX"
digits <- many1 hexDigit <?> "hex digit"
return (foldl (\ b d -> b * 16 + d) 0 $ map digitToInt digits)
-- lsl doesn't support octal!
-- oct = do oneOf "oO"
-- digits <- many1 octDigit <?> "octal digit"
-- return (foldl (\ b d -> b * 8 + d) 0 $ map digitToInt digits)
-- Like Parsec 'naturalOrFloat', but accept <digits>. and .<digits><exp> as valid floating point numbers
naturalOrFloat = do v <- natOrFloat <?> "number"
whiteSpace
return v
natOrFloat = (decimalFraction 0.0 >>= return . Right)
<|> try (char '0' >> option (Left 0) prefZeroNum)
<|> decimalOrFloat
prefZeroNum = (hex >>= return . Left)
<|> (decimalFraction 0.0 >>= return . Right)
<|> decimalOrFloat
decimalOrFloat =
do wholeDigits <- many1 digit <?> "number"
let w = foldl (\ b d -> b * 10 + d) 0 $ map digitToInt wholeDigits
mf <- option Nothing (char '.' >> option (fromIntegral w) (fracPart False (fromIntegral w)) >>= return . Just)
case mf of
Nothing -> try ( expon >>= \ p -> return $ Right (fromIntegral w * p) ) <|> (return $ Left w)
Just f -> return $ Right f
stringLiteral = lexeme (
do{ str <- between (char '"')
(char '"' <?> "end of string")
(many stringChar)
; return (foldr (maybe id (:)) "" str)
}
<?> "literal string")
stringChar :: CharParser st (Maybe Char)
stringChar = do{ c <- stringLetter; return (Just c) }
<|> try stringEscape
<|> (char '\\' >> return (Just '\\'))
<?> "string character"
stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
stringEscape = do
char '\\'
choice [char 't' >> return (Just '\t'),
char 'n' >> return (Just '\n'),
char '\"' >> return (Just '\"'),
char '\\' >> return (Just '\\')]
--- EXPRESSION PARSING -------------------------------------------------------
--mtrace s v = return v -- trace (s ++ show v) (return v)
mtrace s v =
-- trace (s ++ show v)
(return v)
combineExprs e [] = e
combineExprs e0 ((p0,p1,op,e1):rest) = combineExprs (op p0 p1 e0 e1) rest
isFollowedBy p = do
lookAhead p
return ()
reservedOp' name =
lexeme $ try $
do{ string name
; ( (isFollowedBy (char '-')) <|> notFollowedBy (P.opLetter lslStyle)) <?> ("end of " ++ show name)
}
opmatch s f = (reservedOp s >> return f)
opmatch' s f = (reservedOp' s >> return f)
op0 = ((opmatch' "*" mulop) <|> (opmatch' "/" divop) <|> (opmatch' "%" modop)) <?> "operator"
op1 = ((opmatch' "+" addop) <|> (opmatch "-" subop)) <?> "operator"
op2 = ((opmatch' "<<" shiftlop) <|> (opmatch' ">>" shiftrop)) <?> "operator"
op3 = (choice [opmatch' "<" ltop, opmatch' "<=" leop, opmatch' ">" gtop, opmatch' ">=" geop]) <?> "operator"
op4 = ((opmatch' "==" eqop) <|> (opmatch' "!=" neop)) <?> "operator"
opAndExpr opf ef = do pos0 <- getPosition
op <- opf
pos1 <- getPosition
e <- ef
return (pos0,pos1,op,e)
exprChain opf ef = do e0 <- ef
rest <- many (opAndExpr opf ef)
return $ combineExprs e0 rest
mulExpr = exprChain op0 expr2
addExpr = exprChain op1 mulExpr
shiftExpr = exprChain op2 addExpr
relExpr = do e0 <- shiftExpr
rest <- (try (many (try (opAndExpr op3 shiftExpr))) <|> return [])
return $ combineExprs e0 rest
eqExpr = exprChain op4 relExpr
bandExpr = exprChain (opmatch' "&" bandop <?> "operator") eqExpr
xorExpr = exprChain (opmatch' "^" xorop <?> "operator") bandExpr
borExpr = exprChain (opmatch' "|" borop <?> "operator") xorExpr
andExpr = exprChain (opmatch' "&&" andop <?> "operator") borExpr
orExpr = exprChain (opmatch' "||" orop <?> "operator") andExpr
bop op pos0 pos1 e0 e1 =
let ctx = combineContexts (srcCtx e0, pos0, pos1, srcCtx e1) in Ctx ctx $ op e0 e1
mulop pos0 pos1 = bop Mul pos0 pos1
divop pos0 pos1 = bop Div pos0 pos1
modop pos0 pos1 = bop Mod pos0 pos1
addop pos0 pos1 = bop Add pos0 pos1
subop pos0 pos1 = bop Sub pos0 pos1
shiftlop pos0 pos1 = bop ShiftL pos0 pos1
shiftrop pos0 pos1 = bop ShiftR pos0 pos1
ltop pos0 pos1 = bop Lt pos0 pos1
leop pos0 pos1 = bop Le pos0 pos1
gtop pos0 pos1 = bop Gt pos0 pos1
geop pos0 pos1 = bop Ge pos0 pos1
eqop pos0 pos1 = bop Equal pos0 pos1
neop pos0 pos1 = bop NotEqual pos0 pos1
bandop pos0 pos1 = bop BAnd pos0 pos1
xorop pos0 pos1 = bop Xor pos0 pos1
borop pos0 pos1 = bop BOr pos0 pos1
andop pos0 pos1 = bop And pos0 pos1
orop pos0 pos1 = bop Or pos0 pos1
structAccess = do id <- ctxify identifier
whiteSpace
dot
whiteSpace
c <- oneOf "xyzs"
whiteSpace
return (id,stringToComponent [c])
var = try structAccess
<|> do id <- ctxify identifier
return (id,All)
assignment = ctxify $
do v <- var
op <- choice [reservedOp' "+=" >> (return IncBy),
reservedOp' "-=" >> (return DecBy),
reservedOp' "*=" >> (return MulBy),
reservedOp' "/=" >> (return DivBy),
reservedOp' "%=" >> (return ModBy),
reservedOp' "=" >> (return Set)] <?> "assignment operator"
e <- expr
return $ op v e
stringToComponent "" = All
stringToComponent "x" = X
stringToComponent "y" = Y
stringToComponent "z" = Z
stringToComponent "s" = S
listExpr = do whiteSpace
exprs <- (brackets $ commaSep expr) <?> "list expression"
return $ ListExpr exprs
-- there's a conflict between a relational expression embedded in the last component of a vector/rotation and the
-- the normal end of the expression... in particular:
-- v = <1,1,1 > -<1,2,3>>;
-- is not a syntax error (but is a type error), but you can't tell the difference between that and
-- v = <1,1,1 > -<1,2,3>;
-- which is the difference between two vectors (which is both syntactically correct and type correct) until you
-- parse the ';'. So the complexity of the grammar here exists to disambiguate these cases (which requires a
-- bit of lookahead...)
structStart = do whiteSpace
char '<' <?> "vector/rotation expression"
whiteSpace
e1 <- expr
mtrace "structExpr:1 " e1
char ','
whiteSpace
e2 <- expr
mtrace "structExpr:2 " e2
char ',' >> whiteSpace
return (e1,e2)
vecRotExpr = do (x,y) <- structStart
((try (do z <- expr
char ',' >> whiteSpace
s <- tailStruct
return $ RotExpr x y z s)) <|>
(do z <- tailStruct
return $ VecExpr x y z))
tailStruct = (try (do e <- expr
char '>' >> whiteSpace
return e))
<|> (do e <- shiftExpr
char '>' >> whiteSpace
return e)
callExpr = do
name <- ctxify identifier
exprs <- parens $ commaSep expr
return $ Call name exprs
castExpr = ctxify $
do t <- parens typeName
e <- choice [try postfixExpr, atomicExpr]
return $ Cast t e
ctxify f = do
pragmas <- getState >>= return . pendingPragmas
pre <- getLeadingWS
pos0 <- getPosition
v <- f
pos1 <- getEndPosition
post <- getTrailingWS
return $ Ctx (pos2Ctx (pos0,pos1) pre post pragmas) v
notExpr = ctxify ((char '!' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Not)
invExpr = ctxify ((char '~' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Inv)
negExpr = ctxify ((char '-' <?> "prefix operator") >> whiteSpace >> expr2 >>= return.Neg)
atomicExpr = do
aq <- getAQState
(ctxify $
try ( do m <- option 1 (reservedOp "-" >> return (-1))
n <- naturalOrFloat
return $ case n of
Left nat -> (IntLit $ m * fromIntegral nat)
Right flt -> (FloatLit $ fromRational $ toRational m * toRational flt)))
<|> (ctxify (stringLiteral >>= return.StringLit))
<|> (if aq then (ctxify (reservedOp "$string:" >> identifier >>= return . AQString)) else fail "")
<|> (if aq then (ctxify (reservedOp "$integer:" >> identifier >>= return . AQInteger)) else fail "")
<|> (if aq then (ctxify (reservedOp "$key:" >> identifier >>= return . AQKey)) else fail "")
<|> (if aq then (ctxify (reservedOp "$float:" >> identifier >>= return . AQFloat)) else fail "")
<|> (ctxify listExpr)
<|> (ctxify vecRotExpr)
<|> (ctxify $ try callExpr)
<|> (ctxify $ do v <- var
return $ Get v)
<|> parens expr
postfixExpr = ctxify $
do v <- var
f <- choice [reservedOp' "++" >> return PostInc,
reservedOp' "--" >> return PostDec] <?> "postfix operator"
return $ f v
prefixExpr = ctxify $
do f <- choice [reservedOp "--" >> return (PreDec),
reservedOp "++" >> return PreInc] <?> "prefix operator"
v <- var
return $ f v
unaryExpr = choice [try prefixExpr,notExpr,invExpr, negExpr,try castExpr,atomicExpr]
expr2 :: GenParser Char ParseState (Ctx Expr)
expr2 = choice [try assignment, try postfixExpr, unaryExpr]
expr1 = orExpr
expr :: GenParser Char ParseState (Ctx Expr)
expr =
do r <- choice [try assignment, expr1]
mtrace "expr: " r
exprParser :: String -> Either ParseError (Ctx Expr)
exprParser text = runParser (whiteSpace>>expr) newNoAQState "" text
------------------------------------------------------------------------------
-- STATEMENT PARSING
statements = do whiteSpace
many (ctxify statement)
statement = declStatement
<|> returnStatement
<|> jumpStatement
<|> labelStatement
<|> exprStatement
<|> blockStatement
<|> nullStatement
<|> whileStatement
<|> ifElseStatement
<|> stateStatement
<|> doWhileStatement
<|> forStatement
declStatement = do t <- typeName
id <- identifier
rest <- (option Nothing (reservedOp' "=" >> expr >>= return . Just))
semi
return $ Decl (Var id t) rest
integerType = (reserved "integer" >> return LLInteger)
floatType = (reserved "float" >> return LLFloat)
keyType = (reserved "key" >> return LLKey)
vectorType = (reserved "vector" >> return LLVector)
stringType = (reserved "string" >> return LLString)
rotationType = ((reserved "rotation"<|>reserved "quaternion") >> return LLRot)
listType = (reserved "list" >> return LLList)
typeName = choice [integerType,floatType,keyType,vectorType,stringType,rotationType,listType]
returnStatement = do reserved "return"
e <- (option Nothing (expr >>= return . Just))
semi
return $ Return e
jumpStatement = do reserved "jump"
id <- identifier
semi
return $ Jump id
labelStatement = do reservedOp "@"
id <- identifier
semi
return $ Label id
exprStatement = do e <- expr
semi
return $ Do e
blockStatement = do stmts <- braces statements
return $ Compound stmts
nullStatement = (semi >> return NullStmt)
whileStatement = do reserved "while"
e <- parens expr
stmt <- ctxify statement
return $ While e stmt
ifElseStatement = do reserved "if"
e <- parens expr
stmt1 <- ctxify statement
stmt2 <- (option (nullCtx NullStmt) (reserved "else" >> ctxify statement))
return $ If e stmt1 stmt2
stateStatement = do reserved "state"
id <- (identifier <|> (reserved "default" >> return "default"))
semi
return $ StateChange id
forStatement = do reserved "for"
char '('
whiteSpace
mexpr1 <- commaSep expr
semi
mexpr2 <- option Nothing (expr >>= return . Just)
semi
mexpr3 <- commaSep expr
char ')'
whiteSpace
stmt <- ctxify statement
return $ For mexpr1 mexpr2 mexpr3 stmt
doWhileStatement = do reserved "do"
stmt <- ctxify statement
reserved "while"
e <- parens expr
semi
return $ DoWhile stmt e
parseType text = runParser typeName newNoAQState "" text
------------------------------------------------------------
-- HANDLER Parsing
hparam theType = ctxify $
do t <- (typeParser theType)
id <- identifier
return $ Var id t
typeParser LLInteger = integerType
typeParser LLFloat = floatType
typeParser LLList = listType
typeParser LLString = stringType
typeParser LLVector = vectorType
typeParser LLKey = keyType
typeParser LLRot = rotationType
hparams [] = return []
hparams (theType:[]) = (hparam theType >>= return . (:[]))
hparams (theType:ts) = do p <- hparam theType
comma
ps <- hparams ts
return (p:ps)
handlerName name = try (do id <- symbol name; notFollowedBy identLetter; return id)
handler' name types =
ctxify $ do ctxname <- ctxify $ handlerName name
parms <- parens (hparams types)
stmts <- braces statements
return $ Handler ctxname parms stmts
handler = choice $ map (\ (n,ts) -> handler' n ts) goodHandlers
-------------------------------------------------------------
-- STATE parsing
stateName = choice [reserved "default" >> return "default" , reserved "state" >> identifier]
stateDecl = do ctxify $ do
name <- ctxify stateName
handlers <- braces $ many handler
return $ State name handlers
stateDecls = many stateDecl
--------------------------------------------------------------
varOrFunc = do pos0 <- getPosition
pre <- getLeadingWS
pragmas <- getState >>= return . pendingPragmas
(Ctx ctx (t,id)) <- ctxify $ do
t <- try typeName
id <- ctxify identifier <?> "identifier"
return (t,id)
choice [func t id pragmas pos0 pre, gvar ctx t id]
<|> do pos0 <- getPosition
pre <- getLeadingWS
pragmas <- getState >>= return . pendingPragmas
id <- ctxify identifier <?> "identifier"
func LLVoid id pragmas pos0 pre
func t id pragmas pos0 pre =
do ps <- parens params
stmts <- braces statements
pos1 <- getEndPosition
post <- getTrailingWS
return $ GF $ Ctx (pos2Ctx (pos0, pos1) pre post pragmas) $ Func (FuncDec id t ps) stmts
---------------------------------------------------------------
-- GLOBAL VARIABLES parsing
gvar ctx t (Ctx _ id) = do mexpr <- option Nothing (reservedOp' "=" >> expr >>= return . Just)
semi
return $ GV (Ctx ctx (Var id t)) mexpr
--------------------------------------------------------------
-- FUNCTION parsing
param = ctxify $
do t <- typeName
id <- identifier
return $ Var id t
params = commaSep param
----------------------------------------------------------------
-- IMPORT (meta-lsl directive) parsing
gimport = do reserved "$import" <?> "$import keyword"
ids <- (ctxify (char '$' >> identifier >>= return . (:[]) . ("$"++)))
<|>(ctxify $ sepBy identifier dot)
let id = fmap (concat . intersperse ".") ids
let binding = do id0 <- identifier
reservedOp "="
id1 <- identifier
return (id0,id1)
bindings <- option [] $ parens $ commaSep binding
prefix <- option "" identifier
semi
return $ GI id bindings prefix
---------------------------------------------------------------------------------------------------
-- all globals parsing
global = choice [gimport,varOrFunc]
globals = many global
lslParser = do whiteSpace
globs <- globals
ss <- stateDecls
eof
comment <- getState >>= return . initialComment
return $ LSLScript comment globs ss
moduleParser = do whiteSpace
reserved "$module"
freevars <- option [] $ parens params
globs <- globals
eof
return $ LModule globs freevars
-- error recovering parser?
data PResult a = PResult {
resultInput :: !String,
resultPosition :: !SourcePos,
resultItem :: !a }
-- stateInitial = do
-- name <- ctxify stateName
-- lexeme (char '{')
-- hs <- many $ try handler
-- return (State name hs)
withRest a p = do
setPosition p
v <- a
st <- getParserState
return PResult { resultInput = stateInput st, resultPosition = statePos st, resultItem = v }
-- parsePartialInitial = withRest $ do
-- whiteSpace
-- name <- ctxify stateName
-- lexeme (char '{')
-- hs <- many $ try handler
-- return (State name hs)
-- parse as many globals then states without failing
parseGreedy1 = withRest $
(do try whiteSpace
gs <- many $ try global
ss <- many $ try stateDecl
return (gs,ss)) <|> return ([],[])
-- parse one global or state
parseStrict1 = withRest $
do whiteSpace
v <- choice [global >>= return . Left, stateDecl >>= return . Right]
return v
parsePartial = withRest $
ctxify $
do whiteSpace
name <- ctxify stateName
lexeme (char '{')
hs <- many $ try handler
return (State name hs)
parseResume = withRest $ ctxify (
(do whiteSpace
hs <- many $ try handler
lexeme (char '}')
ss <- many $ try stateDecl
return (hs,ss)) <|> -- failed to find end of state
(do whiteSpace
s <- stateDecl
ss <- many $ try stateDecl
return ([],s:ss)))
parseGreedy2 = withRest $
(do try whiteSpace
many $ try stateDecl) <|> return []
parseStrict2 = withRest stateDecl
alternateScriptParser srcName string = goGreedy1 False ([],[],[]) (initialPos "") string
where doParse p pos = runParser (p pos) newNoAQState srcName
goGreedy1 _ (gs,ss,errs) pos [] = (LSLScript "" gs ss, reverse errs)
goGreedy1 skipErr (gs,ss,errs) pos s =
case doParse parseGreedy1 pos s of
Left err -> error ("parseGreedy1 should never return an error, but returned: " ++ show err)
Right (PResult [] _ (gs',ss')) -> (LSLScript "" (gs ++ gs') (ss ++ ss'),errs)
Right (PResult rest pos' (gs',ss')) -> goStrict1 False (gs ++ gs',ss ++ ss',errs) pos' rest
goStrict1 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs)
goStrict1 skipErr (gs,ss,errs) pos s@(c:cs) =
case doParse parseStrict1 pos s of
Left err -> goPartial1 True (gs,ss,if skipErr then errs else err:errs) pos s
Right (PResult rest pos' (Left g)) -> goGreedy1 False (gs ++ [g],ss,errs) pos' rest
Right (PResult rest pos' (Right s)) -> goGreedy2 False (gs,ss ++ [s], errs) pos' rest
goPartial1 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs)
goPartial1 skipErr (gs,ss,errs) pos s@(c:cs) =
case doParse parsePartial pos s of
Left err -> goStrict1 True (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs
Right (PResult rest pos' state) -> goResume True state (gs,ss, errs) pos' rest
goResume skipErr state (gs,ss,errs) _ [] = (LSLScript "" gs (ss ++ [state]),reverse errs)
goResume skipErr state@(Ctx c0 (State nm hs)) (gs,ss,errs) pos s@(c:cs) =
case doParse parseResume pos s of
Left err -> goResume True state (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs
Right (PResult rest pos' (Ctx c1 (hs',ss'))) ->
goGreedy2 False (gs,ss ++ (Ctx (combineContexts1 c0 c1) (State nm (hs ++ hs')):ss'),errs) pos' rest
goGreedy2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs)
goGreedy2 skipErr (gs,ss,errs) pos s =
case doParse parseGreedy2 pos s of
Left err -> error ("parseGreedy2 parser should never return an error, but returned: " ++ show err)
Right (PResult [] _ ss') -> (LSLScript "" gs (ss ++ ss'),reverse errs)
Right (PResult rest pos' ss') -> goStrict2 True (gs,ss ++ ss',errs) pos' rest
goStrict2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs)
goStrict2 skipErr (gs,ss,errs) pos s@(c:cs) =
case doParse parseStrict2 pos s of
Left err -> goPartial2 True (gs,ss,if skipErr then errs else err:errs) pos s
Right (PResult rest pos' s) -> goGreedy2 False (gs,ss ++ [s],errs) pos rest
goPartial2 skipErr (gs,ss,errs) _ [] = (LSLScript "" gs ss,reverse errs)
goPartial2 skipErr (gs,ss,errs) pos s@(c:cs) =
case doParse parsePartial pos s of
Left err -> goStrict2 True (gs,ss,if skipErr then errs else err:errs) (updatePosChar pos c) cs
Right (PResult rest pos' state) -> goResume True state (gs,ss,errs) pos' rest
alternateModuleParser srcName string = goStart string
where doParse p pos = runParser (p pos) newNoAQState srcName
startPos = initialPos ""
goStart s =
case doParse parseStart startPos s of
Left err -> goStrict True ([],[],[err]) startPos s
Right (PResult rest pos freevars) -> goGreedy False (freevars,[],[]) pos rest
goGreedy _ (fv,gs,errs) _ [] = (LModule gs fv, errs)
goGreedy skip (fv,gs,errs) pos s =
case doParse parseGreedy pos s of
Left err -> error ("the greedy parser should never return an error, but returned: " ++ show err)
Right (PResult [] _ gs') -> (LModule (gs ++ gs') fv, reverse errs)
Right (PResult rest pos' gs') -> goStrict False (fv,gs ++ gs',errs) pos' rest
goStrict skip (fv,gs,errs) pos [] = (LModule gs fv, reverse errs)
goStrict skip (fv,gs,errs) pos s@(c:cs) =
case doParse parseStrict pos s of
Left err -> goStrict True (fv,gs,if skip then errs else err:errs) (updatePosChar pos c) cs
Right (PResult rest pos' gs') -> goGreedy False (fv,gs ++ [gs'], errs) pos' rest
parseGreedy = withRest $ many (try global)
parseStrict = withRest global
parseStart = withRest $ do
whiteSpace
reserved "$module"
option [] $ parens params
-----------------------------------------------------------------------------
parseFromString parser string =
case runParser parser newNoAQState "" string of
Left err -> Left (snd (fromParseError err))
Right x -> Right x
-- | Parse an LSL script into its syntax tree.
parseScriptFromString :: String -> Either String LSLScript
parseScriptFromString s = parseFromString lslParser s
-- | Parse an LSL (Plus) module into its syntax tree.
parseModuleFromString :: String -> Either String LModule
parseModuleFromString s = parseFromString moduleParser s
-- | Parse an LSL script, with possible antiquotations, into its syntax tree.
parseScriptFromStringAQ :: String -> Either ParseError LSLScript
parseScriptFromStringAQ s = runParser lslParser newAQState "" s
-- | Parse an LSL (Plus) module, with possible antiquotations, into its syntax tree.
parseModuleFromStringAQ :: String -> Either ParseError LModule
parseModuleFromStringAQ s = runParser moduleParser newAQState "" s
parseModule :: SourceName -> IO (Either (Maybe SourceContext,String) LModule)
parseModule file = parseFile moduleParser file
parseScript file = parseFile lslParser file
fromParseError :: ParseError -> (Maybe SourceContext,String)
fromParseError err =
let pos = errorPos err
msg = showErrorMessages "or" "unknown parse error"
"expecting" "unexpected" "end of input" (errorMessages err)
in (Just $ SourceContext TextLocation { textLine0 = sourceLine pos, textColumn0 = sourceColumn pos,
textLine1 = sourceLine pos, textColumn1 = sourceColumn pos,
textName = sourceName pos }
"" "" [],
msg)
parseFile p file =
do s <- B.readFile file >>= return . UTF8.toString
case parser s of
Left err -> return $ Left (fromParseError err)
Right x -> return $ Right x
where parser = runParser p newNoAQState file
pos2Loc (pos0,pos1) pre post =
SourceContext TextLocation {
textName = sourceName pos0,
textColumn0 = sourceColumn pos0,
textLine0 = sourceLine pos0,
textColumn1 = sourceColumn pos1,
textLine1 = sourceLine pos1
} pre post []
pos2Ctx (pos0,pos1) pre post pragmas =
Just (pos2Loc (pos0,pos1) "" "") { srcPreText = pre, srcPostTxt = post, srcPragmas = pragmas }
combineContexts (Nothing,pos0,pos1,Nothing) = Just $ pos2Loc (pos0,pos1) "" ""
combineContexts (Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre _ prag),_,
_,Just (SourceContext (TextLocation l0' c0' l1' c1' n') _ post _ )) =
Just $ SourceContext (TextLocation l0 c0 l1' c1' n) pre post prag
combineContexts (Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag),_,pos,_) =
Just $ SourceContext (TextLocation l0 c0 (sourceLine pos) (sourceColumn pos) n) pre post prag
combineContexts (_,pos,_,Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag)) =
Just $ SourceContext (TextLocation (sourceLine pos) (sourceColumn pos) l1 c1 n) pre post prag
combineContexts1 Nothing _ = Nothing
combineContexts1 _ Nothing = Nothing
combineContexts1
(Just (SourceContext (TextLocation l0 c0 _ _ n) pre _ prag))
(Just (SourceContext (TextLocation _ _ l1 c1 _) _ post _)) =
(Just (SourceContext (TextLocation l0 c0 l1 c1 n) pre post prag))
tst = [$here|@
integer foo() {
return 1;
}
@
default {
state_entry() {
}
}
|]
tst1 = [$here|
integer foo() {
return 1;
}
default {
@
state_entry() {
}
}
|]
tst2 = [$here|
@
$module (integer x)
integer foo() {
}
|]
tst3 = [$here|
integer foo() {
return 0;
}
default {
state_entry() {
llOwnerSay();
}
}
state boo {
}
|]