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

@@ -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

src/Eval.hs

@@ -3,8 +3,62 @@ module Eval where
 import Parser
 import Research
 
-evalSapling :: SaplingAST -> T
+import qualified Data.Map as Map
-evalSapling TLeaf = Leaf
+import           Data.Map   (Map)
-evalSapling (TStem t) = Stem (evalSapling t)
+
-evalSapling (TFork t1 t2) = Fork (evalSapling t1) (evalSapling t2)
+evalSapling :: Map String T -> SaplingAST -> Map String T
-evalSapling _ = error "Evaluation currently only supported for Tree Calculus terms."
+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)

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

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")

src/Parser.hs

@@ -20,10 +20,8 @@ data SaplingAST
   deriving (Show, Eq, Ord)
 
 parseSapling :: String -> SaplingAST
-parseSapling input = case runParser saplingLexer "" input of
+parseSapling input = case runParser parseExpression "" (lexSapling input) of
-  Left err -> error "RIP"
+  Left err -> error "Failed to parse input"
-  Right tokens -> case runParser parseExpression "" tokens of
-    Left err -> error "RIP"
   Right ast -> ast
 
 scnParser :: Parser ()
@@ -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
+  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
-

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
   ]