From d58c0f1ea892ae220ea591468b58b6209c9c8aea Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Mon, 8 Jan 2024 14:56:59 +0100 Subject: [PATCH] Add operators and add parse func declaration --- lvtc/app/Main.hs | 6 ++- lvtc/src/ParseLvt.hs | 107 +++++++++++++++++++++++++++++---------- lvtc/src/ShuntingYard.hs | 63 +++++++++++++---------- lvtc/test/UTParseLvt.hs | 16 ++++++ 4 files changed, 136 insertions(+), 56 deletions(-) diff --git a/lvtc/app/Main.hs b/lvtc/app/Main.hs index 13e878a..821b444 100644 --- a/lvtc/app/Main.hs +++ b/lvtc/app/Main.hs @@ -10,7 +10,7 @@ module Main (main) where import Expression (parseExpresion, parseAllExpression) import Parser (runParser) import Alias (proceedAlias) -import ParseLvt (parseInstruction, parseInstructions) +import ParseLvt (parseInstruction, parseInstructions, parseFuncDeclaration) test1 :: String test1 = "if (a)\n{\nb(0);\n};\n" @@ -40,6 +40,9 @@ text = aliasInt ++ aliasRetValue ++ funcMain aliasRetValue = "alias retValue 0;\n" funcMain = "fn main () -> int \n{\n <- retValue;\n};\n" +test8 :: String +test8 = "fn abc(a: Int) -> Int\n{\n <- a;\n};\n" + main :: IO () main = print (runParser parseInstruction test1) @@ -49,3 +52,4 @@ main = >> print (runParser parseInstruction test5) >> print (runParser parseInstruction test6) >> print (runParser (proceedAlias <$> parseAllExpression) text) + >> print (runParser parseFuncDeclaration test8) diff --git a/lvtc/src/ParseLvt.hs b/lvtc/src/ParseLvt.hs index 6a8daaa..8d4ea22 100644 --- a/lvtc/src/ParseLvt.hs +++ b/lvtc/src/ParseLvt.hs @@ -24,6 +24,8 @@ module ParseLvt parseDeclaration, parseAssignation, parseCond, + -- Function + parseFuncDeclaration ) where import Control.Applicative @@ -52,6 +54,8 @@ lexeme ('*':' ':xs) = lexeme ("*" ++ xs) lexeme ('/':' ':xs) = lexeme ("/" ++ xs) lexeme ('(':' ':xs) = lexeme ("(" ++ xs) lexeme (')':' ':xs) = lexeme (")" ++ xs) +lexeme (':':' ':xs) = lexeme (":" ++ xs) +lexeme (' ':':':xs) = lexeme (":" ++ xs) lexeme (x:xs) = x : lexeme xs parseBoolean :: Parser Value @@ -113,15 +117,11 @@ parseOperatorFstVal = Parser f parseOperatorOp :: Parser Value parseOperatorOp = - f - <$> (parseString "+" - <|> parseString "-" - <|> parseString "*" - <|> parseString "/" - <|> parseString "(" - <|> parseString ")") - where - f op = Var op + Var + <$> (parseString "+" <|> parseString "-" <|> parseString "*" + <|> parseString "/" <|> parseString "(" <|> parseString ")" + <|> parseString "==" <|> parseString "!=" <|> parseString "<" + <|> parseString ">" <|> parseString "<=" <|> parseString ">=") parseOperator' :: ShuntingYardState -> Parser ShuntingYardState parseOperator' sys = @@ -131,24 +131,26 @@ parseOperator' sys = fVal val = shuntingYardValue val sys fOp op = shuntingYardOp op sys +parseOperatorTransform'' :: [Value] -> Maybe [Value] +parseOperatorTransform'' (x1:x2:(Var op):rest) + | isOperator op = Just (FuncValue (op, [x1, x2]) : rest) + | otherwise = case parseOperatorTransform' rest of + Nothing -> Nothing + Just ys -> Just (x1:x2:ys) +parseOperatorTransform'' _ = Nothing + parseOperatorTransform' :: [Value] -> Maybe [Value] parseOperatorTransform' [] = Just [] -parseOperatorTransform' (_:(Var "+"):_) = Nothing -parseOperatorTransform' (_:(Var "-"):_) = Nothing -parseOperatorTransform' (_:(Var "*"):_) = Nothing -parseOperatorTransform' (_:(Var "/"):_) = Nothing -parseOperatorTransform' (x1:x2:(Var "+"):rest) = - Just ((FuncValue ("+", [x1, x2])) : rest) -parseOperatorTransform' (x1:x2:(Var "-"):rest) = - Just ((FuncValue ("-", [x1, x2])) : rest) -parseOperatorTransform' (x1:x2:(Var "*"):rest) = - Just ((FuncValue ("*", [x1, x2])) : rest) -parseOperatorTransform' (x1:x2:(Var "/"):rest) = - Just ((FuncValue ("/", [x1, x2])) : rest) -parseOperatorTransform' (x:xs) = - case parseOperatorTransform' xs of - Nothing -> Nothing - Just ys -> Just (x:ys) +parseOperatorTransform' [x] = Just [x] +parseOperatorTransform' [_, _] = Nothing +parseOperatorTransform' (x1:(Var op):rest) + | isOperator op = Nothing + | otherwise = parseOperatorTransform'' (x1 : Var op : rest) +parseOperatorTransform' (x1:x2:(Var op):rest) = + parseOperatorTransform'' (x1 : x2 : Var op : rest) +parseOperatorTransform' (x:xs) = case parseOperatorTransform' xs of + Nothing -> Nothing + Just ys -> Just (x:ys) parseOperatorTransform :: [Value] -> Maybe Value parseOperatorTransform [] = Nothing @@ -156,7 +158,7 @@ parseOperatorTransform vals = case parseOperatorTransform' vals of Nothing -> Nothing Just [] -> Nothing - Just (x:[]) -> Just x + Just [x] -> Just x Just (x:rest) -> parseOperatorTransform (x:rest) parseOperatorS :: ShuntingYardState -> Parser ShuntingYardState @@ -231,10 +233,10 @@ parseFunction :: Parser Instruction parseFunction = parseCall parseReturn :: Parser Instruction -parseReturn = Return <$> (parseString "<- " *> parseValue) +parseReturn = Return <$> ((parseString "<- " <|> parseString "<-") *> parseValue) parseType :: Parser String -parseType = +parseType = parseString "Bool" <|> parseString "Int" <|> parseString "Char" @@ -310,3 +312,52 @@ parseInstructions :: Parser [Instruction] parseInstructions = Parser f where f str = runParser (some parseInstruction) (lexeme str) + +parseFuncVar :: Parser Var +parseFuncVar = Parser f + where + f str = case runParser (parseVar <* parseString ":") (lexeme str) of + Nothing -> Nothing + Just (Var x, xs) -> runParser (lmbda x <$> parseType) xs + _notVar -> Nothing + lmbda var typ = (var, typ) + +parseFuncVars :: Parser [Var] +parseFuncVars = + parseChar '(' *> + some + (parseFuncVar + <* (parseString "," <|> parseString " ," <|> parseString ", ") + <|> parseFuncVar) + <* parseChar ')' + +parseFuncName :: Parser Symbol +parseFuncName = Parser f + where + f str = case runParser + ((parseString "export fn " <|> parseString "fn ") *> parseVar) + str + of + Nothing -> Nothing + Just (Var x, xs) -> Just (x, xs) + _notVar -> Nothing + +parseFuncType :: Parser Type +parseFuncType = + (parseString " -> " + <|> parseString "-> " + <|> parseString "->") *> parseType <* parseString "\n{\n" + +parseFuncPrototype :: Parser FuncPrototype +parseFuncPrototype = + (,,) + <$> parseFuncName + <*> parseFuncVars + <*> parseFuncType + +parseFuncDeclaration :: Parser FuncDeclaration +parseFuncDeclaration = + (,) + <$> parseFuncPrototype + <*> parseInstructions + <* parseString "};\n" diff --git a/lvtc/src/ShuntingYard.hs b/lvtc/src/ShuntingYard.hs index 9a308dd..d010d3e 100644 --- a/lvtc/src/ShuntingYard.hs +++ b/lvtc/src/ShuntingYard.hs @@ -10,7 +10,8 @@ module ShuntingYard shuntingYardOp, shuntingYardEnd, shuntingYardValue, - ShuntingYardState (..) + ShuntingYardState (..), + isOperator ) where import AST @@ -26,36 +27,44 @@ instance Show ShuntingYardState where shuntingYardValue :: Value -> ShuntingYardState -> ShuntingYardState shuntingYardValue val (SYS ops out) = SYS ops (out ++ [val]) +isOperator :: String -> Bool +isOperator "!=" = True +isOperator "==" = True +isOperator "<" = True +isOperator ">" = True +isOperator "<=" = True +isOperator ">=" = True +isOperator "+" = True +isOperator "-" = True +isOperator "*" = True +isOperator "/" = True +isOperator _ = False + +getPrecedence :: String -> Int +getPrecedence "!=" = 1 +getPrecedence "==" = 1 +getPrecedence "<" = 1 +getPrecedence ">" = 1 +getPrecedence "<=" = 1 +getPrecedence ">=" = 1 +getPrecedence "+" = 2 +getPrecedence "-" = 2 +getPrecedence "*" = 3 +getPrecedence "/" = 3 +getPrecedence _ = 0 + opOnStack :: Value -> ShuntingYardState -> ShuntingYardState -opOnStack (Var "+") (SYS ((Var "*"):ops) out) = - opOnStack (Var "+") (SYS ops (out ++ [Var "*"])) -opOnStack (Var "+") (SYS ((Var "/"):ops) out) = - opOnStack (Var "+") (SYS ops (out ++ [Var "/"])) -opOnStack (Var "+") (SYS ((Var "-"):ops) out) = - opOnStack (Var "+") (SYS ops (out ++ [Var "-"])) -opOnStack (Var "+") (SYS ((Var "+"):ops) out) = - opOnStack (Var "+") (SYS ops (out ++ [Var "+"])) -opOnStack (Var "-") (SYS ((Var "*"):ops) out) = - opOnStack (Var "-") (SYS ops (out ++ [Var "*"])) -opOnStack (Var "-") (SYS ((Var "/"):ops) out) = - opOnStack (Var "-") (SYS ops (out ++ [Var "/"])) -opOnStack (Var "-") (SYS ((Var "+"):ops) out) = - opOnStack (Var "-") (SYS ops (out ++ [Var "+"])) -opOnStack (Var "-") (SYS ((Var "-"):ops) out) = - opOnStack (Var "-") (SYS ops (out ++ [Var "-"])) -opOnStack (Var "*") (SYS ((Var "/"):ops) out) = - opOnStack (Var "*") (SYS ops (out ++ [Var "/"])) -opOnStack (Var "*") (SYS ((Var "*"):ops) out) = - opOnStack (Var "*") (SYS ops (out ++ [Var "*"])) -opOnStack (Var "/") (SYS ((Var "*"):ops) out) = - opOnStack (Var "/") (SYS ops (out ++ [Var "*"])) -opOnStack (Var "/") (SYS ((Var "/"):ops) out) = - opOnStack (Var "/") (SYS ops (out ++ [Var "/"])) +opOnStack (Var op1) (SYS ((Var op2):ops) out) + | prec2 >= prec1 = opOnStack (Var op1) (SYS ops (out ++ [Var op2])) + | otherwise = SYS (Var op2:ops) out + where + prec1 = getPrecedence op1 + prec2 = getPrecedence op2 opOnStack _ sys = sys shuntingYardOp :: Value -> ShuntingYardState -> ShuntingYardState shuntingYardOp (Var "(") (SYS ops out) = - SYS ((Var "(") : ops) out + SYS (Var "(" : ops) out shuntingYardOp (Var ")") (SYS [] _) = SYS [] [] shuntingYardOp (Var ")") (SYS ((Var "("):ops) out) = @@ -63,7 +72,7 @@ shuntingYardOp (Var ")") (SYS ((Var "("):ops) out) = shuntingYardOp (Var ")") (SYS (op:ops) out) = shuntingYardOp (Var ")") (SYS ops (out ++ [op])) shuntingYardOp (Var op) sys = - SYS ((Var op):ops') out' + SYS (Var op:ops') out' where (SYS ops' out') = opOnStack (Var op) sys shuntingYardOp _ _ = SYS [] [] diff --git a/lvtc/test/UTParseLvt.hs b/lvtc/test/UTParseLvt.hs index d419fe2..d72587c 100644 --- a/lvtc/test/UTParseLvt.hs +++ b/lvtc/test/UTParseLvt.hs @@ -16,6 +16,13 @@ testParserHelper str restExpected expressionExpected = assertEqual str expressionExpected parsed Nothing -> assertFailure ("Parsing failed for: `" ++ str ++ "`") +testParserFunc :: String -> String -> FuncDeclaration -> IO () +testParserFunc str restExpected expressionExpected = + case runParser parseFuncDeclaration str of + Just (parsed, rest) -> assertEqual str restExpected rest >> + assertEqual str expressionExpected parsed + Nothing -> assertFailure ("Parsing failed for: `" ++ str ++ "`") + testParserHelpers :: String -> String -> [Instruction] -> IO () testParserHelpers str restExpected expressionExpected = case runParser parseInstructions str of @@ -86,4 +93,13 @@ utParserLvt = testGroup "Parse Lvt" Declaration (("c", "Int"), FuncValue ("b", [Var "a"])), Cond (Var "c", [Function ("d", [Var "a"])], []) ] + , testCase "test func" $ + testParserFunc "fn abc(a: Int) -> Int\n{\n <- a;\n};\n" + "" + ( + ("abc", [("a", "Int")], "Int"), + [ + Return (Var "a") + ] + ) ]