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..294c12a 100644 --- a/Makefile +++ b/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 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/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) 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..9f2783f 100644 --- a/src/TextToAST.hs +++ b/src/TextToAST.hs @@ -47,6 +47,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,10 +59,18 @@ 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,7 +128,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 +137,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)) diff --git a/test/Spec.hs b/test/Spec.hs index 48a0fce..8879c79 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,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)))") ]