From e5f3a53bcc339a9944db941dceb8d3af2bad9cc2 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Thu, 19 Dec 2024 18:57:57 -0600 Subject: [PATCH] 0.1.0 base collection of features Implemented evaluation of tree calculus terms alongside referentially transparent variable identifiers. Implemented evaluation of defined functions into tree calculus. --- sapling.cabal | 2 +- src/Eval.hs | 64 ++++++++++++++++++++++++++++++++++++++++++---- src/Lexer.hs | 4 +++ src/Main.hs | 3 ++- src/Parser.hs | 71 +++++++++++++++++++++++++++++++++++++++++++-------- test/Spec.hs | 43 ++++++++++++++++++++++++++----- 6 files changed, 163 insertions(+), 24 deletions(-) diff --git a/sapling.cabal b/sapling.cabal index 4b2a0b4..3072066 100644 --- a/sapling.cabal +++ b/sapling.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: sapling -version: 0.0.1 +version: 0.1.0 description: Tree Calculus experiment repository author: James Eversole maintainer: james@eversole.co diff --git a/src/Eval.hs b/src/Eval.hs index 2e443db..33b8e22 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -3,8 +3,62 @@ module Eval where import Parser import Research -evalSapling :: SaplingAST -> T -evalSapling TLeaf = Leaf -evalSapling (TStem t) = Stem (evalSapling t) -evalSapling (TFork t1 t2) = Fork (evalSapling t1) (evalSapling t2) -evalSapling _ = error "Evaluation currently only supported for Tree Calculus terms." +import qualified Data.Map as Map +import Data.Map (Map) + +evalSapling :: Map String T -> SaplingAST -> Map String T +evalSapling env TLeaf = Map.insert "__result" Leaf env +evalSapling env (TStem t) = + let result = Stem (evalTreeCalculus env t) + in Map.insert "__result" result env +evalSapling env (TFork t1 t2) = + let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2) + in Map.insert "__result" result env +evalSapling env (SFunc name [] body) = + let value = evalTreeCalculus env body + in Map.insert name value env +evalSapling env (SVar name) = + case Map.lookup name env of + Just value -> Map.insert "__result" value env + Nothing -> error $ "Variable " ++ name ++ " not defined" +evalSapling env ast = Map.insert "__result" (evalTreeCalculus env ast) env + +evalMulti :: Map String T -> [SaplingAST] -> Map String T +evalMulti env [] = env +evalMulti env [lastLine] = + let updatedEnv = evalSapling env lastLine + in Map.insert "__result" (result updatedEnv) updatedEnv +evalMulti env (line:rest) = + let updatedEnv = evalSapling env line + in evalMulti updatedEnv rest + +evalTreeCalculus :: Map.Map String T -> SaplingAST -> T +evalTreeCalculus _ TLeaf = Leaf +evalTreeCalculus env (TStem t) = Stem (evalTreeCalculus env t) +evalTreeCalculus env (TFork t1 t2) = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2) +evalTreeCalculus env (SApp base []) = evalTreeCalculus env base +evalTreeCalculus env (SApp base args) = + let func = evalTreeCalculus env base + argVals = map (evalTreeCalculus env) args + in foldl apply func argVals +evalTreeCalculus env (SVar name) = + case Map.lookup name env of + Just value -> value + Nothing -> error $ "Variable " ++ name ++ " not defined" +evalTreeCalculus _ (SStr str) = toString str +evalTreeCalculus _ (SInt num) = toNumber num +evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elems) +evalTreeCalculus _ (SFunc name args body) = + error $ "Unexpected function definition " ++ name ++ " in \ + \ evalTreeCalculus; functions should be evaluated to Tree Calculus \ + \ terms by evalSapling." + +result :: Map String T -> T +result r = case (Map.lookup "__result" r) of + Just a -> a + Nothing -> error "No __result field found in provided environment" + +toAST :: T -> SaplingAST +toAST Leaf = TLeaf +toAST (Stem a) = TStem (toAST a) +toAST (Fork a b) = TFork (toAST a) (toAST b) diff --git a/src/Lexer.hs b/src/Lexer.hs index 3c839b0..5ee1423 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -75,3 +75,7 @@ saplingLexer = many (sc *> choice , closeBracket , lnewline ]) <* eof + +lexSapling input = case runParser saplingLexer "" input of + Left err -> error "Failed to lex input" + Right tokens -> tokens diff --git a/src/Main.hs b/src/Main.hs index be272db..db39fc8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,7 +5,8 @@ import Lexer import Parser import Research +import Data.Map as Map import Text.Megaparsec (runParser) main :: IO () -main = putStr $ show $ parseSapling "false = t" +main = putStr $ show $ result $ evalMulti Map.empty (parseMulti "false = t\nnot = t (t (t t) (t t t)) t\ntrue = not false\ntrue") diff --git a/src/Parser.hs b/src/Parser.hs index c711784..c190545 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -20,11 +20,9 @@ data SaplingAST deriving (Show, Eq, Ord) parseSapling :: String -> SaplingAST -parseSapling input = case runParser saplingLexer "" input of - Left err -> error "RIP" - Right tokens -> case runParser parseExpression "" tokens of - Left err -> error "RIP" - Right ast -> ast +parseSapling input = case runParser parseExpression "" (lexSapling input) of + Left err -> error "Failed to parse input" + Right ast -> ast scnParser :: Parser () scnParser = skipMany (satisfy isNewline) @@ -48,9 +46,26 @@ parseFunction = do parseApplication :: Parser SaplingAST parseApplication = do - func <- parseAtomic + func <- parseAtomicBase args <- many parseAtomic - return (SApp func args) + case func of + TLeaf | not (null args) && all isTreeTerm args -> fail "Not an application, defer to Tree Calculus" + _ -> return (SApp func args) + +isTreeTerm :: SaplingAST -> Bool +isTreeTerm TLeaf = True +isTreeTerm (TStem _) = True +isTreeTerm (TFork _ _) = True +isTreeTerm _ = False + +parseAtomicBase :: Parser SaplingAST +parseAtomicBase = choice + [ parseVar + , parseTreeLeaf + ] + +parseTreeLeaf :: Parser SaplingAST +parseTreeLeaf = satisfy isKeywordT *> pure TLeaf getIdentifier :: LToken -> String getIdentifier (LIdentifier name) = name @@ -81,6 +96,7 @@ foldTree (x:y:rest) = TFork x (foldTree (y:rest)) parseAtomic :: Parser SaplingAST parseAtomic = choice [ parseVar + , parseTreeLeafOrParenthesized , parseLiteral , parseListLiteral , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression @@ -92,13 +108,43 @@ parseLiteral = choice , parseStrLiteral ] +parens :: Parser SaplingAST -> Parser SaplingAST +parens p = do + satisfy (== LOpenParen) + result <- p + satisfy (== LCloseParen) + return result + parseListLiteral :: Parser SaplingAST parseListLiteral = do - satisfy (== LOpenBracket) - elements <- sepEndBy parseExpression scnParser + satisfy (== LOpenBracket) + elements <- many parseListItem satisfy (== LCloseBracket) return (SList elements) +parseListItem :: Parser SaplingAST +parseListItem = parseGroupedItem <|> parseSingleItem + +parseGroupedItem :: Parser SaplingAST +parseGroupedItem = do + satisfy (== LOpenParen) + inner <- parseExpression + satisfy (== LCloseParen) + return inner + +parseSingleItem :: Parser SaplingAST +parseSingleItem = do + token <- satisfy isListItem + case token of + LIdentifier name -> return (SVar name) + LKeywordT -> return TLeaf + _ -> fail "Unexpected token in list item" + +isListItem :: LToken -> Bool +isListItem (LIdentifier _) = True +isListItem LKeywordT = True +isListItem _ = False + parseVar :: Parser SaplingAST parseVar = do LIdentifier name <- satisfy isIdentifier @@ -114,6 +160,12 @@ parseStrLiteral = do LStringLiteral value <- satisfy isStringLiteral return (SStr value) +parseMulti :: String -> [SaplingAST] +parseMulti input = + let nonEmptyLines = filter (not . null) (lines input) + in map parseSapling nonEmptyLines + +-- Boolean Helpers isKeywordT (LKeywordT) = True isKeywordT _ = False @@ -128,4 +180,3 @@ isStringLiteral _ = False isNewline (LNewline) = True isNewline _ = False - diff --git a/test/Spec.hs b/test/Spec.hs index a5617e6..b9e43f5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,6 +5,7 @@ import Lexer import Parser import Research +import qualified Data.Map as Map import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -77,36 +78,64 @@ evaluationTests = testGroup "Evaluation Tests" [ testCase "Evaluate single Leaf" $ do let input = "t" let ast = parseSapling input - evalSapling ast @?= Leaf + (result $ evalSapling Map.empty ast) @?= Leaf , testCase "Evaluate single Stem" $ do let input = "t t" let ast = parseSapling input - evalSapling ast @?= Stem Leaf + (result $ evalSapling Map.empty ast) @?= Stem Leaf , testCase "Evaluate single Fork" $ do let input = "t t t" let ast = parseSapling input - evalSapling ast @?= Fork Leaf Leaf + (result $ evalSapling Map.empty ast) @?= Fork Leaf Leaf , testCase "Evaluate nested Fork and Stem" $ do let input = "t (t t) t" let ast = parseSapling input - evalSapling ast @?= Fork (Stem Leaf) Leaf + (result $ evalSapling Map.empty ast) @?= Fork (Stem Leaf) Leaf , testCase "Evaluate `not` function" $ do let input = "t (t (t t) (t t t)) t)" let ast = parseSapling input - evalSapling ast @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf + (result $ evalSapling Map.empty ast) @?= + Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf + + , testCase "Environment updates with definitions" $ do + let input = "x = t\ny = x" + let env = evalMulti Map.empty (parseMulti input) + Map.lookup "x" env @?= Just Leaf + Map.lookup "y" env @?= Just Leaf + + , testCase "Variable substitution" $ do + let input = "x = t t\ny = t x\ny" + let env = evalMulti Map.empty (parseMulti input) + (result env) @?= Stem (Stem Leaf) + + , testCase "Multiline input evaluation" $ do + let input = "x = t\ny = t t\nx" + let env = evalMulti Map.empty (parseMulti input) + (result env) @?= Leaf + + , testCase "Evaluate string literal" $ do + let input = "\"hello\"" + let ast = parseSapling input + (result $ evalSapling Map.empty ast) @?= toString "hello" + + , testCase "Evaluate list literal" $ do + let input = "[t (t t)]" + let ast = parseSapling input + (result $ evalSapling Map.empty ast) @?= toList [Leaf, Stem Leaf] + ] propertyTests :: TestTree propertyTests = testGroup "Property Tests" [ testProperty "Lexing and parsing round-trip" $ \input -> case runParser saplingLexer "" input of - Left _ -> property True -- Ignore invalid lexes + Left _ -> property True Right tokens -> case runParser parseExpression "" tokens of - Left _ -> property True -- Ignore invalid parses + Left _ -> property True Right ast -> parseSapling input === ast ]