205 lines
No EOL
4.4 KiB
Haskell
205 lines
No EOL
4.4 KiB
Haskell
-- Parser for the Lamb programming language
|
|
-- Copyright (c) 2013 darkf
|
|
-- Licensed under the terms of the zlib license, see LICENSE for details
|
|
|
|
module Parser where
|
|
|
|
import Text.Parsec
|
|
import Text.Parsec.String
|
|
import Text.Parsec.Expr
|
|
import qualified Text.Parsec.Token as T
|
|
import Text.Parsec.Language
|
|
import AST
|
|
|
|
languageDef = emptyDef {T.commentStart="{-",
|
|
T.commentEnd="-}",
|
|
T.commentLine="--",
|
|
T.nestedComments=True,
|
|
T.identStart = letter <|> char '_',
|
|
T.identLetter = alphaNum <|> char '_' <|> char '\'' <|> char '!' <|> char '?',
|
|
T.reservedNames = ["do", "end"],
|
|
T.reservedOpNames = ["+", "-", "*", "/", "==", "!=", "<", ">"]}
|
|
|
|
lexer = T.makeTokenParser languageDef
|
|
exprparser = buildExpressionParser ops term <?> "expression"
|
|
ops = [ [Infix (reservedOp "*" >> return Mul) AssocLeft]
|
|
, [Infix (reservedOp "/" >> return Div) AssocLeft]
|
|
, [Infix (reservedOp "+" >> return Add) AssocLeft]
|
|
, [Infix (reservedOp "-" >> return Sub) AssocLeft]
|
|
|
|
, [Infix (reservedOp "==" >> return Equals) AssocLeft]
|
|
, [Infix (reservedOp "!=" >> return NotEquals) AssocLeft]
|
|
, [Infix (reservedOp "<" >> return LessThan) AssocLeft]
|
|
, [Infix (reservedOp ">" >> return GreaterThan) AssocLeft]
|
|
]
|
|
|
|
identifier = T.identifier lexer
|
|
reserved = T.reserved lexer
|
|
reservedOp = T.reservedOp lexer
|
|
parens = T.parens lexer
|
|
integer = T.integer lexer
|
|
semi = T.semi lexer
|
|
whiteSpace = T.whiteSpace lexer
|
|
symbol = T.symbol lexer
|
|
|
|
statement = exprparser
|
|
|
|
-- http://codereview.stackexchange.com/a/2572
|
|
stringChar =
|
|
escaped <|> noneOf "\""
|
|
where
|
|
escaped = char '\\' >> choice (zipWith escapedChar codes replacements)
|
|
escapedChar code replacement = char code >> return replacement
|
|
codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
|
|
replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
|
|
|
|
stringLiteral = do
|
|
char '"'
|
|
x <- many stringChar
|
|
char '"'
|
|
whiteSpace
|
|
return x
|
|
|
|
block = do
|
|
reserved "do"
|
|
lst <- seqStmt
|
|
reserved "end"
|
|
return $ Block lst
|
|
|
|
listSeq p cons = do
|
|
symbol "["
|
|
lst <- sepBy p (symbol ",")
|
|
symbol "]"
|
|
return $ cons lst
|
|
|
|
tupleSeq p cons = do
|
|
symbol "("
|
|
lst <- sepBy1 p (symbol ",")
|
|
symbol ")"
|
|
return $ cons lst
|
|
|
|
emptyTuple cons = do
|
|
symbol "("
|
|
symbol ","
|
|
symbol ")"
|
|
return $ cons []
|
|
|
|
intPattern = fmap IntP integer
|
|
varPattern = fmap VarP identifier
|
|
stringPattern = fmap StrP stringLiteral
|
|
listPattern = listSeq pattern ListP
|
|
|
|
consPattern = do
|
|
x <- intPattern <|> varPattern <|> stringPattern <|> try (tupleSeq pattern TupleP)
|
|
symbol "::"
|
|
y <- pattern
|
|
return $ ConsP x y
|
|
|
|
pattern = try consPattern
|
|
<|> try (emptyTuple TupleP)
|
|
<|> try (tupleSeq pattern TupleP)
|
|
<|> listPattern
|
|
<|> varPattern
|
|
<|> intPattern
|
|
<|> stringPattern
|
|
|
|
patterns = sepBy pattern (symbol ",")
|
|
|
|
funDef = do
|
|
name <- identifier
|
|
symbol "("
|
|
pats <- patterns
|
|
let pat = (case pats of
|
|
[] -> UnitP
|
|
[a] -> a
|
|
otherwise -> TupleP pats)
|
|
symbol ")"
|
|
symbol "->"
|
|
body <- exprparser
|
|
return $ Defun name $ Lambda [(pat, body)]
|
|
|
|
lambda = do
|
|
symbol "\\"
|
|
pats <- patterns
|
|
let pat = (case pats of
|
|
[] -> UnitP
|
|
[a] -> a
|
|
otherwise -> TupleP pats)
|
|
symbol "->"
|
|
body <- exprparser
|
|
return $ Lambda [(pat, body)]
|
|
|
|
call p argp = do
|
|
lhs <- p
|
|
whiteSpace
|
|
symbol "("
|
|
args <- sepBy argp (symbol ",")
|
|
let arg = (case args of
|
|
[] -> UnitConst
|
|
[a] -> a
|
|
otherwise -> TupleConst args)
|
|
symbol ")"
|
|
return $ Call lhs arg
|
|
|
|
consExpr = do
|
|
x <- expr3
|
|
symbol "::"
|
|
y <- exprparser
|
|
return $ Cons x y
|
|
|
|
ifExpr = do
|
|
symbol "if"
|
|
cond <- exprparser
|
|
symbol "then"
|
|
t <- exprparser
|
|
symbol "else"
|
|
e <- exprparser
|
|
return $ IfExpr cond t e
|
|
|
|
bool = fmap BoolConst $ (symbol "true" >> return True) <|> (symbol "false" >> return False)
|
|
|
|
def = do
|
|
pat <- pattern
|
|
whiteSpace
|
|
symbol "="
|
|
value <- exprparser
|
|
return $ Def pat value
|
|
|
|
-- field access
|
|
accessOp = do
|
|
symbol "/"
|
|
return Access
|
|
|
|
expr1 = try block
|
|
<|> try lambda
|
|
<|> try def
|
|
<|> try (emptyTuple TupleConst)
|
|
<|> try (tupleSeq exprparser TupleConst)
|
|
<|> parens exprparser
|
|
<|> listSeq exprparser ListConst
|
|
<|> try ifExpr
|
|
<|> try bool
|
|
<|> fmap Var identifier
|
|
<|> fmap StrConst stringLiteral
|
|
<|> fmap IntConst integer
|
|
|
|
expr2 = try $ chainl1 expr1 accessOp
|
|
<|> expr1
|
|
|
|
expr3 = try funDef
|
|
<|> try (call expr2 exprparser)
|
|
<|> expr2
|
|
|
|
term = try consExpr
|
|
<|> expr3
|
|
|
|
seqStmt = sepBy1 statement semi
|
|
|
|
program =
|
|
many1 $ do
|
|
whiteSpace
|
|
e <- exprparser
|
|
symbol "."
|
|
return e
|
|
|
|
parseProgram = parse program "program" |