From 9f9aca404023b28d7fe1d3b76047ef0243c0405e Mon Sep 17 00:00:00 2001 From: James Eversole Date: Wed, 18 Dec 2024 18:55:51 -0600 Subject: [PATCH] Initialize Repo Working (but likely buggy!) lexing, parsing, and evaluation of Tree Calculus terms --- .gitignore | 13 +++++ flake.lock | 60 ++++++++++++++++++++ flake.nix | 66 ++++++++++++++++++++++ sapling.cabal | 58 ++++++++++++++++++++ shell.nix | 8 +++ src/Eval.hs | 10 ++++ src/Lexer.hs | 77 ++++++++++++++++++++++++++ src/Main.hs | 11 ++++ src/Parser.hs | 131 ++++++++++++++++++++++++++++++++++++++++++++ src/Research.hs | 142 ++++++++++++++++++++++++++++++++++++++++++++++++ test/Spec.hs | 112 ++++++++++++++++++++++++++++++++++++++ 11 files changed, 688 insertions(+) create mode 100644 .gitignore create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 sapling.cabal create mode 100644 shell.nix create mode 100644 src/Eval.hs create mode 100644 src/Lexer.hs create mode 100644 src/Main.hs create mode 100644 src/Parser.hs create mode 100644 src/Research.hs create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..bfdaf13 --- /dev/null +++ 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 new file mode 100644 index 0000000..4e16d41 --- /dev/null +++ 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 new file mode 100644 index 0000000..f4366a9 --- /dev/null +++ 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 new file mode 100644 index 0000000..3c98e65 --- /dev/null +++ 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 new file mode 100644 index 0000000..7b2fa7c --- /dev/null +++ b/shell.nix @@ -0,0 +1,8 @@ +{ pkgs ? import {} }: +let x = pkgs.haskellPackages.ghcWithPackages (hpkgs: with hpkgs; [ + megaparsec + ]); +in +pkgs.mkShell { + buildInputs = [ x ]; +} diff --git a/src/Eval.hs b/src/Eval.hs new file mode 100644 index 0000000..2e443db --- /dev/null +++ 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 new file mode 100644 index 0000000..3c839b0 --- /dev/null +++ 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 new file mode 100644 index 0000000..be272db --- /dev/null +++ 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 new file mode 100644 index 0000000..ce36e13 --- /dev/null +++ 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 new file mode 100644 index 0000000..aa132b2 --- /dev/null +++ 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 new file mode 100644 index 0000000..a5617e6 --- /dev/null +++ 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 + ] +