commit 2a650dac56cb1c7ea98df4f749718f53ff02ca49
Author: James Eversole <james@eversole.co>
Date: Wed, 18 Dec 2024 18:55:51 -0600
Initialize Repo
Working (but likely buggy!) lexing, parsing, and evaluation of Tree Calculus terms
Diffstat:
| A | .gitignore | | | 13 | +++++++++++++ |
| A | flake.lock | | | 60 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | flake.nix | | | 66 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | sapling.cabal | | | 58 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | shell.nix | | | 8 | ++++++++ |
| A | src/Eval.hs | | | 10 | ++++++++++ |
| A | src/Lexer.hs | | | 77 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/Main.hs | | | 11 | +++++++++++ |
| A | src/Parser.hs | | | 131 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/Research.hs | | | 142 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | test/Spec.hs | | | 112 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
11 files changed, 688 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,13 @@
+bin/
+data/Purr.sqlite
+data/encryptionKey
+/result
+/config.dhall
+/Dockerfile
+/docker-stack.yml
+.stack-work/
+*.swp
+dist*
+*~
+.env
+WD
diff --git a/flake.lock b/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
+}
diff --git a/flake.nix b/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 = ''
+ '';
+ };
+ };
+ });
+}
diff --git a/sapling.cabal b/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
diff --git a/shell.nix b/shell.nix
@@ -0,0 +1,8 @@
+{ pkgs ? import <nixpkgs> {} }:
+let x = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [
+ megaparsec
+ ]);
+in
+pkgs.mkShell {
+ buildInputs = [ x ];
+}
diff --git a/src/Eval.hs b/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."
diff --git a/src/Lexer.hs b/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
diff --git a/src/Main.hs b/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"
diff --git a/src/Parser.hs b/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
+
diff --git a/src/Research.hs b/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"
diff --git a/test/Spec.hs b/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
+ ]
+
