From b5f5af2ce0eb0e19986b58a106d6177019c92c83 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Tue, 5 Dec 2023 16:23:15 +0100 Subject: [PATCH 1/7] Interpreter v.0: Add debug --- app/Main.hs | 2 +- src/AST.hs | 6 ++++-- src/TextToAST.hs | 45 +++++++++++++++++++++++++++++---------------- 3 files changed, 34 insertions(+), 19 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index abc153c..3298f61 100644 --- a/app/Main.hs +++ b/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)")) diff --git a/src/AST.hs b/src/AST.hs index bf7a104..117523d 100644 --- a/src/AST.hs +++ b/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" diff --git a/src/TextToAST.hs b/src/TextToAST.hs index 107b602..6e2980e 100644 --- a/src/TextToAST.hs +++ b/src/TextToAST.hs @@ -10,6 +10,7 @@ module TextToAST textToAST ) where +import Debug.Trace import AST import Data.Int (Int64) import Data.Char (isDigit) @@ -47,6 +48,11 @@ 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 @@ -54,17 +60,24 @@ 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 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 -countAtoms str depth | depth >= 2 = 2 +countAtoms str depth | depth >= 2 = trace ("maxdepth") $ 2 | not (null $ takeWhile (/= ')') - (dropWhile skipableChar str)) = + (dropWhile skipableChar str)) = trace ("+1atom, str: " ++ str ++ " parseRes: " ++ (nextToParse str)) $ countAtoms (nextToParse str) (depth + 1) | otherwise = depth @@ -72,16 +85,16 @@ 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,7 +127,8 @@ 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)) @@ -122,7 +136,6 @@ treeFromAtom split str | stringIsNumber 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)) From 1e847472ee90c3a7b42d2fd802a3def2208afe64 Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Tue, 5 Dec 2023 16:33:57 +0100 Subject: [PATCH 2/7] Interpreter v.0: Add tests --- test/Spec.hs | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 48a0fce..ca9a043 100644 --- a/test/Spec.hs +++ b/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,41 @@ 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)") ] From 97bbbf738f3dd9b7724d2bef2747ff6bb20faaad Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Tue, 5 Dec 2023 15:35:03 +0000 Subject: [PATCH 3/7] Fix tests PATCH --- src/TextToAST.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TextToAST.hs b/src/TextToAST.hs index 6e2980e..400f101 100644 --- a/src/TextToAST.hs +++ b/src/TextToAST.hs @@ -67,7 +67,7 @@ cutAtClose (x:xs) = (x:cutAtClose xs) nextToParse :: String -> String nextToParse [] = [] -nextToParse ('(':xs) = nextToParse' xs 0 +nextToParse ('(':xs) = nextToParse' xs 1 nextToParse str | skipableChar (head str) = nextToParse (dropWhile skipableChar str) | (last str) == ')' = nextToParse (popBackPrths str) | otherwise = dropWhile skipableChar From 7da39079dfb73555bea099ad9b30b380f032e10c Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Tue, 5 Dec 2023 16:48:35 +0100 Subject: [PATCH 4/7] Interpreter v.0: Add tests --- src/TextToAST.hs | 5 ++--- test/Spec.hs | 26 ++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/src/TextToAST.hs b/src/TextToAST.hs index 400f101..781abc9 100644 --- a/src/TextToAST.hs +++ b/src/TextToAST.hs @@ -10,7 +10,6 @@ module TextToAST textToAST ) where -import Debug.Trace import AST import Data.Int (Int64) import Data.Char (isDigit) @@ -74,10 +73,10 @@ nextToParse str | skipableChar (head str) = nextToParse (dropWhile skipableChar (dropWhile notSkipableChar (dropWhile skipableChar str)) countAtoms :: String -> Int -> Int -countAtoms str depth | depth >= 2 = trace ("maxdepth") $ 2 +countAtoms str depth | depth >= 2 = 2 | not (null $ takeWhile (/= ')') - (dropWhile skipableChar str)) = trace ("+1atom, str: " ++ str ++ " parseRes: " ++ (nextToParse str)) $ + (dropWhile skipableChar str)) = countAtoms (nextToParse str) (depth + 1) | otherwise = depth diff --git a/test/Spec.hs b/test/Spec.hs index ca9a043..8879c79 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -172,4 +172,30 @@ unitTestsASTParse = testGroup "AST Parse Tests" (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)))") ] From 9217e32efde1e9a3dfe8183b9c1018909edb1c3e Mon Sep 17 00:00:00 2001 From: guillaume abel Date: Tue, 5 Dec 2023 16:55:11 +0100 Subject: [PATCH 5/7] Interpreter v.0: Fix norm --- src/TextToAST.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/TextToAST.hs b/src/TextToAST.hs index 781abc9..9f2783f 100644 --- a/src/TextToAST.hs +++ b/src/TextToAST.hs @@ -67,7 +67,8 @@ cutAtClose (x:xs) = (x:cutAtClose xs) nextToParse :: String -> String nextToParse [] = [] nextToParse ('(':xs) = nextToParse' xs 1 -nextToParse str | skipableChar (head str) = nextToParse (dropWhile skipableChar str) +nextToParse str | skipableChar (head str) = nextToParse + (dropWhile skipableChar str) | (last str) == ')' = nextToParse (popBackPrths str) | otherwise = dropWhile skipableChar (dropWhile notSkipableChar (dropWhile skipableChar str)) @@ -87,7 +88,8 @@ createVariadic str = 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 (_:xs) str _ 0 = Just (Node xs (textToAST str) + (Just Empty)) createNodeFromFunction _ [] _ _ = Nothing createNodeFromFunction (_:xs) str tail_ 1 = Just (Node xs (textToAST str) (textToAST tail_)) From 9f6cfc194eb5efaada2c34724da4627b7d468462 Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Tue, 5 Dec 2023 16:15:42 +0000 Subject: [PATCH 6/7] Add coverage to documentation MINOR --- .github/workflows/documentation.yml | 12 ++++++++++++ Makefile | 6 ++++++ docs/Coverage.md | 1 + docs/SUMMARY.md | 3 ++- 4 files changed, 21 insertions(+), 1 deletion(-) create mode 100644 docs/Coverage.md diff --git a/.github/workflows/documentation.yml b/.github/workflows/documentation.yml index 267b8cb..ee2702f 100644 --- a/.github/workflows/documentation.yml +++ b/.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 diff --git a/Makefile b/Makefile index 96bb1b1..af2ae18 100644 --- a/Makefile +++ b/Makefile @@ -36,4 +36,10 @@ re: fclean $(TARGET) tests: stack test +tests-coverage: + stack test --coverage + +tests-coverage-html-path: + echo "$(stack path --local-hpc-root)" + .PHONY: $(TARGET) fclean re clean all diff --git a/docs/Coverage.md b/docs/Coverage.md new file mode 100644 index 0000000..3bccffe --- /dev/null +++ b/docs/Coverage.md @@ -0,0 +1 @@ +# this will be overwiten by the tests ... diff --git a/docs/SUMMARY.md b/docs/SUMMARY.md index 6b4a296..d4fe094 100644 --- a/docs/SUMMARY.md +++ b/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) From 2cdcbd9d0038b37500cfac5f915e3b0254bff88e Mon Sep 17 00:00:00 2001 From: Xavier Mitault Date: Wed, 6 Dec 2023 17:10:02 +0000 Subject: [PATCH 7/7] Fix documentation PATCH --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index af2ae18..294c12a 100644 --- a/Makefile +++ b/Makefile @@ -40,6 +40,6 @@ tests-coverage: stack test --coverage tests-coverage-html-path: - echo "$(stack path --local-hpc-root)" + @stack path --local-hpc-root .PHONY: $(TARGET) fclean re clean all