add initial parser

This commit is contained in:
darkf 2013-10-18 23:22:42 -07:00
parent 54ea8baa54
commit 5b4118ef8c
1 changed files with 85 additions and 0 deletions

85
parser.hs Normal file
View File

@ -0,0 +1,85 @@
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 '_',
T.reservedNames = ["do", "end", "(", ")", ";", "."],
T.reservedOpNames = ["+", "*"]}
lexer = T.makeTokenParser languageDef
exprparser = buildExpressionParser ops term <?> "expression"
ops = [ [Infix (reservedOp "*" >> return Mul) AssocLeft ]
, [Infix (reservedOp "+" >> return Add) AssocLeft]
]
identifier = T.identifier lexer -- parses an identifier
reserved = T.reserved lexer -- parses a reserved name
reservedOp = T.reservedOp lexer -- parses an operator
parens = T.parens lexer -- parses surrounding parenthesis
integer = T.integer lexer -- parses an integer
semi = T.semi lexer -- parses a semicolon
whiteSpace = T.whiteSpace lexer -- parses whitespace
symbol = T.symbol lexer
statement =
do
e <- exprparser
-- char ';'
return e
block = do
reserved "do"
lst <- seqStmt
reserved "end"
return $ Block lst
funDef = do
name <- identifier
reserved "("
reserved ")"
reserved "->"
lst <- exprparser
return $ rewriteFun (FunDef name (UnitP, lst))
-- curry FunDef to a definition of lambdas
rewriteFun (FunDef name (pattern, body)) =
Def name $ Lambda [(pattern, [body])]
call = do
name <- identifier
whiteSpace
char '('
char ')'
whiteSpace
return $ Call name [UnitConst]
term = block
<|> try funDef
<|> try call
<|> parens exprparser
<|> fmap Var identifier
<|> fmap IntConst integer
manyExpr = many1 exprparser
seqStmt = do
lst <- sepBy1 statement semi
return lst
program =
many1 $ do
e <- exprparser
reserved "."
return e
parseProgram = parse program "program"