diff --git a/LobsterLang/src/Parse.hs b/LobsterLang/src/Parse.hs index 8f7f7cc..edee976 100644 --- a/LobsterLang/src/Parse.hs +++ b/LobsterLang/src/Parse.hs @@ -27,8 +27,8 @@ module Parse ( parseValue, parseLobster, parseAnyString, + parseCmpString, parseDefineValue, - parseUnaryOperation, parseProduct, parseSum, parseExpr, @@ -36,7 +36,10 @@ module Parse ( parseFalse, parseAstString, parseWhiteSpace, - errorParsing + errorParsing, + parseDefineFn, + parseLambda, + parseCond ) where import qualified AST @@ -286,16 +289,43 @@ parseValue = parseWhiteSpace *> ( parseWhiteSpace *> parseAnyString "(|" *> parseExpr <* parseAnyString "|)" <* parseWhiteSpace <|> AST.Value <$> parseElem parseInt <|> parseBool + <|> parseSymbol + <|> parseUnaryOperator ) +parseUnaryOperator :: Parser AST.Ast +parseUnaryOperator = parseWhiteSpace *> parseAnyString "!"<|> + parseWhiteSpace *> parseAnyString "@" <|> + parseWhiteSpace *> parseAnyString "~ " + >>= \op -> parseValue + >>= \value -> return $ AST.Call op [value] + +parseListElem :: Parser a -> Parser [a] +parseListElem parserA = Parser (parseFirst parserA) + where + parseFirst :: Parser a -> Position -> String -> Either String ([a], String, Position) + parseFirst parser pos s = case runParser parser pos s of + Left _ -> Right ([], s, pos) + Right (res, s', pos') -> case (parseOthers parser pos' s') of + Left err -> Left err + Right (res', s'', pos'') -> Right(res : res', s'', pos'') + parseOthers :: Parser a -> Position -> String -> Either String ([a], String, Position) + parseOthers parser pos s = case runParser (parseChar ',') pos s of + Left _ -> Right ([], s, pos) + Right (_, s', pos') -> case runParser parser pos' s' of + Left err -> Left err + Right (res, s'', pos'') -> case (parseOthers parser pos'' s'') of + Left err -> Left err + Right (res', s''', pos''') -> Right (res : res', s''', pos''') + -- | Parse a list of element -- Return a Parser of list `element` that start with a '(' and end with a ')' parseList :: Parser a -> Parser [a] parseList parser = parseStart *> parseListValue <* parseEnd where - parseEnd = parseChar ')' <* parseWhiteSpace - parseListValue = parseWhiteSpace *> parseMany (parseElem parser) <* parseWhiteSpace - parseStart = parseWhiteSpace *> parseChar '(' + parseEnd = parseAnyString "|)" <* parseWhiteSpace + parseListValue = parseWhiteSpace *> parseListElem parser <* parseWhiteSpace + parseStart = parseWhiteSpace *> parseAnyString "(|" -- | Parse any character from a String -- Return a Parser that parse every character from a String @@ -323,6 +353,14 @@ parseAnyString s = Parser (f s s) Right (_, s'', pos') -> f xs str pos' s'' f [] str pos s' = Right (str, s', pos) +parseCmpString :: String -> Parser String +parseCmpString s = Parser (f s) + where + f :: String -> Position -> String -> Either String (String, String, Position) + f str pos s' = case runParser parseString pos s' of + Left err -> Left err + Right (res, s'', pos') -> if str == res then Right (res, s'', pos') else Left (errorParsing pos') + -- | Return a Parser that parse a Bool (#f or #t) parseBool :: Parser AST.Ast parseBool = AST.Boolean <$> (parseTrue <|> parseFalse) <* parseWhiteSpace @@ -357,34 +395,79 @@ parseDefineValue = Parser f Left err'' -> Left err'' Right (res'', s''', pos''') -> Right (AST.Define res res'', s''', pos''') -parseUnaryOperator :: Parser String -parseUnaryOperator = parseWhiteSpace *> parseAnyString "!"<|> - parseWhiteSpace *> parseAnyString "@" <|> - parseWhiteSpace *> parseAnyString "~" - -parseUnaryOperation :: Parser AST.Ast -parseUnaryOperation = Parser f - where - f :: Position -> String -> Either String (AST.Ast, String, Position) - f pos s = case runParser parseUnaryOperator pos s of - Left err -> Left err - Right (res, s', pos') -> case runParser parseAst pos' s' of - Left err' -> Left err' - Right (res', s'', pos'') -> Right (AST.Call res [res'], s'', pos'') +parseSymbol :: Parser AST.Ast +parseSymbol = do + name <- parseString + args <- optional (parseWhiteSpace *> parseList parseAst + >>= \res -> return $ AST.Symbol name (Just res)) + return $ fromMaybe (AST.Symbol name Nothing) args -- | Return a Parser that parse a SExpr parseAst :: Parser AST.Ast parseAst = parseWhiteSpace *> ( - parseDefineValue - <|> parseExpr + parseDefineFn + <|> parseCond + <|> parseDefineValue + <|> parseLambda <|> parseBool - <|> parseUnaryOperation + <|> parseExpr <|> parseAstString <|> parseValue - <|> parseAstString + <|> parseSymbol ) +parseDefineFn :: Parser AST.Ast +parseDefineFn = parseCmpString "fn" *> (Parser defineFn) + where + defineFn :: Position -> String -> Either String (AST.Ast, String, Position) + defineFn s pos = case runParser parseString s pos of + Left err -> Left err + Right (res, s', pos') -> case runParser parseFunctionValue pos' s' of + Left err -> Left err + Right (res', s'', pos'') -> Right (AST.Define res res', s'', pos'') + +parseLambda :: Parser AST.Ast +parseLambda = lambda *> parseFunctionValue + where + lambda = parseCmpString "lambda" <|> parseAnyString "λ" + +parseFunctionValue :: Parser AST.Ast +parseFunctionValue = Parser parseParams + where + parseParams :: Position -> String -> Either String (AST.Ast, String, Position) + parseParams s pos = case runParser (parseList parseString) s pos of + Left err -> Left err + Right (res, s', pos') -> case runParser parseBracket pos' s' of + Left err -> Left err + Right (res', s'', pos'') -> Right (AST.FunctionValue res res' Nothing, s'', pos'') + +parseBracket :: Parser AST.Ast +parseBracket = parseStart *> parseAst <* parseEnd + where + parseEnd = parseWhiteSpace *> parseChar '}' <* parseWhiteSpace + parseStart = parseWhiteSpace *> parseChar '{' <* parseWhiteSpace + +parseCond :: Parser AST.Ast +parseCond = parseCmpString "if" *> Parser parseIf + where + parseIf :: Position -> String -> Either String (AST.Ast, String, Position) + parseIf pos s = case runParser parseExpr pos s of + Left err -> Left err + Right (res, s', pos') -> case runParser parseBracket pos' s' of + Left err -> Left err + Right (res', s'', pos'') -> case runParser parseElse pos'' s'' of + Left _ -> Right ((AST.Cond res res' Nothing), s'', pos'') + Right (res'', s''', pos''') -> Right ((AST.Cond res res' (Just res'')), s''', pos''') + parseElse :: Parser AST.Ast + parseElse = parseCmpString "else" *> Parser p + where + p :: Position -> String -> Either String (AST.Ast, String, Position) + p pos s = case runParser parseCond pos s of + Left _ -> case runParser parseBracket pos s of + Left err -> Left err + Right (res, s', pos') -> Right (res, s', pos') + Right (res, s', pos') -> Right (res, s', pos') parseLobster :: Parser [AST.Ast] parseLobster = parseSome (parseWhiteSpace *> parseAst) diff --git a/LobsterLang/test/ParserSpec.hs b/LobsterLang/test/ParserSpec.hs index a14f74f..7743700 100644 --- a/LobsterLang/test/ParserSpec.hs +++ b/LobsterLang/test/ParserSpec.hs @@ -80,18 +80,20 @@ spec = do runParser (parseElem parseString) (0,0) "hello la " `shouldBe` Right ("hello", "la ", (0,6)) it "Check parseValue Success" $ do runParser parseValue (0,0) "432 la " `shouldBe` Right (AST.Value 432, "la ", (0,14)) - it "Check parseList with parseInt Success" $ do - runParser (parseList parseInt) (0,0) "(1 2 3 4 5)" `shouldBe` Right ([1, 2 ,3 , 4, 5], "", (0, 13)) - it "Check parseList with parseInt Failure (without a number inside)" $ do - runParser (parseList parseInt) (0,0) "(1 2 3 d 4 5) (0,0) " `shouldBe` Left (errorParsing (0,8)) - it "Check parseList with parseInt Failure (without a ending ')')" $ do - runParser (parseList parseInt) (0,0) "(1 2 3 4 5 " `shouldBe` Left (errorParsing (0,12)) - it "Check parseList with parseInt Failure (without a starting '(')" $ do - runParser (parseList parseInt) (0,0) "1 2 3 4 5)" `shouldBe` Left (errorParsing (0,0)) - it "Check parseList with parseString Success" $ do - runParser (parseList parseString) (0,0) "(buenos owow k ye )1 2 3 4 5)" `shouldBe` Right (["buenos", "owow", "k", "ye"], "1 2 3 4 5)", (0, 22)) + it "Check parseList String Success" $ do + runParser (parseList parseString) (0,0) "(| a, b ,c, d |)" `shouldBe` Right(["a", "b", "c", "d"], "", (0,19)) + it "Check parseList Error missing comma" $ do + runParser (parseList parseString) (0,0) "(| a b |)" `shouldBe` Left "Error on parsing on '0' '5'" + it "Check parseList Error end with comma" $ do + runParser (parseList parseString) (0,0) "(|a, |)" `shouldBe` Left "Error on parsing on '0' '5'" + it "Check parseList Error starting with comma" $ do + runParser (parseList parseString) (0,0) "(|,a|)" `shouldBe` Left "Error on parsing on '0' '2'" + it "Check parseList Error missing starting bracket" $ do + runParser (parseList parseString) (0,0) "a, b|)" `shouldBe` Left "Error on parsing on '0' '0'" + it "Check parseList Error missing ending bracket" $ do + runParser (parseList parseString) (0,0) "(|a, b" `shouldBe` Left "Error on parsing on '0' '6'" it "Check parseList with parseString Failure" $ do - runParser (parseList parseString) (0,0) "(buenos 3 owow k ye )1 2 3 4 5)" `shouldBe` Left (errorParsing (0,8)) + runParser (parseList parseString) (0,0) "(|buenos, 3, owow, k, ye |)" `shouldBe` Left (errorParsing (0,10)) it "Check parseBool true Success" $ do runParser parseBool (0,0) "true lp" `shouldBe` Right (AST.Boolean True, "lp", (0,5)) it "Check parseBool false Success" $ do @@ -176,9 +178,9 @@ spec = do runParser parseString (0,0) "_Lob3ster*" `shouldBe` Right ("_Lob3ster","*",(0,9)) it "Check parseMany Success" $ do runParser (parseMany (parseChar ' ')) (0,0) " p" `shouldBe` Right (" ","p",(0,1)) - it "Check parseUnaryOperation Success" $ do - runParser parseUnaryOperation (0,0) "! true" `shouldBe` Right (AST.Call "!" [AST.Boolean True],"",(0,6)) - it "Check parseUnaryOperation Failure (incorrect AST)" $ do - runParser parseUnaryOperation (0,0) "! *" `shouldBe` Left (errorParsing (0,2)) - it "Check parseUnaryOperation Failure (missing operator)" $ do - runParser parseUnaryOperation (0,0) "error" `shouldBe` Left (errorParsing (0,0)) + it "Check parseExpr Unary Operation Success" $ do + runParser parseExpr (0,0) "! true" `shouldBe` Right (AST.Call "!" [AST.Boolean True],"",(0,6)) + it "Check parseExpr Unary Operation Failure (incorrect AST)" $ do + runParser parseExpr (0,0) "! *" `shouldBe` Left (errorParsing (0,2)) + it "Check parseExpr Unary Operation Failure (missing operator)" $ do + runParser parseExpr (0,0) "error" `shouldBe` Right (AST.Symbol "error" Nothing, "", (0, 5))