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

Somewhat working lambdas

Browse Source 
Architectural changes to lambda evaluation and parsing to allow
for correct expression evaluation. Contains several failing AI-generated
tests and we're still failing tests for erroring incomplete definitions
This commit is contained in:
James Eversole
2024-12-27 12:27:00 -06:00
committed by James Eversole
parent 5e574d2ca1
commit c3c6646cb2
5 changed files with 420 additions and 336 deletions
Download Patch File Download Diff File Expand all files Collapse all files

134
src/Eval.hs
View File

@ -2,121 +2,93 @@ 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.Map String T -> SaplingAST -> Map.Map String T
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (foldl')
import qualified Data.Set as Set
evalSingle :: Map String T -> SaplingAST -> 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
SVar name -> case Map.lookup name env of
Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined"
_ ->
let result = evalAST env term
in Map.insert "__result" result env
SFunc name [] body ->
let
lineNoLambda = eliminateLambda body
result = evalAST env lineNoLambda
in Map.insert name result env
SLambda _ body ->
let result = evalAST env body
in Map.insert "__result" result env
SApp func arg ->
let result = apply (evalAST env func) (evalAST env arg)
in Map.insert "__result" result env
SVar name ->
case Map.lookup name env of
Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined"
_ ->
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
lastLineNoLambda = eliminateLambda lastLine
let lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
let
lineNoLambda = eliminateLambda line
let lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
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"
SVar name -> case Map.lookup name env of
Just value -> value
Nothing -> error $ "Variable " ++ name ++ " not defined"
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)
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
Just a -> a
Nothing -> error "No __result field found in provided environment"
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
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)
| 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 other = other
lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y)
| x == y = tI
| x == y = tI
lambdaToT x (SVar y)
| x /= y =
SApp tK (SVar y)
| x /= y = SApp tK (SVar y)
lambdaToT x t
| not (isFree x t) =
SApp tK 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
| 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 body
| not (isFree x body) =
SApp tK body
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
| not (isFree x body) = SApp tK body
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
tLeaf :: SaplingAST
tLeaf = TLeaf
freeVars :: SaplingAST -> Set String
freeVars :: SaplingAST -> Set.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 (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
@ -130,11 +102,15 @@ toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
tI :: SaplingAST
tI = toAST _I
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: SaplingAST
tK = toAST _K
tK = SApp TLeaf TLeaf
tS :: SaplingAST
tS = toAST _S
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
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"

5
src/Lexer.hs
View File

@ -7,6 +7,7 @@ import Data.Void
import qualified Data.Set as Set
type Lexer = Parsec Void String
data LToken
= LKeywordT
| LIdentifier String
@ -44,7 +45,7 @@ stringLiteral = do
if null content
then fail "Empty string literals are not allowed"
else do
char '"' -- "
char '"'
return (LStringLiteral content)
assign :: Lexer LToken
@ -92,5 +93,5 @@ saplingLexer = many (sc *> choice
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

3
src/Main.hs
View File

@ -11,3 +11,6 @@ import Text.Megaparsec (runParser)
main :: IO ()
main = repl Map.empty --(Map.fromList [("__result", Leaf)])
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)

100
src/Parser.hs
View File

@ -1,10 +1,8 @@
module Parser where
import Debug.Trace
import Lexer
import Research hiding (toList)
import Control.Exception (throw)
import Data.List.NonEmpty (toList)
import qualified Data.Set as Set
@ -14,17 +12,18 @@ import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken]
data SaplingAST
= SVar String
| SInt Int
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST
= SVar String
| SInt Int
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST
| TLeaf
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
@ -35,7 +34,7 @@ parseSapling input =
parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err
Left err -> error $ handleParseError err
Right ast -> ast
scnParser :: Parser ()
@ -45,6 +44,7 @@ parseExpression :: Parser SaplingAST
parseExpression = choice
[ try parseFunction
, try parseLambda
, try parseLambdaExpression
, try parseListLiteral
, try parseApplication
, try parseTreeTerm
@ -59,6 +59,19 @@ parseFunction = do
body <- parseExpression
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 = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
@ -81,6 +94,7 @@ parseAtomicLambda = choice
, parseTreeLeaf
, parseLiteral
, parseListLiteral
, try parseLambda
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
@ -92,22 +106,15 @@ parseApplication = do
parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication = do
func <- parseAtomicLambda
args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args
func <- parseAtomicLambda
args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool
isTreeTerm TLeaf = True
isTreeTerm (TStem _) = True
isTreeTerm TLeaf = True
isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True
isTreeTerm _ = False
parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ parseVar
, parseTreeLeaf
, parseGrouped
]
isTreeTerm _ = False
parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
@ -123,8 +130,8 @@ parseTreeTerm = do
pure $ foldl combine base rest
where
combine acc next = case acc of
TLeaf -> TStem next
TStem t -> TFork t next
TLeaf -> TStem next
TStem t -> TFork t next
TFork _ _ -> TFork acc next
parseTreeLeafOrParenthesized :: Parser SaplingAST
@ -147,7 +154,6 @@ parseAtomic = choice
, parseLiteral
]
parseGrouped :: Parser SaplingAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
@ -190,8 +196,8 @@ parseSingleItem = do
token <- satisfy isListItem
case token of
LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf
_ -> fail "Unexpected token in list item"
LKeywordT -> return TLeaf
_ -> fail "Unexpected token in list item"
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
@ -216,24 +222,19 @@ parseStrLiteral = do
return (SStr value)
-- Boolean Helpers
isKeywordT (LKeywordT) = True
isKeywordT _ = False
isIdentifier (LIdentifier _) = True
isIdentifier _ = False
isKeywordT (LKeywordT) = True
isKeywordT _ = False
isIdentifier (LIdentifier _) = True
isIdentifier _ = False
isIntegerLiteral (LIntegerLiteral _) = True
isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False
isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
esNewline (LNewline) = True
isNewline _ = False
isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False
isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
isNewline (LNewline) = True
isNewline _ = False
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
@ -246,9 +247,10 @@ handleParseError bundle =
showError :: ParseError [LToken] Void -> String
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
"Parse error at offset " ++ show offset ++ ": unexpected token "
++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
showError (FancyError offset fancy) =
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of "
++ show (Set.toList expected)
++ show (Set.toList expected)