Fakultas Ilmu Komputer UI

Commit 4cfdc6f5 authored by Sean Gillespie's avatar Sean Gillespie
Browse files

Update System F parser

Split parser into two separate parsers
 * Expression Parser
 * Type parser
parent b160e65a
module Language.SystemF.Parser (parseExpr) where
module Language.SystemF.Parser (
parseExpr,
parseType
) where
import Control.Monad
import Prelude hiding (abs)
......@@ -11,6 +14,10 @@ import Language.SystemF.Expression
parseExpr :: String -> Either ParseError (SystemFExpr String String)
parseExpr = parse (whitespace *> expr <* eof) ""
parseType :: String -> Either ParseError (Ty String)
parseType = parse (whitespace *> ty <* eof) ""
-- Parse expressions
expr :: Parser (SystemFExpr String String)
expr = try app <|> term
......@@ -18,21 +25,33 @@ app :: Parser (SystemFExpr String String)
app = chainl1 term (return App)
term :: Parser (SystemFExpr String String)
term = abs <|> var <|> parens
term = abs <|> var <|> parens expr
var :: Parser (SystemFExpr String String)
var = Var <$> identifier
abs :: Parser (SystemFExpr String String)
abs = curry <$> idents <*> expr
where idents = symbol '\\' *> many1 ((,) <$> identifier <*> (symbol ':' *> (TyVar <$> identifier))) <* symbol '.'
abs = curry
<$> (symbol '\\' *> many1 args <* symbol '.')
<*> expr
where args = (,) <$> (identifier <* symbol ':') <*> (TyVar <$> identifier)
curry = flip . foldr . uncurry $ Abs
abs' :: Parser [(String, String)]
abs' = many1 $ (,) <$> identifier <*> (symbol ':' *> identifier)
-- Parse type expressions
ty :: Parser (Ty String)
ty = try arrow
arrow :: Parser (Ty String)
arrow = chainr1 tyterm (symbol' "->" *> return TyArrow)
tyterm :: Parser (Ty String)
tyterm = tyvar <|> parens ty
parens :: Parser (SystemFExpr String String)
parens = symbol '(' *> expr <* symbol ')'
tyvar :: Parser (Ty String)
tyvar = TyVar <$> identifier
parens :: Parser a -> Parser a
parens p = symbol '(' *> p <* symbol ')'
identifier :: Parser String
identifier = lexeme ((:) <$> first <*> many rest)
......@@ -45,5 +64,8 @@ whitespace = void . many . oneOf $ " \t"
symbol :: Char -> Parser ()
symbol = void . lexeme . char
symbol' :: String -> Parser ()
symbol' = void . lexeme . string
lexeme :: Parser a -> Parser a
lexeme p = p <* whitespace
......@@ -8,31 +8,54 @@ import Language.SystemF.Expression
import Language.SystemF.Parser
spec :: Spec
spec = describe "parseExpr" $ do
it "parses simple variables" $
parseExpr "x" `shouldBe` Right (Var "x")
spec = do
describe "parseExpr" $ do
it "parses simple variables" $
parseExpr "x" `shouldBe` Right (Var "x")
it "parses parenthesized variables" $
parseExpr "(x)" `shouldBe` Right (Var "x")
it "parses parenthesized variables" $
parseExpr "(x)" `shouldBe` Right (Var "x")
it "parses simple abstractions" $
parseExpr "\\x:T. x" `shouldBe` Right (Abs "x" (TyVar "T") (Var "x"))
it "parses simple abstractions" $
parseExpr "\\x:T. x" `shouldBe` Right (Abs "x" (TyVar "T") (Var "x"))
it "parses nested abstractions" $
parseExpr "\\a:A b:B. b"
`shouldBe` Right (Abs "a" (TyVar "A") (Abs "b" (TyVar "B") (Var "b")))
it "parses nested abstractions" $
parseExpr "\\a:A b:B. b"
`shouldBe` Right (Abs "a" (TyVar "A") (Abs "b" (TyVar "B") (Var "b")))
it "parses simple applications" $
parseExpr "f x" `shouldBe` Right (App (Var "f") (Var "x"))
it "parses abstractions with arrow types" pending
it "parses chained applications" $
parseExpr "a b c" `shouldBe` Right (App (App (Var "a") (Var "b")) (Var "c"))
it "parses simple applications" $
parseExpr "f x" `shouldBe` Right (App (Var "f") (Var "x"))
it "parses complex expressions" $
pendingWith "Abstraction Not Implemented"
it "parses chained applications" $
parseExpr "a b c" `shouldBe` Right (App (App (Var "a") (Var "b")) (Var "c"))
it "does not parse trailing errors" $
parseExpr "x +" `shouldSatisfy` isLeft
it "parses complex expressions" $
pendingWith "Abstraction Not Implemented"
it "ignores whitespace" $
pendingWith "Abstraction Not Implemented"
it "does not parse trailing errors" $
parseExpr "x +" `shouldSatisfy` isLeft
it "ignores whitespace" $
pendingWith "Abstraction Not Implemented"
describe "parseType" $ do
it "parses simple variables" $
parseType "X" `shouldBe` Right (TyVar "X")
it "parses parenthesized variables" $
parseType "(T)" `shouldBe` Right (TyVar "T")
it "parses simple arrow types" $
parseType "A -> B" `shouldBe` Right (TyArrow (TyVar "A") (TyVar "B"))
it "parses parenthesized arrow types" $
parseType "((X)->(Y))" `shouldBe` Right (TyArrow (TyVar "X") (TyVar "Y"))
it "parses nested arrow types" $ do
parseType "T -> U -> V"
`shouldBe` Right (TyArrow (TyVar "T") (TyArrow (TyVar "U") (TyVar "V")))
parseType "(W -> V) -> U"
`shouldBe` Right (TyArrow (TyArrow (TyVar "W") (TyVar "V")) (TyVar "U"))
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment