diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index b89f8ee..dd66015 100644 --- a/.github/workflows/tests.yml +++ b/.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 diff --git a/.gitignore b/.gitignore index 826e993..b1e48a8 100644 --- a/.gitignore +++ b/.gitignore @@ -166,7 +166,7 @@ tags .idea/* -/koaky +/koaky-exe /glados *.log diff --git a/app/Main.hs b/app/Main.hs index 8c240f6..abc153c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,5 +7,8 @@ module Main (main) where +import AST (showMaybeTree) +import TextToAST (textToAST) + main :: IO () -main = putStrLn "Hello, World!" +main = putStrLn (showMaybeTree (textToAST "(define javascriptIsGood #f 42)")) diff --git a/src/AST.hs b/src/AST.hs index bf6f5a8..bf7a104 100644 --- a/src/AST.hs +++ b/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 ++ "}" diff --git a/src/TextToAST.hs b/src/TextToAST.hs index 4b06767..107b602 100644 --- a/src/TextToAST.hs +++ b/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)) diff --git a/test/Spec.hs b/test/Spec.hs index c9add35..a80f47b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,7 @@ import Test.Tasty.HUnit import Test.Tasty.Runners.Html import AST +import TextToAST main :: IO () main = defaultMainWithIngredients (htmlRunner : defaultIngredients) tests @@ -10,14 +11,144 @@ main = defaultMainWithIngredients (htmlRunner : defaultIngredients) tests tests :: TestTree tests = testGroup "Tests" [unitTests, computeTests] -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 )") ] computeTests :: TestTree