commit 7ae470a4aee14aa605d3bf309811d9d975a125ff
parent dcf8120deaf34a6d81c4040491d52b573b6dfe90
Author: James Eversole <james@eversole.co>
Date: Thu, 19 Dec 2024 18:57:57 -0600
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.
Diffstat:
6 files changed, 163 insertions(+), 24 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
]
