parser2 -> parser; higher call precedence

parser.hs

@@ -1,205 +1,128 @@
--- Parser for the Lamb programming language
+{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}
--- Copyright (c) 2013 darkf
--- Licensed under the terms of the zlib license, see LICENSE for details
 
 module Parser where
-
+import Text.Peggy hiding (space)
-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="{-",
+[peggy|
-						  T.commentEnd="-}",
+top :: [AST] = statements !.
-						  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
+lineComment :: () = '--' (!'\n' .)* '\n' { () }
-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]
+space :: () = [ \r\n\t] { () } / lineComment
-	  , [Infix (reservedOp "!=" >> return NotEquals) AssocLeft]
-	  , [Infix (reservedOp "<" >> return LessThan) AssocLeft]
-	  , [Infix (reservedOp ">" >> return GreaterThan) AssocLeft]
-	  ]
 
-identifier = T.identifier lexer
+statements :: [AST] = statement+
-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
+statement :: AST = expr "."
 
--- http://codereview.stackexchange.com/a/2572
+semistatements :: [AST]
-stringChar =
+  = expr ";" semistatements { $1 : $2 }
-	escaped <|> noneOf "\""
+  / expr { [$1] }
-	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
+args :: AST
-	char '"'
+  = expr ("," expr)+ { TupleConst ($1 : $2) }
-	x <- many stringChar
+  / expr? { case $1 of
-	char '"'
+  				Just x -> x
-	whiteSpace
+  				Nothing -> UnitConst }
-	return x
 
-block = do
+patternlist :: Pattern
-	reserved "do"
+  = pattern ("," pattern)+ { ListP ($1 : $2) }
-	lst <- seqStmt
+  / pattern? { case $1 of
-	reserved "end"
+  				Just x -> ListP [x]
-	return $ Block lst
+  				Nothing -> ListP [] }
 
-listSeq p cons = do
+patterntuple :: Pattern
-	symbol "["
+  = "(" "," ")" { TupleP [] }
-	lst <- sepBy p (symbol ",")
+  / "(" pattern ("," pattern)+ ")" { TupleP ($1 : $2) }
-	symbol "]"
+  / "(" pattern "," ")" { TupleP [$1] }
-	return $ cons lst
 
-tupleSeq p cons = do
+pattern :: Pattern
-	symbol "("
+  = pattern "::" pattern { ConsP $1 $2 }
-	lst <- sepBy1 p (symbol ",")
+  / "[" patternlist "]"
-	symbol ")"
+  / patterntuple
-	return $ cons lst
+  / identifier { VarP $1 }
+  / stringlit { StrP $1 }
+  / integer { IntP $1 }
 
-emptyTuple cons = do
+funpattern :: Pattern
-	symbol "("
+  = pattern ("," pattern)+ { TupleP ($1 : $2) }
-	symbol ","
+  / pattern? { case $1 of
-	symbol ")"
+  					Just x -> x
-	return $ cons []
+  					Nothing -> UnitP }
 
-intPattern = fmap IntP integer
+listseq :: AST
-varPattern = fmap VarP identifier
+  = expr ("," expr)+ { ListConst ($1 : $2) }
-stringPattern = fmap StrP stringLiteral
+  / expr? { case $1 of
-listPattern = listSeq pattern ListP
+  				Just x -> ListConst [x]
+  				Nothing -> ListConst [] }
 
-consPattern = do
+tuple :: AST
-	x <- intPattern <|> varPattern <|> stringPattern <|> try (tupleSeq pattern TupleP)
+  = "(" "," ")" { TupleConst [] }
-	symbol "::"
+  / "(" expr ("," expr)+ ")" { TupleConst ($1 : $2) }
-	y <- pattern
+  / "(" expr "," ")" { TupleConst [$1] }
-	return $ ConsP x y
 
-pattern = try consPattern
+doblock :: AST
-		<|> try (emptyTuple TupleP)
+  = "do" semistatements "end" { Block $1 }
-		<|> try (tupleSeq pattern TupleP)
-		<|> listPattern
-	    <|> varPattern
-	    <|> intPattern
-	    <|> stringPattern
 
-patterns = sepBy pattern (symbol ",")
+lambda :: AST
+  = "\\" funpattern "->" expr { Lambda [($1, $2)] }
 
-funDef = do
+def :: AST
-	name <- identifier
+  = pattern "=" expr { Def $1 $2 }
-	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
+ifcond :: AST
-	symbol "\\"
+  = "if" expr "then" expr "else" expr { IfExpr $1 $2 $3 }
-	pats <- patterns
-	let pat = (case pats of
-		[] -> UnitP
-		[a] -> a
-		otherwise -> TupleP pats)
-	symbol "->"
-	body <- exprparser
-	return $ Lambda [(pat, body)]
 
-call p argp = do
+expr :: AST
-	lhs <- p
+  = expr "::" expr { Cons $1 $2 }
-	whiteSpace
+  / expr "+" fact { Add $1 $2 }
-	symbol "("
+  / expr "-" fact { Sub $1 $2 }
-	args <- sepBy argp (symbol ",")
+  / expr "==" fact { Equals $1 $2 }
-	let arg = (case args of
+  / expr "!=" fact { NotEquals $1 $2 }
-		[] -> UnitConst
+  / expr "<" fact { LessThan $1 $2 }
-		[a] -> a
+  / expr ">" fact { GreaterThan $1 $2 }
-		otherwise -> TupleConst args)
+  / def
-	symbol ")"
+  / lambda
-	return $ Call lhs arg
+  / identifier "(" funpattern ")" "->" expr { Defun $1 (Lambda [($2, $3)]) }
+  / fact
 
-consExpr = do
+fact :: AST
-	x <- expr3
+  = fact "*" term { Mul $1 $2 }
-	symbol "::"
+  / fact "/" term { Div $1 $2 }
-	y <- exprparser
+  / term
-	return $ Cons x y
 
-ifExpr = do
+term :: AST
-	symbol "if"
+  = term "(" args ")" { Call $1 $2 }
-	cond <- exprparser
+  / tuple
-	symbol "then"
+  / "(" expr ")"
-	t <- exprparser
+  / "[" listseq "]"
-	symbol "else"
+  / ifcond
-	e <- exprparser
+  / doblock
-	return $ IfExpr cond t e
+  / stringlit { StrConst $1 }
+  / integer { IntConst $1 }
+  / identifier { Var $1 }
 
-bool = fmap BoolConst $ (symbol "true" >> return True) <|> (symbol "false" >> return False)
+stringlit ::: String = '\"' charlit* '\"'
 
-def = do
+charlit :: Char
-	pat <- pattern
+  = '\\' escChar
-	whiteSpace
+  / [^\"\\]
-	symbol "="
-	value <- exprparser
-	return $ Def pat value
 
--- field access
+escChar :: Char
-accessOp = do
+  = '\"' { '\"' }
-	symbol "/"
+  / '\\' { '\\' }
-	return Access
+  / '/' { '/' }
+  / 'b' { '\b' }
+  / 'f' { '\f' }
+  / 'n' { '\n' }
+  / 'r' { '\r' }
+  / 't' { '\t' }
 
-expr1 = try block
+identifier ::: String
-	 <|> try lambda
+  = [a-zA-Z_] [a-zA-Z0-9_'?!]* { $1 : $2 }
-	 <|> 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
+integer ::: Integer
-	  <|> expr1
+  = [0-9] [0-9]* { read ($1 : $2) }
+|]
 
-expr3 = try funDef
+parseProgram program = parseString top "<input>" program
-	   <|> 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"