James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Stop using lists to represent args

Browse Source
This commit is contained in:
James Eversole
2024-12-27 08:17:06 -06:00
parent c5f1ccc4dc
commit 7fca4d38e8
7 changed files with 399 additions and 299 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -11,3 +11,4 @@ dist*
*~
.env
WD
*.hs.txt

1
sapling.cabal
View File

@ -18,6 +18,7 @@ executable sapling
src
default-extensions:
ConstraintKinds
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances

144
src/Eval.hs
View File

@ -2,63 +2,139 @@ module Eval where
import Parser
import Research
import Data.Set (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 env TLeaf = Map.insert "__result" Leaf env
evalSingle env (TStem t) =
let result = Stem (evalTreeCalculus env t)
evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
evalSingle env term = case term of
SFunc name [] body ->
let result = evalAST env body
in Map.insert name result env
SApp func arg ->
let result = apply (evalAST env func) (evalAST env arg)
in Map.insert "__result" result env
evalSingle env (TFork t1 t2) =
let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
in Map.insert "__result" result env
evalSingle env (SFunc name [] body) =
let value = evalTreeCalculus env body
in Map.insert name value env
evalSingle env (SVar name) =
case Map.lookup name env of
SVar name -> case Map.lookup name env of
Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env
_ ->
let result = evalAST env term
in Map.insert "__result" result env
evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env
evalSapling env [lastLine] =
let updatedEnv = evalSingle env lastLine
let
lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
let updatedEnv = evalSingle env line
let
lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
evalTreeCalculus _ TLeaf = Leaf
evalTreeCalculus env (TStem t) = Stem (evalTreeCalculus env t)
evalTreeCalculus env (TFork t1 t2) = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
evalTreeCalculus env (SApp base []) = evalTreeCalculus env base
evalTreeCalculus env (SApp base args) =
let func = evalTreeCalculus env base
argVals = map (evalTreeCalculus env) args
in foldl apply func argVals
evalTreeCalculus env (SVar name) =
evalAST :: Map String T -> SaplingAST -> T
evalAST env term = case term of
SVar name ->
case Map.lookup name env of
Just value -> value
Nothing -> error $ "Variable " ++ name ++ " not defined"
evalTreeCalculus _ (SStr str) = toString str
evalTreeCalculus _ (SInt num) = toNumber num
evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elems)
evalTreeCalculus _ (SFunc name args body) =
error $ "Unexpected function definition " ++ name ++ " in \
\ evalTreeCalculus; functions should be evaluated to Tree Calculus \
\ terms by evalSingle."
TLeaf -> Leaf
TStem t ->
Stem (evalAST env t)
TFork t1 t2 ->
Fork (evalAST env t1) (evalAST env t2)
SApp t1 t2 ->
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 ->
error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle."
SLambda {} ->
error "Internal error: SLambda found in evalAST after elimination."
result :: Map String T -> T
result r = case (Map.lookup "__result" r) of
result r = case Map.lookup "__result" r of
Just a -> a
Nothing -> error "No __result field found in provided environment"
eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body)
| otherwise =
eliminateLambda (SLambda [v] (SLambda vs body))
eliminateLambda (SApp f arg) =
SApp (eliminateLambda f) (eliminateLambda arg)
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
lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
| x /= y =
SApp tK (SVar y)
lambdaToT x t
| not (isFree x t) =
SApp tK t
lambdaToT x (SApp n u)
| not (isFree x (SApp n 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
| not (isFree x body) =
SApp tK body
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
tLeaf :: SaplingAST
tLeaf = TLeaf
freeVars :: SaplingAST -> Set String
freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs
freeVars (SFunc _ _ b) = freeVars b
freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty
freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
isFree :: String -> SaplingAST -> Bool
isFree x = Set.member x . freeVars
toAST :: T -> SaplingAST
toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
tI :: SaplingAST
tI = toAST _I
tK :: SaplingAST
tK = toAST _K
tS :: SaplingAST
tS = toAST _S

10
src/Lexer.hs
View File

@ -13,6 +13,8 @@ data LToken
| LIntegerLiteral Int
| LStringLiteral String
| LAssign
| LColon
| LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
@ -48,6 +50,12 @@ stringLiteral = do
assign :: Lexer LToken
assign = char '=' *> pure LAssign
colon :: Lexer LToken
colon = char ':' *> pure LColon
backslash :: Lexer LToken
backslash = char '\\' *> pure LBackslash
openParen :: Lexer LToken
openParen = char '(' *> pure LOpenParen
@ -73,6 +81,8 @@ saplingLexer = many (sc *> choice
, try integerLiteral
, try stringLiteral
, assign
, colon
, backslash
, openParen
, closeParen
, openBracket

2
src/Main.hs
View File

@ -6,7 +6,7 @@ import Parser
import REPL (repl)
import Research
import Data.Map as Map
import qualified Data.Map as Map
import Text.Megaparsec (runParser)
main :: IO ()

72
src/Parser.hs
View File

@ -1,5 +1,7 @@
module Parser where
import Debug.Trace
import Lexer
import Research hiding (toList)
@ -18,10 +20,11 @@ data SaplingAST
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST [SaplingAST]
| SApp SaplingAST SaplingAST
| TLeaf
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
@ -41,10 +44,11 @@ scnParser = skipMany (satisfy isNewline)
parseExpression :: Parser SaplingAST
parseExpression = choice
[ try parseFunction
, try parseLambda
, try parseListLiteral
, try parseApplication
, parseTreeTerm
, try parseTreeTerm
, parseLiteral
, parseListLiteral
]
parseFunction :: Parser SaplingAST
@ -55,13 +59,42 @@ parseFunction = do
body <- parseExpression
return (SFunc name (map getIdentifier args) body)
parseLambda :: Parser SaplingAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
param <- satisfy isIdentifier
rest <- many (satisfy isIdentifier)
satisfy (== LColon)
body <- parseLambdaExpression
let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
return (SLambda [getIdentifier param] nestedLambda)
parseLambdaExpression :: Parser SaplingAST
parseLambdaExpression = choice
[ try parseLambdaApplication
, parseAtomicLambda
]
parseAtomicLambda :: Parser SaplingAST
parseAtomicLambda = choice
[ parseVar
, parseTreeLeaf
, parseLiteral
, parseListLiteral
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
parseApplication :: Parser SaplingAST
parseApplication = do
func <- parseAtomicBase
args <- many parseAtomicApplication
case func of
TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
_ -> return (SApp func args)
args <- many parseAtomic
return $ foldl (\acc arg -> SApp acc arg) func args
parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication = do
func <- parseAtomicLambda
args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool
isTreeTerm TLeaf = True
@ -73,6 +106,7 @@ parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ parseVar
, parseTreeLeaf
, parseGrouped
]
parseTreeLeaf :: Parser SaplingAST
@ -107,27 +141,15 @@ foldTree (x:y:rest) = TFork x (foldTree (y:rest))
parseAtomic :: Parser SaplingAST
parseAtomic = choice
[ parseVar
, parseTreeLeafOrParenthesized
, parseLiteral
, parseTreeLeaf
, parseListLiteral
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
, parseGrouped
, parseLiteral
]
parseAtomicApplication :: Parser SaplingAST
parseAtomicApplication = do
token <- anySingle
case token of
LAssign -> fail
"Unexpected `=` character in application context. \
\ This is usually caused by an incomplete definition such as: \
\ `function a b =`"
LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf
LIntegerLiteral value -> return (SInt value)
LStringLiteral value -> return (SStr value)
LOpenBracket -> parseListLiteral
LOpenParen -> between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
_ -> fail "Invalid token while parsing attempted function application"
parseGrouped :: Parser SaplingAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
parseLiteral :: Parser SaplingAST
parseLiteral = choice

104
test/Spec.hs
View File

@ -4,7 +4,6 @@ import Eval
import Lexer
import Parser
import Research
import Control.Exception (evaluate, try, SomeException)
import qualified Data.Map as Map
import Test.Tasty
@ -28,37 +27,31 @@ lexerTests :: TestTree
lexerTests = testGroup "Lexer Tests"
[ testCase "Lex simple identifiers" $ do
let input = "x a b = a"
let expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
runParser saplingLexer "" input @?= expect
, testCase "Lex Tree Calculus terms" $ do
let input = "t t t"
let expect = Right [LKeywordT, LKeywordT, LKeywordT]
expect = Right [LKeywordT, LKeywordT, LKeywordT]
runParser saplingLexer "" input @?= expect
, testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\""
let expect = Right [LStringLiteral "hello\\nworld"]
expect = Right [LStringLiteral "hello\\nworld"]
runParser saplingLexer "" input @?= expect
, testCase "Lex mixed literals" $ do
let input = "t \"string\" 42"
let expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
runParser saplingLexer "" input @?= expect
, testCase "Lex invalid token" $ do
let input = "$invalid"
case runParser saplingLexer "" input of
Left _ -> return ()
Right _ -> assertFailure "Expected lexer to fail on invalid token"
, testCase "Drop trailing whitespace in definitions" $ do
let input = "x = 5 "
let expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
case (runParser saplingLexer "" input) of
Left _ -> assertFailure "Failed to lex input"
Right i -> i @?= expect
, testCase "Error when using invalid characters in identifiers" $ do
case (runParser saplingLexer "" "__result = 5") of
Left _ -> return ()
@ -72,97 +65,93 @@ parserTests = testGroup "Parser Tests"
case (runParser parseExpression "" input) of
Left _ -> return ()
Right _ -> assertFailure "Expected failure on invalid input"
, testCase "Error when assigning a value to T" $ do
let input = lexSapling "t = x"
case (runParser parseExpression "" input) of
Left _ -> return ()
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
let input = "x a b = a"
let expect = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
let input = "x a b c = a"
let expect = SFunc "x" ["a","b","c"] (SVar "a")
parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do
let input = "t (t t) t"
let expect = TFork (TStem TLeaf) TLeaf
let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
parseSingle input @?= expect
, testCase "Parse sequential Tree Calculus terms" $ do
let input = "t t t"
let expect = TFork TLeaf TLeaf
let expect = SApp (SApp TLeaf TLeaf) TLeaf
parseSingle input @?= expect
, testCase "Parse mixed list literals" $ do
let input = "[t (\"hello\") t]"
let expect = SList [TLeaf, SStr "hello", TLeaf]
parseSingle input @?= expect
, testCase "Parse function with applications" $ do
let input = "f x = t x"
let expect = SFunc "f" ["x"] (SApp TLeaf [SVar "x"])
let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
parseSingle input @?= expect
, testCase "Parse nested lists" $ do
let input = "[t [(t t)]]"
let expect = SList [TLeaf, SList [TStem TLeaf]]
let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
parseSingle input @?= expect
, testCase "Parse complex parentheses" $ do
let input = "t (t t (t t))"
let expect = TStem (TFork TLeaf (TStem TLeaf))
let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
parseSingle input @?= expect
, testCase "Parse empty list" $ do
let input = "[]"
let expect = SList []
parseSingle input @?= expect
, testCase "Parse multiple nested lists" $ do
let input = "[[t t] [t (t t)]]"
let expect = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]]
let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
parseSingle input @?= expect
, testCase "Parse whitespace variance" $ do
let input1 = "[t t]"
let input2 = "[ t t ]"
let expect = SList [TLeaf, TLeaf]
parseSingle input1 @?= expect
parseSingle input2 @?= expect
, testCase "Parse string in list" $ do
let input = "[(\"hello\")]"
let expect = SList [SStr "hello"]
parseSingle input @?= expect
, testCase "Parse parentheses inside list" $ do
let input = "[t (t t)]"
let expect = SList [TLeaf, TStem TLeaf]
let expect = SList [TLeaf,SApp TLeaf TLeaf]
parseSingle input @?= expect
, testCase "Parse nested parentheses in function body" $ do
let input = "f = t (t (t t))"
let expect = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do
let input = "(\\a : a)"
let expect = (SLambda ["a"] (SVar "a"))
parseSingle input @?= expect
, testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)"
let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
parseSingle input @?= expect
, testCase "Grouping T terms with parentheses in function application" $ do
let input = "x = (\\a : a)\n" <> "x (t)"
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
parseSapling input @?= expect
]
integrationTests :: TestTree
integrationTests = testGroup "Integration Tests"
[ testCase "Combine lexer and parser" $ do
let input = "x = t t t"
let expect = SFunc "x" [] (TFork TLeaf TLeaf)
let expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
parseSingle input @?= expect
, testCase "Complex Tree Calculus expression" $ do
let input = "t (t t t) t"
let expect = TFork (TFork TLeaf TLeaf) TLeaf
let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
parseSingle input @?= expect
]
@ -172,72 +161,73 @@ evaluationTests = testGroup "Evaluation Tests"
let input = "t"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Leaf
, testCase "Evaluate single Stem" $ do
let input = "t t"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Stem Leaf
, testCase "Evaluate single Fork" $ do
let input = "t t t"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
, testCase "Evaluate nested Fork and Stem" $ do
let input = "t (t t) t"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
, testCase "Evaluate `not` function" $ do
let input = "t (t (t t) (t t t)) t)"
let input = "t (t (t t) (t t t)) t"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?=
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Environment updates with definitions" $ do
let input = "x = t\ny = x"
let env = evalSapling Map.empty (parseSapling input)
Map.lookup "x" env @?= Just Leaf
Map.lookup "y" env @?= Just Leaf
, testCase "Variable substitution" $ do
let input = "x = t t\ny = t x\ny"
let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Stem (Stem Leaf)
, testCase "Multiline input evaluation" $ do
let input = "x = t\ny = t t\nx"
let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf
, testCase "Evaluate string literal" $ do
let input = "\"hello\""
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toString "hello"
, testCase "Evaluate list literal" $ do
let input = "[t (t t)]"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
, testCase "Evaluate empty list" $ do
let input = "[]"
let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toList []
, testCase "Evaluate variable dependency chain" $ do
let input = "x = t\n \
\ y = t x\n \
\ z = t y\n \
let input = "x = t (t t)\n \
\ y = x\n \
\ z = y\n \
\ variablewithamuchlongername = z\n \
\ variablewithamuchlongername"
let env = evalSapling Map.empty (parseSapling input)
(result env) @?= (Stem (Stem Leaf))
, testCase "Evaluate redefinition of variables" $ do
, testCase "Evaluate variable shadowing" $ do
let input = "x = t t\nx = t\nx"
let env = evalSapling Map.empty (parseSapling input)
(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
let not = "(t (t (t t) (t t t)) t)"
input = "x = (\\a : a)\nx " ++ not
env = evalSapling Map.empty (parseSapling input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Constant function matches" $ do
let input = "k = (\\a b : a)\nk (t t) t"
env = evalSapling Map.empty (parseSapling input)
result env @?= Stem Leaf
]
propertyTests :: TestTree