Merge branch 'dev' into 3-compute-ast

.github/workflows/tests.yml

@@ -86,3 +86,9 @@ jobs:
             tests.log
           refresh-message-position: true
           message-id: tests-cicd
+
+      - name: Exit Status
+        run: |
+          if [ ${{ steps.failedTest.outputs.failedTest }} == 'true' ]; then
+            exit 1
+          fi

.gitignore

@@ -166,7 +166,7 @@ tags
 
 .idea/*
 
-/koaky
+/koaky-exe
 /glados
 
 *.log

src/AST.hs

@@ -8,32 +8,41 @@
 module AST
     (
         Symbol,
-        Atom (Number, Symbol),
-        Tree (Node, Leaf)
+        Atom (Number, Symbol, Boolean),
+        Tree (Node, Leaf, Variadic),
+        showMaybeTree
     ) where
 
 import Data.Int (Int64)
 
 type Symbol = String
 
-data Atom = Number Int64 | Symbol Symbol
+data Atom = Number Int64 | Symbol Symbol | Boolean Bool
 
-data Tree = Node Symbol [Tree] | Leaf Atom
+data Tree = Node Symbol (Maybe Tree) (Maybe Tree) | Leaf Atom | Variadic (Maybe Tree) (Maybe Tree)
+
+showMaybeTree :: Maybe Tree -> String
+showMaybeTree Nothing = "Nothing"
+showMaybeTree (Just tree) = show tree
 
 instance Eq Atom where
     Number a == Number b = a == b
     Symbol a == Symbol b = a == b
+    Boolean a == Boolean b = a == b
     _ == _ = False
 
 instance Show Atom where
-    show (Number a) = "Number:'" ++ show a ++ "'"
-    show (Symbol a) = "Symbol:'" ++ a ++ "'"
+    show (Number a) = "N:'" ++ show a ++ "'"
+    show (Symbol a) = "S:'" ++ a ++ "'"
+    show (Boolean value) = "B: " ++ show value
 
 instance Eq Tree where
-    Node a as == Node b bs = a == b && as == bs
+    Node a fst_ scd == Node b bfst bscd = a == b && fst_ == bfst && scd == bscd
     Leaf a == Leaf b = a == b
+    Variadic fst_ scd == Variadic bfst bscd = fst_ == bfst && scd == bscd
     _ == _ = False
 
 instance Show Tree where
-    show (Node a as) = "Node:'" ++ a ++ "'{" ++ show as ++ "}"
-    show (Leaf a) = "Leaf:'" ++ show a ++ "'"
+    show (Node value fst_ scd) = "Node:'" ++ value ++ "' first: '{" ++ showMaybeTree fst_ ++ "} second: {" ++ showMaybeTree scd ++ "}'"
+    show (Leaf value) = "Leaf:'" ++ show value ++ "'"
+    show (Variadic fst_ scd) = "Variadic first: {" ++ showMaybeTree fst_ ++ "} second: {" ++ showMaybeTree scd ++ "}"

src/TextToAST.hs

@@ -7,4 +7,122 @@
 
 module TextToAST
     (
+        textToAST
     ) where
+
+import AST
+import Data.Int (Int64)
+import Data.Char (isDigit)
+
+isFunction :: String -> Bool
+isFunction [] = False
+isFunction ('(':_) = True
+isFunction _ = False
+
+skipableChar :: Char -> Bool
+skipableChar ' ' = True
+skipableChar '\t' = True
+skipableChar _ = False
+
+notSkipableChar :: Char -> Bool
+notSkipableChar x = not (skipableChar x)
+
+stringIsNumber' :: String -> Bool
+stringIsNumber' [] = False
+stringIsNumber' [x] | Data.Char.isDigit x = True
+                    | otherwise = False
+stringIsNumber' (x:xs) | Data.Char.isDigit x = stringIsNumber' xs
+                       | otherwise = False
+
+stringIsNumber :: String -> Bool
+stringIsNumber [] = False
+stringIsNumber [x] | Data.Char.isDigit x = True
+                   | otherwise = False
+stringIsNumber str =
+    stringIsNumber' (takeWhile (\x -> notSkipableChar x && x /= ')') str)
+
+parseStringNumber :: String -> Atom
+parseStringNumber str =
+    Number (read
+        (takeWhile (\x -> notSkipableChar x && x /= ')') str)
+        :: Data.Int.Int64)
+
+nextToParse' :: String -> Int -> String
+nextToParse' [] _ = []
+nextToParse' (')':xs) 1 = dropWhile (\x -> skipableChar x || x == ')') xs
+nextToParse' (')':xs) depth = nextToParse' xs (depth - 1)
+nextToParse' ('(':xs) depth = nextToParse' xs (depth + 1)
+nextToParse' (_:xs) depth = nextToParse' xs depth
+
+nextToParse :: String -> String
+nextToParse [] = []
+nextToParse ('(':xs) = nextToParse' xs 0
+nextToParse str = dropWhile skipableChar
+    (dropWhile notSkipableChar (dropWhile skipableChar str))
+
+countAtoms :: String -> Int -> Int
+countAtoms str depth | depth >= 2 = 2
+                     | not (null $ takeWhile
+                        (/= ')')
+                        (dropWhile skipableChar str)) =
+                            countAtoms (nextToParse str) (depth + 1)
+                     | otherwise = depth
+
+createVariadic :: String -> Maybe Tree
+createVariadic str =
+    Just $ Variadic (textToAST str) (textToAST (nextToParse str))
+
+createNodeFromFunction :: Symbol -> String -> Int -> Maybe Tree
+createNodeFromFunction [] _ _ = Nothing
+createNodeFromFunction (_:xs) [] 0 = Just (Node xs Nothing Nothing)
+createNodeFromFunction (_:xs) str 0 = Just (Node xs (textToAST str) Nothing)
+createNodeFromFunction _ [] _ = Nothing
+createNodeFromFunction (_:xs) str 1 = Just (Node xs (textToAST str)
+    (textToAST (nextToParse str)))
+createNodeFromFunction (_:xs) str 2 =
+    Just (Node xs (textToAST str) (createVariadic (nextToParse str)))
+createNodeFromFunction _ _ _ = Nothing
+
+stringIsBool :: String -> Bool
+stringIsBool "#t" = True
+stringIsBool "#f" = True
+stringIsBool "#f)" = True
+stringIsBool "#t)" = True
+stringIsBool ('#':'t':xs) | dropWhile skipableChar xs == ")" = True
+                          | otherwise = False
+stringIsBool ('#':'f':xs) | dropWhile skipableChar xs == ")" = True
+                          | otherwise = False
+stringIsBool _ = False
+
+createBool :: String -> Maybe Tree
+createBool "#f" = Just (Leaf (Boolean False))
+createBool "#t" = Just (Leaf (Boolean True))
+createBool "#f)" = Just (Leaf (Boolean False))
+createBool "#t)" = Just (Leaf (Boolean True))
+createBool ('#':'t':xs) | dropWhile skipableChar xs == ")" =
+                            Just (Leaf (Boolean True))
+                        | otherwise = Nothing
+createBool ('#':'f':xs) | dropWhile skipableChar xs == ")" =
+                            Just (Leaf (Boolean False))
+                        | otherwise = Nothing
+createBool _ = Nothing
+
+treeFromAtom :: String -> String -> Maybe Tree
+treeFromAtom [] _ = Nothing
+treeFromAtom split str | stringIsNumber split =
+                            Just (Leaf (parseStringNumber split))
+                       | stringIsBool split = createBool split
+                       | isFunction split = createNodeFromFunction
+                            (takeWhile (/= ')') split)
+                            str
+                            (countAtoms (nextToParse str) 0)
+                       | otherwise =
+                            Just (Leaf (Symbol $ takeWhile (/= ')') split))
+
+textToAST :: String -> Maybe Tree
+textToAST [] = Nothing
+textToAST (x:xs) | skipableChar x = textToAST xs
+                 | otherwise =
+                    treeFromAtom
+                        (takeWhile notSkipableChar (x:xs))
+                        (dropWhile notSkipableChar (x:xs))

test/Spec.hs

@@ -3,19 +3,150 @@ import Test.Tasty.HUnit
 import Test.Tasty.Runners.Html
 
 import AST
+import TextToAST
 
 main :: IO ()
 main = defaultMainWithIngredients (htmlRunner : defaultIngredients) tests
 
 tests :: TestTree
-tests = testGroup "Tests" [unitTests]
+tests = testGroup "Tests" [unitTestsASTEqual, unitTestsASTParse]
 
-unitTests :: TestTree
-unitTests = testGroup "Unit tests"
+unitTestsASTEqual :: TestTree
+unitTestsASTEqual = testGroup "AST Equal Tests"
   [ testCase "Basic AST creation 0" $
-      assertEqual "define x 42" (Node "define" [Leaf (Symbol "x"), Leaf (Number 42)]) (Node "define" [Leaf (Symbol "x"), Leaf (Number 42)])
+      assertEqual "define x 42"
+        (Node "define" (Just $ Leaf (Symbol "x")) (Just $ Leaf (Number 42)))
+        (Node "define" (Just $ Leaf (Symbol "x")) (Just $ Leaf (Number 42)))
   , testCase "Basic AST creation 1" $
-      assertEqual "foo" (Leaf (Symbol "foo")) (Leaf (Symbol "foo"))
+      assertEqual "foo"
+        (Leaf (Symbol "foo"))
+        (Leaf (Symbol "foo"))
   , testCase "Basic AST creation 2" $
-      assertEqual "42" (Leaf (Number 42)) (Leaf (Number 42))
+      assertEqual "42"
+        (Leaf (Number 42))
+        (Leaf (Number 42))
+  , testCase "Basic AST creation 3" $
+      assertEqual "#f"
+        (Leaf (Boolean False))
+        (Leaf (Boolean False))
+  , testCase "Basic AST creation 4" $
+      assertEqual "#t"
+        (Leaf (Boolean True))
+        (Leaf (Boolean True))
+  ]
+
+unitTestsASTParse :: TestTree
+unitTestsASTParse = testGroup "AST Parse Tests"
+  [ testCase "(foo abc def hij)" $
+      assertEqual "(foo abc def hij)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "abc"))
+          (Just $ Variadic
+            (Just $ Leaf (Symbol "def"))
+            (Just $ Leaf (Symbol "hij"))
+          )
+        )
+        (textToAST "(foo abc def hij)")
+  , testCase "(define x 42)" $
+      assertEqual "(define x 42)"
+        (Just $ Node "define"
+          (Just $ Leaf (Symbol "x"))
+          (Just $ Leaf (Number 42))
+        )
+        (textToAST "(define x 42)")
+  , testCase "42" $
+      assertEqual "42"
+        (Just $ Leaf (Number 42))
+        (textToAST "42")
+  , testCase "#f" $
+      assertEqual "#f"
+        (Just $ Leaf (Boolean False))
+        (textToAST "#f")
+  , testCase "#t" $
+      assertEqual "#t"
+        (Just $ Leaf (Boolean True))
+        (textToAST "#t")
+  , testCase "foo" $
+      assertEqual "foo"
+        (Just $ Leaf (Symbol "foo"))
+        (textToAST "foo")
+  , testCase "(foo)" $
+      assertEqual "(foo)"
+        (Just $ Node "foo" Nothing Nothing)
+        (textToAST "(foo)")
+  , testCase "(foo def)" $
+      assertEqual "(foo def)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          Nothing
+        )
+        (textToAST "(foo def)")
+  , testCase "(foo def #t)" $
+      assertEqual "(foo def #t)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          (Just $ Leaf (Boolean True))
+        )
+        (textToAST "(foo def #t)")
+  , testCase "(foo def #f)" $
+      assertEqual "(foo def #f)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          (Just $ Leaf (Boolean False))
+        )
+        (textToAST "(foo def #f)")
+  , testCase "(foo #f def)" $
+      assertEqual "(foo #f def)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Boolean False))
+          (Just $ Leaf (Symbol "def"))
+        )
+        (textToAST "(foo #f def)")
+  , testCase "(foo def #t #f)" $
+      assertEqual "(foo def #t #f)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          (Just $ Variadic
+            (Just $ Leaf (Boolean True))
+            (Just $ Leaf (Boolean False))
+          )
+        )
+        (textToAST "(foo def #t #f)")
+  , testCase "(foo def #f #t)" $
+      assertEqual "(foo def #f #t)"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          (Just $ Variadic
+            (Just $ Leaf (Boolean False))
+            (Just $ Leaf (Boolean True))
+          )
+        )
+        (textToAST "(foo def #f #t)")
+  , testCase "(fst 1 (scd 2 3 4))" $
+      assertEqual "(fst 1 (scd 2 3 4))"
+        (Just $ Node "fst"
+          (Just $ Leaf (Number 1))
+          (Just $ Node "scd"
+            (Just $ Leaf (Number 2))
+            (Just $ Variadic
+              (Just $ Leaf (Number 3))
+              (Just $ Leaf (Number 4))
+            )
+          )
+        )
+        (textToAST "(fst 1 (scd 2 3 4))")
+  , testCase "(foo 42 )" $
+      assertEqual "(foo 42 )"
+        (Just $ Node "foo"
+          (Just $ Leaf (Number 42))
+          Nothing
+        )
+        (textToAST "(foo 42 )")
+  , testCase "(foo def )" $
+      assertEqual "(foo 42 )"
+        (Just $ Node "foo"
+          (Just $ Leaf (Symbol "def"))
+          Nothing
+        )
+        (textToAST "(foo def )")
   ]