Merge pull request #12 from X-R-G-B/fix-parser

Add operators and add parse func declaration

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)
 import WatLike (aSTToWatLike)
 import AST
 
@@ -42,6 +42,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"
+
 test7 :: [FuncDeclaration]
 test7 =
     [
@@ -60,4 +63,5 @@ main =
     >> print (runParser parseInstruction test5)
     >> print (runParser parseInstruction test6)
     >> print (runParser (proceedAlias <$> parseAllExpression) text)
+    >> print (runParser parseFuncDeclaration test8)
     >> print (aSTToWatLike test7)

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,32 +131,34 @@ parseOperator' sys =
         fVal val = shuntingYardValue val sys
         fOp op = shuntingYardOp op sys
 
-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
+parseOperatorTransformOne' :: [Value] -> Maybe [Value]
+parseOperatorTransformOne' (x1:x2:(Var op):rest)
+    | isOperator op = Just (FuncValue (op, [x1, x2]) : rest)
+    | otherwise = case parseOperatorTransformOne rest of
         Nothing -> Nothing
-        Just ys -> Just (x:ys)
+        Just ys -> Just (x1:x2:ys)
+parseOperatorTransformOne' _ = Nothing
+
+parseOperatorTransformOne :: [Value] -> Maybe [Value]
+parseOperatorTransformOne [] = Just []
+parseOperatorTransformOne [x] = Just [x]
+parseOperatorTransformOne [_, _] = Nothing
+parseOperatorTransformOne (x1:(Var op):rest)
+    | isOperator op = Nothing
+    | otherwise = parseOperatorTransformOne' (x1 : Var op : rest)
+parseOperatorTransformOne (x1:x2:(Var op):rest) =
+    parseOperatorTransformOne' (x1 : x2 : Var op : rest)
+parseOperatorTransformOne (x:xs) = case parseOperatorTransformOne xs of
+    Nothing -> Nothing
+    Just ys -> Just (x:ys)
 
 parseOperatorTransform :: [Value] -> Maybe Value
 parseOperatorTransform [] = Nothing
 parseOperatorTransform vals =
-    case parseOperatorTransform' vals of
+    case parseOperatorTransformOne 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 "<-") *> 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"

lvtc/src/ShuntingYard.hs

@@ -10,7 +10,8 @@ module ShuntingYard
     shuntingYardOp,
     shuntingYardEnd,
     shuntingYardValue,
-    ShuntingYardState (..)
+    ShuntingYardState (..),
+    isOperator
 ) where
 
 import AST
@@ -26,44 +27,52 @@ 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) =
     SYS 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 [] []

lvtc/test/UTParseLvt.hs

@@ -23,6 +23,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
@@ -66,9 +73,9 @@ utParserLvt = testGroup "Parse Lvt"
         ""
         (Function ("a", [Integer 0, StringView "abc", Boolean False]))
   , testCase "return value" $
-      testParserHelper "<- 0;\n"
+      testParserHelpers "<- 0;\n"
         ""
-        (Return (Integer 0))
+        [(Return (Integer 0))]
   , testCase "condition if" $
       testParserHelper "if (a)\n{\nb(0);\n};\n"
         ""
@@ -93,4 +100,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")
+            ]
+        )
   ]