Compare commits

..

No commits in common. "e376d13a93cdf7cc32ca27d0f9b94736b292ea65" and "7fca4d38e8dc50cff988d0da1729ac9838de5f94" have entirely different histories.

10 changed files with 385 additions and 581 deletions

View File

@ -1,52 +1,16 @@
# sapling # sapling
## Introduction
sapling is a "micro-language" that I'm working on to investigate [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) . sapling is a "micro-language" that I'm working on to investigate [Tree Calculus](https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf) .
It offers a minimal amount of syntax sugar: It offers a minimal amount of syntax sugar:
- `t` operator behaving by the rules of Tree Calculus - `t` operator behaving by the rules of Tree Calculus
- Function ("variable") definitions - Variable definitions
- Lambda abstractions - Lambda abstractions
- List, Number, and String literals (WIP) - List, Integer, and String literals
This is an active experimentation project by [someone who has no idea what they're doing](https://eversole.co). This is an active experimentation project by [someone who has no idea what they're doing](https://eversole.co).
## What does it look like?
```
false = t
_ = t
true = t t
id = (\a : a)
triage = (\a b c : t (t a b) c)
match_bool = (\ot of : triage of (\_ : ot) t)
and = match_bool id (\_ : false)
if = (\cond then else : t (t else (t t then)) t cond)
triage = (\a b c : t (t a b) c)
test = triage "leaf" (\_ : "stem") (\_ _ : "fork")
-- The REPL outputs the tree form results by default; they are elided here.
sapling < test t
DECODE -: "leaf"
sapling < test (t t)
DECODE -: "stem"
sapling < test (t t t)
DECODE -: "fork"
sapling < map (\i : listConcat i " is super cool!") [("He") ("She") ("Everybody")]
DECODE -: ["He is super cool!", "She is super cool!", "Everybody is super cool!"]
```
## How to use
For now, you can easily build and run this project using Nix:
1. Clone the repository:
a. `git clone ssh://git.eversole.co/sapling.git`
b. `git clone https://git.eversole/sapling.git`
1. Run the REPL: `nix run`
## Acknowledgements ## Acknowledgements
Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog). Tree Calculus was discovered by [Barry Jay](https://github.com/barry-jay-personal/blog).

View File

@ -1,8 +1,8 @@
cabal-version: 1.12 cabal-version: 1.12
name: sapling name: sapling
version: 0.4.0 version: 0.2.0
description: A micro-language for exploring Tree Calculus description: Tree Calculus experiment repository
author: James Eversole author: James Eversole
maintainer: james@eversole.co maintainer: james@eversole.co
copyright: James Eversole copyright: James Eversole
@ -29,13 +29,11 @@ executable sapling
build-depends: build-depends:
base >=4.7 base >=4.7
, containers , containers
, haskeline
, megaparsec , megaparsec
, mtl , mtl
other-modules: other-modules:
Eval Eval
Lexer Lexer
Library
Parser Parser
REPL REPL
Research Research
@ -48,7 +46,6 @@ test-suite sapling-tests
build-depends: build-depends:
base base
, containers , containers
, haskeline
, megaparsec , megaparsec
, mtl , mtl
, tasty , tasty
@ -58,7 +55,6 @@ test-suite sapling-tests
other-modules: other-modules:
Eval Eval
Lexer Lexer
Library
Parser Parser
REPL REPL
Research Research

View File

@ -2,26 +2,21 @@ module Eval where
import Parser import Parser
import Research import Research
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (foldl')
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Map (Map)
evalSingle :: Map String T -> SaplingAST -> Map String T evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
evalSingle env term = case term of evalSingle env term = case term of
SFunc name [] body -> SFunc name [] body ->
let lineNoLambda = eliminateLambda body
result = evalAST env lineNoLambda
in Map.insert name result env
SLambda _ body ->
let result = evalAST env body let result = evalAST env body
in Map.insert "__result" result env in Map.insert name result env
SApp func arg -> SApp func arg ->
let result = apply (evalAST env $ eliminateLambda func) (evalAST env $ eliminateLambda arg) let result = apply (evalAST env func) (evalAST env arg)
in Map.insert "__result" result env in Map.insert "__result" result env
SVar name -> SVar name -> case Map.lookup name env of
case Map.lookup name env of
Just value -> Map.insert "__result" value env Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined" Nothing -> error $ "Variable " ++ name ++ " not defined"
_ -> _ ->
@ -31,66 +26,97 @@ evalSingle env term = case term of
evalSapling :: Map String T -> [SaplingAST] -> Map String T evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env evalSapling env [] = env
evalSapling env [lastLine] = evalSapling env [lastLine] =
let lastLineNoLambda = eliminateLambda lastLine let
lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) = evalSapling env (line:rest) =
let lineNoLambda = eliminateLambda line let
lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest in evalSapling updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T evalAST :: Map String T -> SaplingAST -> T
evalAST env term = case term of evalAST env term = case term of
SVar name -> case Map.lookup name env of SVar name ->
case Map.lookup name env of
Just value -> value Just value -> value
Nothing -> error $ "Variable " ++ name ++ " not defined" Nothing -> error $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf TLeaf -> Leaf
TStem t -> Stem (evalAST env t) TStem t ->
TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2) Stem (evalAST env t)
SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2) TFork t1 t2 ->
SStr str -> ofString str Fork (evalAST env t1) (evalAST env t2)
SInt num -> ofNumber num SApp t1 t2 ->
SList elems -> ofList (map (evalAST Map.empty) elems) apply (evalAST env t1) (evalAST env t2)
SStr str -> toString str
SInt num -> toNumber num
SList elems -> toList (map (evalAST Map.empty) elems)
SFunc name args body -> SFunc name args body ->
error $ "Unexpected function definition " ++ name error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle." ++ " in evalAST; define via evalSingle."
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination." SLambda {} ->
error "Internal error: SLambda found in evalAST after elimination."
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"
eliminateLambda :: SaplingAST -> SaplingAST eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda (SLambda (v:vs) body) eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body) | null vs = lambdaToT v (eliminateLambda body)
| otherwise = eliminateLambda (SLambda [v] (SLambda vs body)) | otherwise =
eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg) eliminateLambda (SLambda [v] (SLambda vs body))
eliminateLambda (TStem t) = TStem (eliminateLambda t) eliminateLambda (SApp f arg) =
eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r) SApp (eliminateLambda f) (eliminateLambda arg)
eliminateLambda (SList xs) = SList (map eliminateLambda xs) eliminateLambda (TStem t) =
TStem (eliminateLambda t)
eliminateLambda (TFork l r) =
TFork (eliminateLambda l) (eliminateLambda r)
eliminateLambda (SList xs) =
SList (map eliminateLambda xs)
eliminateLambda (SFunc n vs b) =
SFunc n vs (eliminateLambda b)
eliminateLambda other = other eliminateLambda other = other
-- This is my attempt to implement the lambda calculus elimination rules defined
-- in "Typed Program Analysis without Encodings" by Barry Jay.
-- https://github.com/barry-jay-personal/typed_tree_calculus/blob/main/typed_program_analysis.pdf
lambdaToT :: String -> SaplingAST -> SaplingAST lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x == y = tI | x == y = tI
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x /= y = SApp tK (SVar y) | x /= y =
SApp tK (SVar y)
lambdaToT x t lambdaToT x t
| not (isFree x t) = SApp tK t | not (isFree x t) =
SApp tK t
lambdaToT x (SApp n u) lambdaToT x (SApp n u)
| not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u)) | not (isFree x (SApp n u)) =
lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u)) SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
lambdaToT x (SApp n u) =
SApp
(SApp tS (lambdaToT x (eliminateLambda n)))
(lambdaToT x (eliminateLambda u))
lambdaToT x (SApp f args) = lambdaToT x f
lambdaToT x body lambdaToT x body
| not (isFree x body) = SApp tK body | not (isFree x body) =
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf SApp tK body
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
freeVars :: SaplingAST -> Set.Set String tLeaf :: SaplingAST
tLeaf = TLeaf
freeVars :: SaplingAST -> Set String
freeVars (SVar v) = Set.singleton v freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs freeVars (SList xs) = foldMap freeVars xs
freeVars (SFunc _ _ b) = freeVars b
freeVars (SApp f arg) = freeVars f <> freeVars arg freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty freeVars TLeaf = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
@ -103,18 +129,12 @@ toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a) toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b) toAST (Fork a b) = TFork (toAST a) (toAST b)
-- We need the SKI operators in an unevaluated SaplingAST tree form so that we
-- can keep the evaluation functions straightforward
tI :: SaplingAST tI :: SaplingAST
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf tI = toAST _I
tK :: SaplingAST tK :: SaplingAST
tK = SApp TLeaf TLeaf tK = toAST _K
tS :: SaplingAST tS :: SaplingAST
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf tS = toAST _S
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"

View File

@ -3,13 +3,10 @@ module Lexer where
import Research import Research
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Control.Monad (void)
import Data.Void import Data.Void
import qualified Data.Set as Set import qualified Data.Set as Set
type Lexer = Parsec Void String type Lexer = Parsec Void String
data LToken data LToken
= LKeywordT = LKeywordT
| LIdentifier String | LIdentifier String
@ -23,7 +20,6 @@ data LToken
| LOpenBracket | LOpenBracket
| LCloseBracket | LCloseBracket
| LNewline | LNewline
| LComment String
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
keywordT :: Lexer LToken keywordT :: Lexer LToken
@ -48,7 +44,7 @@ stringLiteral = do
if null content if null content
then fail "Empty string literals are not allowed" then fail "Empty string literals are not allowed"
else do else do
char '"' --" char '"' -- "
return (LStringLiteral content) return (LStringLiteral content)
assign :: Lexer LToken assign :: Lexer LToken
@ -75,16 +71,8 @@ closeBracket = char ']' *> pure LCloseBracket
lnewline :: Lexer LToken lnewline :: Lexer LToken
lnewline = char '\n' *> pure LNewline lnewline = char '\n' *> pure LNewline
comment :: Lexer LToken
comment = do
string "--"
content <- many (satisfy (/= '\n'))
optional (char '\n')
pure (LComment content)
sc :: Lexer () sc :: Lexer ()
sc = skipMany (void (char ' ') <|> void (char '\t') <|> void comment) sc = skipMany (char ' ' <|> char '\t')
saplingLexer :: Lexer [LToken] saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice saplingLexer = many (sc *> choice

View File

@ -1,47 +0,0 @@
module Library where
import Eval
import Parser
import Research
import qualified Data.Map as Map
library :: Map.Map String T
library = evalSapling Map.empty $ parseSapling $ unlines
[ "false = t"
, "true = t t"
, "_ = t"
, "k = t t"
, "i = t (t k) t"
, "s = t (t (k t)) t"
, "m = s i i"
, "b = s (k s) k"
, "c = s (s (k s) (s (k k) s)) (k k)"
, "iC = (\\a b c : s a (k c) b)"
, "iD = b (b iC) iC"
, "iE = b (b iD) iC"
, "yi = (\\i : b m (c b (i m)))"
, "y = yi iC"
, "yC = yi iD"
, "yD = yi iE"
, "id = (\\a : a)"
, "triage = (\\a b c : t (t a b) c)"
, "pair = t"
, "matchBool = (\\ot of : triage of (\\_ : ot) (\\_ _ : ot))"
, "matchList = (\\oe oc : triage oe _ oc)"
, "matchPair = (\\op : triage _ _ op)"
, "and = matchBool id (\\z : false)"
, "if = (\\cond then else : t (t else (t t then)) t cond)"
, "test = triage \"leaf\" (\\z : \"stem\") (\\a b : \"fork\")"
, "emptyList = matchList true (\\y z : false)"
, "nonEmptyList = matchList false (\\y z : true)"
, "head = matchList t (\\hd tl : hd)"
, "tail = matchList t (\\hd tl : tl)"
, "isLeaf = (\\_ : triage true false false)"
, "listConcat = y (\\self : matchList (\\k : k) (\\h r k : pair h (self r k)))"
, "lAnd = triage (\\x : false) (\\_ x : x) (\\_ _ x : x)"
, "lOr = triage (\\x : x) (\\_ _ : true) (\\_ _ x : true)"
, "hmap = y (\\self : matchList (\\f : t) (\\hd tl f : pair (f hd) (self tl f)))"
, "map = (\\f l : hmap l f)"
, "equal = y (\\self : triage (triage true (\\z : false) (\\y z : false)) (\\ax : triage false (self ax) (\\y z : false)) (\\ax ay : triage false (\\z : false) (\\bx by : lAnd (self ax bx) (self ay by))))"
]

View File

@ -2,7 +2,6 @@ module Main where
import Eval import Eval
import Lexer import Lexer
import Library
import Parser import Parser
import REPL (repl) import REPL (repl)
import Research import Research
@ -11,12 +10,4 @@ import qualified Data.Map as Map
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
main :: IO () main :: IO ()
main = do main = repl Map.empty --(Map.fromList [("__result", Leaf)])
putStrLn "Welcome to the Sapling Interpreter"
putStrLn "You can exit at any time by typing and entering: "
putStrLn ":_exit"
repl library
runSapling :: String -> T
runSapling s = result (evalSapling Map.empty $ parseSapling s)
runSaplingEnv env s = result (evalSapling env $ parseSapling s)

View File

@ -1,8 +1,10 @@
module Parser where module Parser where
import Debug.Trace import Debug.Trace
import Lexer import Lexer
import Research hiding (toList) import Research hiding (toList)
import Control.Exception (throw) import Control.Exception (throw)
import Data.List.NonEmpty (toList) import Data.List.NonEmpty (toList)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -12,7 +14,6 @@ import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle) import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken] type Parser = Parsec Void [LToken]
data SaplingAST data SaplingAST
= SVar String = SVar String
| SInt Int | SInt Int
@ -32,6 +33,7 @@ parseSapling input =
in map parseSingle nonEmptyLines in map parseSingle nonEmptyLines
parseSingle :: String -> SaplingAST parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err Left err -> error $ handleParseError err
Right ast -> ast Right ast -> ast
@ -43,7 +45,6 @@ parseExpression :: Parser SaplingAST
parseExpression = choice parseExpression = choice
[ try parseFunction [ try parseFunction
, try parseLambda , try parseLambda
, try parseLambdaExpression
, try parseListLiteral , try parseListLiteral
, try parseApplication , try parseApplication
, try parseTreeTerm , try parseTreeTerm
@ -58,19 +59,6 @@ parseFunction = do
body <- parseExpression body <- parseExpression
return (SFunc name (map getIdentifier args) body) return (SFunc name (map getIdentifier args) body)
parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ try parseVarWithoutAssignment
, parseTreeLeaf
, parseGrouped
]
parseVarWithoutAssignment :: Parser SaplingAST
parseVarWithoutAssignment = do
LIdentifier name <- satisfy isIdentifier
if (name == "t" || name == "__result")
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
else notFollowedBy (satisfy (== LAssign)) *> return (SVar name)
parseLambda :: Parser SaplingAST parseLambda :: Parser SaplingAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash) satisfy (== LBackslash)
@ -93,7 +81,6 @@ parseAtomicLambda = choice
, parseTreeLeaf , parseTreeLeaf
, parseLiteral , parseLiteral
, parseListLiteral , parseListLiteral
, try parseLambda
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
] ]
@ -115,6 +102,13 @@ isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True isTreeTerm (TFork _ _) = True
isTreeTerm _ = False isTreeTerm _ = False
parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ parseVar
, parseTreeLeaf
, parseGrouped
]
parseTreeLeaf :: Parser SaplingAST parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
@ -153,6 +147,7 @@ parseAtomic = choice
, parseLiteral , parseLiteral
] ]
parseGrouped :: Parser SaplingAST parseGrouped :: Parser SaplingAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
@ -223,16 +218,21 @@ parseStrLiteral = do
-- Boolean Helpers -- Boolean Helpers
isKeywordT (LKeywordT) = True isKeywordT (LKeywordT) = True
isKeywordT _ = False isKeywordT _ = False
isIdentifier (LIdentifier _) = True isIdentifier (LIdentifier _) = True
isIdentifier _ = False isIdentifier _ = False
isIntegerLiteral (LIntegerLiteral _) = True isIntegerLiteral (LIntegerLiteral _) = True
isIntegerLiteral _ = False isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False isStringLiteral _ = False
isLiteral (LIntegerLiteral _) = True isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True isLiteral (LStringLiteral _) = True
isLiteral _ = False isLiteral _ = False
isNewline (LNewline) = True
esNewline (LNewline) = True
isNewline _ = False isNewline _ = False
-- Error Handling -- Error Handling
@ -252,4 +252,3 @@ showError (FancyError offset fancy) =
showError (TrivialError offset Nothing expected) = showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of " "Parse error at offset " ++ show offset ++ ": expected one of "
++ show (Set.toList expected) ++ show (Set.toList expected)

View File

@ -5,38 +5,21 @@ import Lexer
import Parser import Parser
import Research import Research
import Data.List (intercalate) import Control.Monad (void)
import qualified Data.Map as Map import qualified Data.Map as Map
import System.Console.Haskeline
import System.IO (hFlush, stdout) import System.IO (hFlush, stdout)
repl :: Map.Map String T -> IO () repl :: Map.Map String T -> IO ()
repl env = runInputT defaultSettings (loop env) repl env = do
where putStr "sapling > "
loop :: Map.Map String T -> InputT IO () hFlush stdout
loop env = do input <- getLine
minput <- getInputLine "sapling < " if input == "_:exit"
case minput of then putStrLn "Goodbye!"
Nothing -> outputStrLn "Goodbye!" else do
Just ":_exit" -> outputStrLn "Goodbye!"
Just "" -> do
outputStrLn ""
loop env
Just input -> do
let clearEnv = Map.delete "__result" env let clearEnv = Map.delete "__result" env
newEnv = evalSingle clearEnv (parseSingle input) let newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of case Map.lookup "__result" newEnv of
Just r -> do Just r -> putStrLn $ "sapling < " ++ show r
outputStrLn $ "sapling > " ++ show r Nothing -> pure ()
outputStrLn $ "DECODE -: " ++ decodeResult r repl newEnv
Nothing -> return ()
loop newEnv
decodeResult :: T -> String
decodeResult tc = case toNumber tc of
Right num -> show num
Left _ -> case toString tc of
Right str -> "\"" ++ str ++ "\""
Left _ -> case toList tc of
Right list -> "[" ++ intercalate ", " (map decodeResult list) ++ "]"
Left _ -> ""

View File

@ -34,11 +34,8 @@ _S = Fork (Stem (Fork Leaf Leaf)) Leaf
_K :: T _K :: T
_K = Stem Leaf _K = Stem Leaf
-- Identity
-- We use the "point-free" style which drops a redundant node
-- Full _I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
_I :: T _I :: T
_I = Fork (Stem (Stem Leaf)) Leaf _I = apply (apply _S _K) _K -- Fork (Stem (Stem Leaf)) (Stem Leaf)
-- Booleans -- Booleans
_false :: T _false :: T
@ -51,41 +48,33 @@ _not :: T
_not = Fork (Fork _true (Fork Leaf _false)) Leaf _not = Fork (Fork _true (Fork Leaf _false)) Leaf
-- Marshalling -- Marshalling
ofString :: String -> T toString :: String -> T
ofString str = ofList (map ofNumber (map fromEnum str)) toString str = toList (map toNumber (map fromEnum str))
ofNumber :: Int -> T ofString :: T -> String
ofNumber 0 = Leaf ofString tc = map (toEnum . ofNumber) (ofList tc)
ofNumber n =
toNumber :: Int -> T
toNumber 0 = Leaf
toNumber n =
Fork Fork
(if odd n then Stem Leaf else Leaf) (if odd n then Stem Leaf else Leaf)
(ofNumber (n `div` 2)) (toNumber (n `div` 2))
ofList :: [T] -> T ofNumber :: T -> Int
ofList [] = Leaf ofNumber Leaf = 0
ofList (x:xs) = Fork x (ofList xs) ofNumber (Fork Leaf rest) = 2 * ofNumber rest
ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
ofNumber _ = error "Invalid Tree Calculus number"
toNumber :: T -> Either String Int toList :: [T] -> T
toNumber Leaf = Right 0 toList [] = Leaf
toNumber (Fork Leaf rest) = case toNumber rest of toList (x:xs) = Fork x (toList xs)
Right n -> Right (2 * n)
Left err -> Left err
toNumber (Fork (Stem Leaf) rest) = case toNumber rest of
Right n -> Right (1 + 2 * n)
Left err -> Left err
toNumber _ = Left "Invalid Tree Calculus number"
toString :: T -> Either String String ofList :: T -> [T]
toString tc = case toList tc of ofList Leaf = []
Right list -> traverse (fmap toEnum . toNumber) list ofList (Fork x rest) = x : ofList rest
Left err -> Left "Invalid Tree Calculus string" ofList _ = error "Invalid Tree Calculus list"
toList :: T -> Either String [T]
toList Leaf = Right []
toList (Fork x rest) = case toList rest of
Right xs -> Right (x : xs)
Left err -> Left err
toList _ = Left "Invalid Tree Calculus list"
-- Utility -- Utility
toAscii :: T -> String toAscii :: T -> String

View File

@ -2,31 +2,24 @@ module Main where
import Eval import Eval
import Lexer import Lexer
import Library
import Parser import Parser
import Research import Research
import Control.Exception (evaluate, try, SomeException) import Control.Exception (evaluate, try, SomeException)
import qualified Data.Map as Map
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.QuickCheck import Test.Tasty.QuickCheck
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
import qualified Data.Map as Map
import qualified Data.Set as Set
main :: IO () main :: IO ()
main = defaultMain tests main = defaultMain tests
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
tests :: TestTree tests :: TestTree
tests = testGroup "Sapling Tests" tests = testGroup "Sapling Tests"
[ lexerTests [ lexerTests
, parserTests , parserTests
, integrationTests , integrationTests
, evaluationTests , evaluationTests
, lambdaEvalTests
, propertyTests , propertyTests
] ]
@ -67,80 +60,85 @@ lexerTests = testGroup "Lexer Tests"
parserTests :: TestTree parserTests :: TestTree
parserTests = testGroup "Parser Tests" parserTests = testGroup "Parser Tests"
[ --testCase "Error when parsing incomplete definitions" $ do [ testCase "Error when parsing incomplete definitions" $ do
-- let input = lexSapling "x = " let input = lexSapling "x = "
-- case (runParser parseExpression "" input) of case (runParser parseExpression "" input) of
-- Left _ -> return () Left _ -> return ()
-- Right _ -> assertFailure "Expected failure on invalid input" Right _ -> assertFailure "Expected failure on invalid input"
testCase "Error when assigning a value to T" $ do , testCase "Error when assigning a value to T" $ do
let input = lexSapling "t = x" let input = lexSapling "t = x"
case (runParser parseExpression "" input) of case (runParser parseExpression "" input) of
Left _ -> return () Left _ -> return ()
Right _ -> assertFailure "Expected failure when trying to assign the value of T" Right _ -> assertFailure "Expected failure when trying to assign the value of T"
, testCase "Error when parsing bodyless definitions with arguments" $ do
let input = lexSapling "x a b = "
case (runParser parseExpression "" input) of
Left _ -> return ()
Right _ -> assertFailure "Expected failure on invalid input"
, testCase "Parse function definitions" $ do , testCase "Parse function definitions" $ do
let input = "x = (\\a b c : a)" let input = "x a b c = a"
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a")))) let expect = SFunc "x" ["a","b","c"] (SVar "a")
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do , testCase "Parse nested Tree Calculus terms" $ do
let input = "t (t t) t" let input = "t (t t) t"
expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse sequential Tree Calculus terms" $ do , testCase "Parse sequential Tree Calculus terms" $ do
let input = "t t t" let input = "t t t"
expect = SApp (SApp TLeaf TLeaf) TLeaf let expect = SApp (SApp TLeaf TLeaf) TLeaf
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse mixed list literals" $ do , testCase "Parse mixed list literals" $ do
let input = "[t (\"hello\") t]" let input = "[t (\"hello\") t]"
expect = SList [TLeaf, SStr "hello", TLeaf] let expect = SList [TLeaf, SStr "hello", TLeaf]
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse function with applications" $ do , testCase "Parse function with applications" $ do
let input = "f = (\\x : t x)" let input = "f x = t x"
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x"))) let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse nested lists" $ do , testCase "Parse nested lists" $ do
let input = "[t [(t t)]]" let input = "[t [(t t)]]"
expect = SList [TLeaf,SList [SApp TLeaf TLeaf]] let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse complex parentheses" $ do , testCase "Parse complex parentheses" $ do
let input = "t (t t (t t))" let input = "t (t t (t t))"
expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf)) let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse empty list" $ do , testCase "Parse empty list" $ do
let input = "[]" let input = "[]"
expect = SList [] let expect = SList []
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse multiple nested lists" $ do , testCase "Parse multiple nested lists" $ do
let input = "[[t t] [t (t t)]]" let input = "[[t t] [t (t t)]]"
expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]] let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse whitespace variance" $ do , testCase "Parse whitespace variance" $ do
let input1 = "[t t]" let input1 = "[t t]"
let input2 = "[ t t ]" let input2 = "[ t t ]"
expect = SList [TLeaf, TLeaf] let expect = SList [TLeaf, TLeaf]
parseSingle input1 @?= expect parseSingle input1 @?= expect
parseSingle input2 @?= expect parseSingle input2 @?= expect
, testCase "Parse string in list" $ do , testCase "Parse string in list" $ do
let input = "[(\"hello\")]" let input = "[(\"hello\")]"
expect = SList [SStr "hello"] let expect = SList [SStr "hello"]
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse parentheses inside list" $ do , testCase "Parse parentheses inside list" $ do
let input = "[t (t t)]" let input = "[t (t t)]"
expect = SList [TLeaf,SApp TLeaf TLeaf] let expect = SList [TLeaf,SApp TLeaf TLeaf]
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse nested parentheses in function body" $ do , testCase "Parse nested parentheses in function body" $ do
let input = "f = (\\x : t (t (t t)))" let input = "f = t (t (t t))"
expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))) let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do , testCase "Parse lambda abstractions" $ do
let input = "(\\a : a)" let input = "(\\a : a)"
expect = (SLambda ["a"] (SVar "a")) let expect = (SLambda ["a"] (SVar "a"))
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse multiple arguments to lambda abstractions" $ do , testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)" let input = "x = (\\a b : a)"
expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a"))) let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Grouping T terms with parentheses in function application" $ do , testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\nx (t)" let input = "x = (\\a : a)\n" <> "x (t)"
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf] expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
parseSapling input @?= expect parseSapling input @?= expect
] ]
@ -149,11 +147,11 @@ integrationTests :: TestTree
integrationTests = testGroup "Integration Tests" integrationTests = testGroup "Integration Tests"
[ testCase "Combine lexer and parser" $ do [ testCase "Combine lexer and parser" $ do
let input = "x = t t t" let input = "x = t t t"
expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf) let expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Complex Tree Calculus expression" $ do , testCase "Complex Tree Calculus expression" $ do
let input = "t (t t t) t" let input = "t (t t t) t"
expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
parseSingle input @?= expect parseSingle input @?= expect
] ]
@ -182,131 +180,54 @@ evaluationTests = testGroup "Evaluation Tests"
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Environment updates with definitions" $ do , testCase "Environment updates with definitions" $ do
let input = "x = t\ny = x" let input = "x = t\ny = x"
env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
Map.lookup "x" env @?= Just Leaf Map.lookup "x" env @?= Just Leaf
Map.lookup "y" env @?= Just Leaf Map.lookup "y" env @?= Just Leaf
, testCase "Variable substitution" $ do , testCase "Variable substitution" $ do
let input = "x = t t\ny = t x\ny" let input = "x = t t\ny = t x\ny"
env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Stem (Stem Leaf) (result env) @?= Stem (Stem Leaf)
, testCase "Multiline input evaluation" $ do , testCase "Multiline input evaluation" $ do
let input = "x = t\ny = t t\nx" let input = "x = t\ny = t t\nx"
env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf (result env) @?= Leaf
, testCase "Evaluate string literal" $ do , testCase "Evaluate string literal" $ do
let input = "\"hello\"" let input = "\"hello\""
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= ofString "hello" (result $ evalSingle Map.empty ast) @?= toString "hello"
, testCase "Evaluate list literal" $ do , testCase "Evaluate list literal" $ do
let input = "[t (t t)]" let input = "[t (t t)]"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= ofList [Leaf, Stem Leaf] (result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
, testCase "Evaluate empty list" $ do , testCase "Evaluate empty list" $ do
let input = "[]" let input = "[]"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= ofList [] (result $ evalSingle Map.empty ast) @?= toList []
, testCase "Evaluate variable dependency chain" $ do , testCase "Evaluate variable dependency chain" $ do
let input = "x = t (t t)\n \ let input = "x = t (t t)\n \
\ y = x\n \ \ y = x\n \
\ z = y\n \ \ z = y\n \
\ variablewithamuchlongername = z\n \ \ variablewithamuchlongername = z\n \
\ variablewithamuchlongername" \ variablewithamuchlongername"
env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
(result env) @?= (Stem (Stem Leaf)) (result env) @?= (Stem (Stem Leaf))
, testCase "Evaluate variable shadowing" $ do , testCase "Evaluate variable shadowing" $ do
let input = "x = t t\nx = t\nx" let input = "x = t t\nx = t\nx"
env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf (result env) @?= Leaf
, testCase "Lambda identity" $ do
let input = "(\\a : a)"
env = evalSapling Map.empty (parseSapling input)
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
, testCase "Apply identity to Boolean Not" $ do , testCase "Apply identity to Boolean Not" $ do
let not = "(t (t (t t) (t t t)) t)" let not = "(t (t (t t) (t t t)) t)"
let input = "x = (\\a : a)\nx " ++ not input = "x = (\\a : a)\nx " ++ not
env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Constant function matches" $ do , testCase "Constant function matches" $ do
let input = "k = (\\a b : a)\nk (t t) t" let input = "k = (\\a b : a)\nk (t t) t"
env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
result env @?= Stem Leaf result env @?= Stem Leaf
, testCase "Boolean AND_ TF" $ do
let input = "and (t t) (t)"
env = evalSapling library (parseSapling input)
result env @?= Leaf
, testCase "Boolean AND_ FT" $ do
let input = "and (t) (t t)"
env = evalSapling library (parseSapling input)
result env @?= Leaf
, testCase "Boolean AND_ FF" $ do
let input = "and (t) (t)"
env = evalSapling library (parseSapling input)
result env @?= Leaf
, testCase "Boolean AND_ TT" $ do
let input = "and (t t) (t t)"
env = evalSapling library (parseSapling input)
result env @?= Stem Leaf
, testCase "Verifying Equality" $ do
let input = "equal (t t t) (t t t)"
env = evalSapling library (parseSapling input)
result env @?= Stem Leaf
]
lambdaEvalTests :: TestTree
lambdaEvalTests = testGroup "Lambda Evaluation Tests"
[ testCase "Lambda Identity Function" $ do
let input = "id = (\\x : x)\nid t"
runSapling input @?= "Leaf"
, testCase "Lambda Constant Function (K combinator)" $ do
let input = "k = (\\x y : x)\nk t (t t)"
runSapling input @?= "Leaf"
, testCase "Lambda Application with Variable" $ do
let input = "id = (\\x : x)\nval = t t\nid val"
runSapling input @?= "Stem Leaf"
, testCase "Lambda Application with Multiple Arguments" $ do
let input = "apply = (\\f x y : f x y)\nk = (\\a b : a)\napply k t (t t)"
runSapling input @?= "Leaf"
, testCase "Nested Lambda Application" $ do
let input = "apply = (\\f x y : f x y)\nid = (\\x : x)\napply (\\f x : f x) id t"
runSapling input @?= "Leaf"
, testCase "Lambda with a complex body" $ do
let input = "f = (\\x : t (t x))\nf t"
runSapling input @?= "Stem (Stem Leaf)"
, testCase "Lambda returning a function" $ do
let input = "f = (\\x : (\\y : x))\ng = f t\ng (t t)"
runSapling input @?= "Leaf"
, testCase "Lambda with Shadowing" $ do
let input = "f = (\\x : (\\x : x))\nf t (t t)"
runSapling input @?= "Stem Leaf"
, testCase "Lambda returning another lambda" $ do
let input = "k = (\\x : (\\y : x))\nk_app = k t\nk_app (t t)"
runSapling input @?= "Leaf"
, testCase "Lambda with free variables" $ do
let input = "y = t t\nf = (\\x : y)\nf t"
runSapling input @?= "Stem Leaf"
, testCase "SKI Composition" $ do
let input = "s = (\\x y z : x z (y z))\nk = (\\x y : x)\ni = (\\x : x)\ncomp = s k i\ncomp t (t t)"
runSapling input @?= "Stem (Stem Leaf)"
, testCase "Lambda with multiple parameters and application" $ do
let input = "f = (\\a b c : t a b c)\nf t (t t) (t t t)"
runSapling input @?= "Stem Leaf"
, testCase "Lambda with nested application in the body" $ do
let input = "f = (\\x : t (t (t x)))\nf t"
runSapling input @?= "Stem (Stem (Stem Leaf))"
, testCase "Lambda returning a function and applying it" $ do
let input = "f = (\\x : (\\y : t x y))\ng = f t\ng (t t)"
runSapling input @?= "Fork Leaf (Stem Leaf)"
, testCase "Lambda applying a variable" $ do
let input = "id = (\\x : x)\na = t t\nid a"
runSapling input @?= "Stem Leaf"
, testCase "Nested lambda abstractions in the same expression" $ do
let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
runSapling input @?= "Leaf"
, testCase "Lambda with a string literal" $ do
let input = "f = (\\x : x)\nf \"hello\""
runSapling input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) Leaf))))"
, testCase "Lambda with an integer literal" $ do
let input = "f = (\\x : x)\nf 42"
runSapling input @?= "Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) Leaf)))))"
, testCase "Lambda with a list literal" $ do
let input = "f = (\\x : x)\nf [t (t t)]"
runSapling input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
] ]
propertyTests :: TestTree propertyTests :: TestTree