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.

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)

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