module Agda.Compiler.JS.Parser where
import Prelude hiding ( exp, lookup )
import Data.List ( genericLength )
import Data.Char ( isLetter, isAlphaNum, isDigit )
import Data.Map ( Map, fromList, union, empty )
import qualified Data.Map as M
import Agda.Utils.ReadP
( ReadP, (+++), (<++), between, char, choice, look, many,
munch, munch1, parse', pfail, satisfy, sepBy, string, skipSpaces )
import Agda.Syntax.Common ( Nat )
import Agda.Compiler.JS.Syntax
( LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId),
Exp(Local,Global,Undefined,String,Integer,Lambda,Apply,Object,Lookup,If,BinOp,PreOp,Const) )
type Parser = ReadP Char
identifier :: Parser String
identifier = do
c <- satisfy isLetter
cs <- munch isAlphaNum
skipSpaces
return (c : cs)
wordBoundary :: Parser ()
wordBoundary = do
cs <- look
case cs of
(c:_) | isAlphaNum c -> pfail
_ -> return ()
token :: String -> Parser ()
token s = string s >> wordBoundary >> skipSpaces
punct :: Char -> Parser ()
punct c = char c >> skipSpaces
parened :: Parser a -> Parser a
parened = between (punct '(') (punct ')')
braced :: Parser a -> Parser a
braced = between (punct '{') (punct '}')
bracketed :: Parser a -> Parser a
bracketed = between (punct '[') (punct ']')
quoted :: Parser a -> Parser a
quoted = between (char '"') (punct '"')
stringLit :: Parser Exp
stringLit = do s <- stringStr; return (String s)
stringStr :: Parser String
stringStr = quoted (many stringChr)
stringChr :: Parser Char
stringChr = satisfy (`notElem` "\\\"") +++ escChr
escChr :: Parser Char
escChr = char '\\' >> (
(char 'n' >> return '\n') +++
(char 'r' >> return '\r') +++
(char 't' >> return '\t') +++
(char '"' >> return '"') +++
(char '\\' >> return '\\')
)
intLit :: Parser Exp
intLit = do s <- munch1 isDigit; skipSpaces; return (Integer (read s))
undef :: Parser Exp
undef = token "undefined" >> return Undefined
localid :: (Map String Nat) -> Parser Exp
localid m = do
s <- identifier
case M.lookup s m of
Nothing -> return (Const s)
Just i -> return (Local (LocalId i))
globalid :: Parser Exp
globalid = do
token "require"
i <- parened (quoted (sepBy (munch1 isAlphaNum) (char '.')))
return (Global (GlobalId i))
preop :: Parser String
preop = do
op <- choice (map string [ "+", "-", "!" ])
skipSpaces
return op
binop :: Parser String
binop = do
op <- choice (map string [
"<", ">", "<=", ">=", "==", "===", "<<", ">>",
"<<<", ">>>", "!=", "!==", "+", "-", "*", "%", "/",
"&", "&&", "|", "||", "^"
])
skipSpaces
return op
field :: (Map String Nat) -> Parser (MemberId,Exp)
field m = do
l <- stringStr
punct ':'
e <- exp m
return (MemberId l, e)
object :: (Map String Nat) -> Parser Exp
object m = do
o <- braced (sepBy (field m) (punct ','))
return (Object (fromList o))
function :: (Map String Nat) -> Parser Exp
function m = do
token "function"
xs <- parened (sepBy identifier (punct ','))
n <- return (genericLength xs)
m' <- return (union (fromList (zip xs [n1,n2..0])) (M.map (+n) m))
e <- bracedBlock m'
return (Lambda n e)
bracedBlock :: (Map String Nat) -> Parser Exp
bracedBlock m = braced (returnBlock m +++ ifBlock m +++ bracedBlock m)
returnBlock :: (Map String Nat) -> Parser Exp
returnBlock m = between (token "return") (punct ';') (exp m)
ifBlock :: (Map String Nat) -> Parser Exp
ifBlock m = do
token "if"
e <- parened (exp m)
f <- bracedBlock m
token "else"
g <- (ifBlock m +++ bracedBlock m)
return (If e f g)
exp0 :: (Map String Nat) -> Parser Exp
exp0 m = function m <++ undef <++ globalid <++ localid m <++
object m <++ stringLit <++ intLit <++ parened (exp m)
exp1 :: (Map String Nat) -> Parser Exp
exp1 m =
(do op <- preop; e <- exp1 m; return (PreOp op e)) <++
(exp0 m)
exp2 :: (Map String Nat) -> Parser Exp
exp2 m = exp1 m >>= exp2' m
exp2' :: (Map String Nat) -> Exp -> Parser Exp
exp2' m e =
(do es <- parened (sepBy (exp m) (punct ',')); exp2' m (Apply e es)) <++
(do i <- bracketed stringStr; exp2' m (Lookup e (MemberId i))) <++
(do punct '.'; i <- identifier; exp2' m (Lookup e (MemberId i))) <++
(do op <- binop; f <- exp0 m; exp2' m (BinOp e op f)) <++
(return e)
exp3 :: (Map String Nat) -> Parser Exp
exp3 m = exp2 m >>= exp3' m
exp3' :: (Map String Nat) -> Exp -> Parser Exp
exp3' m e =
(do punct '?'; f <- exp2 m; punct ':'; g <- exp2 m; return (If e f g)) <++
(return e)
exp :: (Map String Nat) -> Parser Exp
exp = exp3
topLevel :: Parser Exp
topLevel = skipSpaces >> exp empty
parse :: String -> Either Exp String
parse = parse' topLevel