Initialize Repo

Working (but likely buggy!) lexing, parsing, and evaluation of Tree Calculus terms

.gitignore

@@ -0,0 +1,13 @@
+bin/
+data/Purr.sqlite
+data/encryptionKey
+/result
+/config.dhall
+/Dockerfile
+/docker-stack.yml
+.stack-work/
+*.swp
+dist*
+*~
+.env
+WD

flake.lock

@@ -0,0 +1,60 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1731533236,
+        "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1734566935,
+        "narHash": "sha256-cnBItmSwoH132tH3D4jxmMLVmk8G5VJ6q/SC3kszv9E=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "087408a407440892c1b00d80360fd64639b8091d",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,66 @@
+{
+  description = "sapling";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs              = nixpkgs.legacyPackages.${system};
+        packageName       = "sapling";
+        containerPackageName = "${packageName}-container";
+
+        customGHC = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
+          megaparsec
+        ]);
+
+        haskellPackages = pkgs.haskellPackages;
+
+        enableSharedExecutables = false;
+        enableSharedLibraries = false;
+
+        sapling = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
+      in {
+
+        packages.${packageName} =
+          haskellPackages.callCabal2nix packageName self rec {};
+
+        packages.default = self.packages.${system}.${packageName};
+        defaultPackage = self.packages.${system}.default;
+
+        devShells.default = pkgs.mkShell {
+          buildInputs = with pkgs.haskellPackages; [
+            cabal-install
+            ghcid
+            customGHC
+          ];
+          inputsFrom = builtins.attrValues self.packages.${system};
+        };
+        devShell = self.devShells.${system}.default;
+
+        packages.${containerPackageName} = pkgs.dockerTools.buildImage {
+          name = "sapling";
+
+          copyToRoot = pkgs.buildEnv {
+            name = "image-root";
+            paths = [ sapling ];
+            pathsToLink = [ "/bin" ];
+          };
+          tag = "latest";
+          config = {
+            Cmd = [
+              "/bin/sapling"
+            ];
+            WorkingDir = "/app";
+            ExposedPorts = {
+              "3000/tcp" = {};
+            };
+            extraCommands = ''
+            '';
+          };
+        };
+      });
+}

sapling.cabal

@@ -0,0 +1,58 @@
+cabal-version: 1.12
+
+name:           sapling
+version:        0.0.1
+description:    Tree Calculus Experiment
+author:         James Eversole
+maintainer:     james@eversole.co
+copyright:      James Eversole
+license:        ISC
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README
+    ChangeLog.md
+
+executable sapling
+  main-is: Main.hs
+  hs-source-dirs:
+      src
+  default-extensions:
+      ConstraintKinds
+      DeriveGeneric
+      FlexibleContexts
+      FlexibleInstances
+      GeneralizedNewtypeDeriving
+      OverloadedStrings
+      ScopedTypeVariables
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
+  build-depends:
+    base >=4.7
+    , containers
+    , megaparsec
+    , mtl
+  other-modules:
+    Eval
+    Lexer
+    Parser
+    Research
+  default-language: Haskell2010
+
+test-suite sapling-tests
+  type:                exitcode-stdio-1.0
+  main-is:             Spec.hs
+  hs-source-dirs:      test, src
+  build-depends:       
+    base
+    , containers
+    , megaparsec
+    , mtl
+    , tasty
+    , tasty-hunit
+    , tasty-quickcheck
+  default-language:    Haskell2010
+  other-modules:
+    Eval
+    Lexer
+    Parser
+    Research

shell.nix

@@ -0,0 +1,8 @@
+{ pkgs ? import <nixpkgs> {} }:
+let x = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
+		megaparsec
+  ]);
+in
+pkgs.mkShell {
+  buildInputs = [ x ];
+}

src/Eval.hs

@@ -0,0 +1,10 @@
+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."

src/Lexer.hs

@@ -0,0 +1,77 @@
+module Lexer where
+
+import Research
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Void
+
+type Lexer = Parsec Void String
+data LToken
+  = LKeywordT
+  | LIdentifier String
+  | LIntegerLiteral Int
+  | LStringLiteral String
+  | LAssign
+  | LOpenParen
+  | LCloseParen
+  | LOpenBracket
+  | LCloseBracket
+  | LNewline
+  deriving (Show, Eq, Ord)
+
+keywordT :: Lexer LToken
+keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
+
+identifier :: Lexer LToken
+identifier = do
+  name <- some (letterChar <|> char '_' <|> char '-')
+  if name == "t"
+    then fail "Keyword 't' cannot be used as an identifier"
+    else return (LIdentifier name)
+
+integerLiteral :: Lexer LToken
+integerLiteral = do
+  num <- some digitChar
+  return (LIntegerLiteral (read num))
+
+stringLiteral :: Lexer LToken
+stringLiteral = do
+  char '"'
+  content <- many (noneOf ['"'])
+  char '"' --"
+  return (LStringLiteral content)
+
+assign :: Lexer LToken
+assign = char '=' *> pure LAssign
+
+openParen :: Lexer LToken
+openParen = char '(' *> pure LOpenParen
+
+closeParen :: Lexer LToken
+closeParen = char ')' *> pure LCloseParen
+
+openBracket :: Lexer LToken
+openBracket = char '[' *> pure LOpenBracket
+
+closeBracket :: Lexer LToken
+closeBracket = char ']' *> pure LCloseBracket
+
+lnewline :: Lexer LToken
+lnewline = char '\n' *> pure LNewline
+
+sc :: Lexer ()
+sc = skipMany (char ' ' <|> char '\t')
+
+saplingLexer :: Lexer [LToken]
+saplingLexer = many (sc *> choice
+  [ try keywordT
+  , try identifier
+  , try integerLiteral
+  , try stringLiteral
+  , assign
+  , openParen
+  , closeParen
+  , openBracket
+  , closeBracket
+  , lnewline
+  ]) <* eof

src/Main.hs

@@ -0,0 +1,11 @@
+module Main where
+
+import Eval
+import Lexer
+import Parser
+import Research
+
+import Text.Megaparsec (runParser)
+
+main :: IO ()
+main = putStr $ show $ parseSapling "false = t"

src/Parser.hs

@@ -0,0 +1,131 @@
+module Parser where
+
+import Lexer
+import Research
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Void
+
+type Parser = Parsec Void [LToken]
+data SaplingAST
+  = SVar String
+  | SInt Int
+  | SStr String
+  | SList [SaplingAST]
+  | SFunc String [String] SaplingAST
+  | SApp SaplingAST [SaplingAST]
+  | TLeaf
+  | TStem SaplingAST
+  | TFork SaplingAST 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
+
+scnParser :: Parser ()
+scnParser = skipMany (satisfy isNewline)
+
+parseExpression :: Parser SaplingAST
+parseExpression = choice
+  [ try parseFunction
+  , try parseApplication
+  , parseTreeTerm
+  , parseLiteral
+  , parseListLiteral
+  ]
+
+parseFunction :: Parser SaplingAST
+parseFunction = do
+  LIdentifier name <- satisfy isIdentifier
+  args <- many (satisfy isIdentifier)
+  satisfy (== LAssign)
+  body <- parseExpression
+  return (SFunc name (map getIdentifier args) body)
+
+parseApplication :: Parser SaplingAST
+parseApplication = do
+  func <- parseAtomic
+  args <- many parseAtomic
+  return (SApp func args)
+
+getIdentifier :: LToken -> String
+getIdentifier (LIdentifier name) = name
+getIdentifier _ = error "Expected identifier"
+
+parseTreeTerm :: Parser SaplingAST
+parseTreeTerm = do
+  base <- parseTreeLeafOrParenthesized
+  rest <- many parseTreeLeafOrParenthesized
+  pure $ foldl combine base rest
+  where
+    combine acc next = case acc of
+      TLeaf     -> TStem next
+      TStem t   -> TFork t next
+      TFork _ _ -> TFork acc next
+
+parseTreeLeafOrParenthesized :: Parser SaplingAST
+parseTreeLeafOrParenthesized = choice
+  [ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
+  , satisfy isKeywordT *> pure TLeaf
+  ]
+
+foldTree :: [SaplingAST] -> SaplingAST
+foldTree [] = TLeaf
+foldTree [x] = x
+foldTree (x:y:rest) = TFork x (foldTree (y:rest))
+
+parseAtomic :: Parser SaplingAST
+parseAtomic = choice
+  [ parseVar
+  , parseLiteral
+  , parseListLiteral
+  , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
+  ]
+
+parseLiteral :: Parser SaplingAST
+parseLiteral = choice
+  [ parseIntLiteral
+  , parseStrLiteral
+  ]
+
+parseListLiteral :: Parser SaplingAST
+parseListLiteral = do
+  satisfy (== LOpenBracket) 
+  elements <- sepEndBy parseExpression scnParser
+  satisfy (== LCloseBracket)
+  return (SList elements)
+
+parseVar :: Parser SaplingAST
+parseVar = do 
+  LIdentifier name <- satisfy isIdentifier
+  return (SVar name)
+
+parseIntLiteral :: Parser SaplingAST
+parseIntLiteral = do
+  LIntegerLiteral value <- satisfy isIntegerLiteral
+  return (SInt value)
+
+parseStrLiteral :: Parser SaplingAST
+parseStrLiteral = do
+  LStringLiteral value <- satisfy isStringLiteral
+  return (SStr value)
+
+isKeywordT        (LKeywordT)        = True
+isKeywordT                        _  = False
+
+isIdentifier      (LIdentifier    _) = True
+isIdentifier                      _  = False
+
+isIntegerLiteral (LIntegerLiteral _) = True
+isIntegerLiteral                  _  = False
+
+isStringLiteral  (LStringLiteral  _) = True
+isStringLiteral                   _  = False
+
+isNewline        (LNewline)          = True
+isNewline                         _  = False
+

src/Research.hs

@@ -0,0 +1,142 @@
+module Research where
+
+import Data.List (intercalate)
+import Control.Monad.State
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+data T
+  = Leaf     -- t
+  | Stem T   -- t t
+  | Fork T T -- t a b
+  deriving (Show, Eq, Ord)
+
+apply :: T -> T -> T
+apply Leaf b                            = Stem b
+apply (Stem a) b                        = Fork a b
+apply (Fork Leaf a) _                   = a
+apply (Fork (Stem a1) a2) b             = apply (apply a1 b) (apply a2 b)
+apply (Fork (Fork a1 a2) a3) Leaf       = a1
+apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u
+apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v
+
+reduce :: T -> T
+reduce expr =
+  let next = step expr
+  in if next == expr then expr else reduce next
+
+step :: T -> T
+step (Fork left right) = reduce (apply (reduce left) (reduce right))
+step (Stem inner) = Stem (reduce inner) 
+step t = t 
+
+-- SKI Combinators
+_S :: T
+_S = Fork (Stem (Fork Leaf Leaf)) Leaf
+
+_K :: T
+_K = Stem Leaf
+
+_I :: T
+_I = apply (apply _S _K) _K -- Fork (Stem (Stem Leaf)) (Stem Leaf)
+
+-- Lambda
+data Lambda
+  = Var String
+  | App Lambda Lambda
+  | Lam String Lambda
+  | TC T
+  deriving (Show, Eq)
+
+-- Booleans
+_false :: T
+_false = Leaf
+
+_true :: T
+_true = Stem Leaf
+
+_not :: T
+_not = Fork (Fork _true (Fork Leaf _false)) Leaf
+
+-- Marshalling
+toString :: String -> T
+toString str = toList (map toNumber (map fromEnum str))
+
+ofString :: T -> String
+ofString tc = map (toEnum . ofNumber) (ofList tc)
+
+toNumber :: Int -> T 
+toNumber 0 = Leaf
+toNumber n =
+  Fork
+    (if odd n then Stem Leaf else Leaf)
+    (toNumber (n `div` 2)) 
+
+ofNumber :: T -> Int
+ofNumber Leaf = 0
+ofNumber (Fork Leaf rest) = 2 * ofNumber rest
+ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
+ofNumber _ = error "Invalid Tree Calculus number" 
+
+toList :: [T] -> T 
+toList [] = Leaf
+toList (x:xs) = Fork x (toList xs)
+
+ofList :: T -> [T]
+ofList Leaf = []
+ofList (Fork x rest) = x : ofList rest
+ofList _ = error "Invalid Tree Calculus list"
+
+-- Utility
+toAscii :: T -> String
+toAscii tree = go tree "" True
+  where
+    go :: T -> String -> Bool -> String
+    go Leaf prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Leaf\n"
+    go (Stem t) prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Stem\n"
+        ++ go t (prefix ++ (if isLast then "    " else "|   ")) True
+    go (Fork left right) prefix isLast =
+      prefix ++ (if isLast then "`-- " else "|-- ") ++ "Fork\n"
+        ++ go left (prefix ++ (if isLast then "    " else "|   ")) False
+        ++ go right (prefix ++ (if isLast then "    " else "|   ")) True
+
+rules :: IO ()
+rules = putStr $ header 
+              ++ (unlines $ tcRules) 
+              ++ (unlines $ haskellRules)
+              ++ footer
+  where
+    tcRules :: [String]
+    tcRules = 
+      [ "|                                                                               |"
+      , "|                  ┌--------- | Tree Calculus | ---------┐                      |"
+      , "|                  | 1.  t  t      a b       -> a        |                      |"
+      , "|                  | 2.  t (t a)   b c       -> a c (b c)|                      |"
+      , "|                  | 3a. t (t a b) c t       -> a        |                      |"
+      , "|                  | 3b. t (t a b) c (t u)   -> b u      |                      |"
+      , "|                  | 3c. t (t a b) c (t u v) -> c u v    |                      |"
+      , "|                  └-------------------------------------┘                      |"
+      , "|                                                                               |"
+      ]
+    haskellRules :: [String]
+    haskellRules =
+      [ "| ┌------------------------------ | Haskell | --------------------------------┐ |"
+      , "| |                                                                           | |"
+      , "| | data T = Leaf | Stem T | Fork TT                                          | |"
+      , "| |                                                                           | |"
+      , "| | apply :: T -> T -> T                                                      | |"
+      , "| | apply Leaf b                            = Stem b                          | |"
+      , "| | apply (Stem a) b                        = Fork a b                        | |"
+      , "| | apply (Fork Leaf a) _                   = a                               | |"
+      , "| | apply (Fork (Stem a1) a2) b             = apply (apply a1 b) (apply a2 b) | |"
+      , "| | apply (Fork (Fork a1 a2) a3) Leaf       = a1                              | |"
+      , "| | apply (Fork (Fork a1 a2) a3) (Stem u)   = apply a2 u                      | |"
+      , "| | apply (Fork (Fork a1 a2) a3) (Fork u v) = apply (apply a3 u) v            | |"
+      , "| └---------------------------------------------------------------------------┘ |"
+      ]
+    header :: String
+    header = "┌-------------------- | Rules for evaluating Tree Calculus | -------------------┐\n"
+    footer :: String
+    footer = "└-------------------- | Rules for evaluating Tree Calculus | -------------------┘\n"

test/Spec.hs

@@ -0,0 +1,112 @@
+module Main where
+
+import Eval
+import Lexer
+import Parser
+import Research
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+import Text.Megaparsec (runParser)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Sapling Tests"
+  [ lexerTests
+  , parserTests
+  , integrationTests
+  , evaluationTests
+  , propertyTests
+  ]
+
+lexerTests :: TestTree
+lexerTests = testGroup "Lexer Tests"
+  [ testCase "Lex simple identifiers" $ do
+      let input = "x a b = a"
+      let expected = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
+      runParser saplingLexer "" input @?= expected
+
+  , testCase "Lex Tree Calculus terms" $ do
+      let input = "t t t"
+      let expected = Right [LKeywordT, LKeywordT, LKeywordT]
+      runParser saplingLexer "" input @?= expected
+
+  , testCase "Handle invalid input" $ do
+      let input = "x = "
+      case runParser saplingLexer "" input of
+        Left _ -> return ()
+        Right _ -> assertFailure "Expected failure on invalid input"
+  ]
+
+parserTests :: TestTree
+parserTests = testGroup "Parser Tests"
+  [ testCase "Parse function definitions" $ do
+      let input = "x a b = a"
+      let expected = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
+      parseSapling input @?= expected
+
+  , testCase "Parse nested Tree Calculus terms" $ do
+      let input = "t (t t) t"
+      let expected = TFork (TStem TLeaf) TLeaf
+      parseSapling input @?= expected
+
+  , testCase "Parse sequential Tree Calculus terms" $ do
+      let input = "t t t"
+      let expected = TFork TLeaf TLeaf
+      parseSapling input @?= expected
+  ]
+
+integrationTests :: TestTree
+integrationTests = testGroup "Integration Tests"
+  [ testCase "Combine lexer and parser" $ do
+      let input = "x = t t t"
+      let expected = SFunc "x" [] (TFork TLeaf TLeaf)
+      parseSapling input @?= expected
+
+  , testCase "Complex Tree Calculus expression" $ do
+      let input = "t (t t t) t"
+      let expected = TFork (TFork TLeaf TLeaf) TLeaf
+      parseSapling input @?= expected
+  ]
+
+evaluationTests :: TestTree
+evaluationTests = testGroup "Evaluation Tests"
+  [ testCase "Evaluate single Leaf" $ do
+      let input = "t"
+      let ast = parseSapling input
+      evalSapling ast @?= Leaf
+
+  , testCase "Evaluate single Stem" $ do
+      let input = "t t"
+      let ast = parseSapling input
+      evalSapling ast @?= Stem Leaf
+
+  , testCase "Evaluate single Fork" $ do
+      let input = "t t t"
+      let ast = parseSapling input
+      evalSapling 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
+
+  , 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
+  ]
+
+propertyTests :: TestTree
+propertyTests = testGroup "Property Tests"
+  [ testProperty "Lexing and parsing round-trip" $ \input ->
+      case runParser saplingLexer "" input of
+        Left _ -> property True  -- Ignore invalid lexes
+        Right tokens -> case runParser parseExpression "" tokens of
+          Left _ -> property True  -- Ignore invalid parses
+          Right ast -> parseSapling input === ast
+  ]
+