diff --git a/src/Language/SystemF/Parser.hs b/src/Language/SystemF/Parser.hs index c417e467c217974652a08b333760f81a23c36e90..e28c5e68cf03bcb113f55fa7d2396d42a1ece524 100644 --- a/src/Language/SystemF/Parser.hs +++ b/src/Language/SystemF/Parser.hs @@ -1,4 +1,7 @@ -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 diff --git a/test/Language/SystemF/ParserSpec.hs b/test/Language/SystemF/ParserSpec.hs index 2c0951774df2692bfdadc2fa88ad95a2e0e7eec6..f2769e2e2ed426c411178a55ed507544687acced 100644 --- a/test/Language/SystemF/ParserSpec.hs +++ b/test/Language/SystemF/ParserSpec.hs @@ -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"))