Parser more testing

.github/workflows/documentation.yml

@@ -68,6 +68,18 @@ jobs:
             exit 0
           fi
 
+      - name: Coverage
+        if: steps.filter.outputs.docs == 'true' || steps.filter.outputs.docs2 == 'true' || steps.filter.outputs.workflow == 'true' || github.ref == 'refs/heads/main'
+        run: |
+          if ! make tests-coverage; then
+            exit 0
+          else
+            PATH_HTML=$(make tests-coverage-html-path)
+            cp -r "$PATH_HTML/koaky" book/
+            cp -r "$PATH_HTML/combined" book/
+            cp "$PATH_HTML/index.html" book/Coverage.html
+          fi
+
       - name: Setup Pages
         if: github.ref == 'refs/heads/main'
         uses: actions/configure-pages@v3

Makefile

@@ -36,4 +36,10 @@ re: fclean $(TARGET)
 tests:
 	stack test
 
+tests-coverage:
+	stack test --coverage
+
+tests-coverage-html-path:
+	@stack path --local-hpc-root
+
 .PHONY: $(TARGET) fclean re clean all

app/Main.hs

@@ -11,4 +11,4 @@ import AST (showMaybeTree)
 import TextToAST (textToAST)
 
 main :: IO ()
-main = putStrLn (showMaybeTree (textToAST "(define javascriptIsGood #f 42)"))
+main = putStrLn (showMaybeTree (textToAST "(fst 1 (scd 2 3 4) 12)"))

docs/Coverage.md

@@ -0,0 +1 @@
+# this will be overwiten by the tests ...

docs/SUMMARY.md

@@ -4,4 +4,5 @@ This is a new amazing programming language
 made in Haskell.
 
 [README](README.md)
-[Tests](Tests.md)
+[:link: Tests](Tests.md)
+[:link: Coverage](Coverage.md)

src/AST.hs

@@ -9,7 +9,7 @@ module AST
     (
         Symbol,
         Atom (Number, Symbol, Boolean),
-        Tree (Node, Leaf, Variadic),
+        Tree (Node, Leaf, Variadic, Empty),
         showMaybeTree
     ) where
 
@@ -19,7 +19,7 @@ type Symbol = String
 
 data Atom = Number Int64 | Symbol Symbol | Boolean Bool
 
-data Tree = Node Symbol (Maybe Tree) (Maybe Tree) | Leaf Atom | Variadic (Maybe Tree) (Maybe Tree)
+data Tree = Node Symbol (Maybe Tree) (Maybe Tree) | Leaf Atom | Variadic (Maybe Tree) (Maybe Tree) | Empty
 
 showMaybeTree :: Maybe Tree -> String
 showMaybeTree Nothing = "Nothing"
@@ -40,9 +40,11 @@ instance Eq Tree where
     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
+    Empty == Empty = True
     _ == _ = False
 
 instance Show Tree where
     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 ++ "}"
+    show (Empty) = "Empty"

src/TextToAST.hs

@@ -47,17 +47,30 @@ parseStringNumber str =
         (takeWhile (\x -> notSkipableChar x && x /= ')') str)
         :: Data.Int.Int64)
 
+popBackPrths :: String -> String
+popBackPrths [] = []
+popBackPrths [')'] = []
+popBackPrths (x:xs) = (x:popBackPrths xs)
+
 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
 
+cutAtClose :: String -> String
+cutAtClose [] = []
+cutAtClose (')':_) = []
+cutAtClose (x:xs) = (x:cutAtClose xs)
+
 nextToParse :: String -> String
 nextToParse [] = []
-nextToParse ('(':xs) = nextToParse' xs 0
-nextToParse str = dropWhile skipableChar
+nextToParse ('(':xs) = nextToParse' xs 1
+nextToParse str | skipableChar (head str) = nextToParse
+                    (dropWhile skipableChar str)
+                | (last str) == ')' = nextToParse (popBackPrths str)
+                | otherwise = dropWhile skipableChar
     (dropWhile notSkipableChar (dropWhile skipableChar str))
 
 countAtoms :: String -> Int -> Int
@@ -72,16 +85,17 @@ 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
+createNodeFromFunction :: Symbol -> String -> String -> Int -> Maybe Tree
+createNodeFromFunction [] _ _ _ = Nothing
+createNodeFromFunction (_:xs) [] _ 0 = Just (Leaf (Symbol xs))
+createNodeFromFunction (_:xs) str _ 0 = Just (Node xs (textToAST str)
+                                      (Just Empty))
+createNodeFromFunction _ [] _ _ = Nothing
+createNodeFromFunction (_:xs) str tail_ 1 = Just (Node xs (textToAST str)
+    (textToAST tail_))
+createNodeFromFunction (_:xs) str tail_ 2 =
+    Just (Node xs (textToAST str) (createVariadic tail_))
+createNodeFromFunction _ _ _ _ = Nothing
 
 stringIsBool :: String -> Bool
 stringIsBool "#t" = True
@@ -114,15 +128,15 @@ treeFromAtom split str | stringIsNumber split =
                        | stringIsBool split = createBool split
                        | isFunction split = createNodeFromFunction
                             (takeWhile (/= ')') split)
-                            str
+                            (cutAtClose str)
+                            (nextToParse 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
+                 | otherwise = treeFromAtom
                         (takeWhile notSkipableChar (x:xs))
                         (dropWhile notSkipableChar (x:xs))

test/Spec.hs

@@ -72,13 +72,13 @@ unitTestsASTParse = testGroup "AST Parse Tests"
         (textToAST "foo")
   , testCase "(foo)" $
       assertEqual "(foo)"
-        (Just $ Node "foo" Nothing Nothing)
+        (Just $ Leaf (Symbol "foo"))
         (textToAST "(foo)")
   , testCase "(foo def)" $
       assertEqual "(foo def)"
         (Just $ Node "foo"
           (Just $ Leaf (Symbol "def"))
-          Nothing
+          (Just $ Empty)
         )
         (textToAST "(foo def)")
   , testCase "(foo def #t)" $
@@ -135,18 +135,67 @@ unitTestsASTParse = testGroup "AST Parse Tests"
           )
         )
         (textToAST "(fst 1 (scd 2 3 4))")
+  , testCase "(fst 1 (scd 2 3 4) 12)" $
+      assertEqual "(fst 1 (scd 2 3 4) 12)"
+        (Just $ Node "fst"
+          (Just $ Leaf (Number 1))
+          (Just $ Variadic
+            (Just $ Node "scd"
+              (Just $ Leaf (Number 2))
+              (Just $ Variadic
+                (Just $ Leaf (Number 3))
+                (Just $ Leaf (Number 4))
+              )
+            )
+            (Just $ Leaf (Number 12))
+          )
+        )
+        (textToAST "(fst 1 (scd 2 3 4) 12)")
   , testCase "(foo 42 )" $
       assertEqual "(foo 42 )"
         (Just $ Node "foo"
           (Just $ Leaf (Number 42))
-          Nothing
+          (Just $ Empty)
         )
         (textToAST "(foo 42 )")
   , testCase "(foo def )" $
-      assertEqual "(foo 42 )"
+      assertEqual "(foo def )"
         (Just $ Node "foo"
           (Just $ Leaf (Symbol "def"))
-          Nothing
+          (Just $ Empty)
         )
         (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 "(do (re (mi)) 12)" $
+      assertEqual "(do (re (mi)) 12)"
+        (Just $ Node "do"
+          (Just $ Node "re"
+            (Just $ Leaf (Symbol "mi"))
+            (Just $ Empty)
+          )
+          (Just $ Leaf (Number 12))
+        )
+        (textToAST "(do (re (mi)) 12)")
+  , testCase "(do (re (mi)) 12 (re (mi)))" $
+      assertEqual "(do (re (mi)) 12 (re (mi)))"
+        (Just $ Node "do"
+          (Just $ Node "re"
+            (Just $ Leaf (Symbol "mi"))
+            (Just $ Empty)
+          )
+          (Just $ Variadic
+            (Just $ Leaf (Number 12))
+            (Just $ Node "re"
+              (Just $ Leaf (Symbol "mi"))
+              (Just $ Empty)
+            )
+          )
+        )
+        (textToAST "(do (re (mi)) 12 (re (mi)))")
   ]