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

Rename from sapling to tricu

Browse Source
This commit is contained in:
James Eversole
2024-12-29 08:29:25 -06:00
parent 064bed26c5
commit c30f17367f
10 changed files with 136 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
src/Eval.hs
View File

@ -8,7 +8,7 @@ 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 :: Map String T -> TricuAST -> Map String T
evalSingle env term = case term of
SFunc name [] body ->
let lineNoLambda = eliminateLambda body
@ -28,18 +28,18 @@ evalSingle env term = case term of
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] =
evalTricu :: Map String T -> [TricuAST] -> Map String T
evalTricu env [] = env
evalTricu env [lastLine] =
let lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
evalTricu env (line:rest) =
let lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
in evalTricu updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T
evalAST :: Map String T -> TricuAST -> T
evalAST env term = case term of
SVar name -> case Map.lookup name env of
Just value -> value
@ -56,7 +56,7 @@ evalAST env term = case term of
++ " in evalAST; define via evalSingle."
SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda :: TricuAST -> TricuAST
eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body)
| otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
@ -69,7 +69,7 @@ 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 -> TricuAST -> TricuAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
@ -83,7 +83,7 @@ lambdaToT x body
| not (isFree x body) = SApp tK body
| otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
freeVars :: SaplingAST -> Set.Set String
freeVars :: TricuAST -> Set.Set String
freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty
@ -95,23 +95,23 @@ 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 :: String -> TricuAST -> Bool
isFree x = Set.member x . freeVars
toAST :: T -> SaplingAST
toAST :: T -> TricuAST
toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
-- We need the SKI operators in an unevaluated SaplingAST tree form so that we
-- We need the SKI operators in an unevaluated TricuAST tree form so that we
-- can keep the evaluation functions straightforward
tI :: SaplingAST
tI :: TricuAST
tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: SaplingAST
tK :: TricuAST
tK = SApp TLeaf TLeaf
tS :: SaplingAST
tS :: TricuAST
tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
result :: Map String T -> T

8
src/Lexer.hs
View File

@ -86,8 +86,8 @@ comment = do
sc :: Lexer ()
sc = skipMany (void (char ' ') <|> void (char '\t') <|> void comment)
saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice
tricuLexer :: Lexer [LToken]
tricuLexer = many (sc *> choice
[ try identifier
, try keywordT
, try integerLiteral
@ -102,7 +102,7 @@ saplingLexer = many (sc *> choice
, lnewline
] <* sc) <* eof
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

2
src/Library.hs
View File

@ -7,7 +7,7 @@ import Research
import qualified Data.Map as Map
library :: Map.Map String T
library = evalSapling Map.empty $ parseSapling $ unlines
library = evalTricu Map.empty $ parseTricu $ unlines
[ "false = t"
, "true = t t"
, "_ = t"

8
src/Main.hs
View File

@ -12,11 +12,11 @@ import Text.Megaparsec (runParser)
main :: IO ()
main = do
putStrLn "Welcome to the Sapling Interpreter"
putStrLn "Welcome to the Tricu 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)
runTricu :: String -> T
runTricu s = result (evalTricu Map.empty $ parseTricu s)
runTricuEnv env s = result (evalTricu env $ parseTricu s)

72
src/Parser.hs
View File

@ -13,33 +13,33 @@ import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken]
data SaplingAST
data TricuAST
= SVar String
| SInt Int
| SStr String
| SList [SaplingAST]
| SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST
| SList [TricuAST]
| SFunc String [String] TricuAST
| SApp TricuAST TricuAST
| TLeaf
| TStem SaplingAST
| TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST
| TStem TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
parseSapling input =
parseTricu :: String -> [TricuAST]
parseTricu input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSingle nonEmptyLines
parseSingle :: String -> SaplingAST
parseSingle input = case runParser parseExpression "" (lexSapling input) of
parseSingle :: String -> TricuAST
parseSingle input = case runParser parseExpression "" (lexTricu input) of
Left err -> error $ handleParseError err
Right ast -> ast
scnParser :: Parser ()
scnParser = skipMany (satisfy isNewline)
parseExpression :: Parser SaplingAST
parseExpression :: Parser TricuAST
parseExpression = choice
[ try parseFunction
, try parseLambda
@ -50,7 +50,7 @@ parseExpression = choice
, parseLiteral
]
parseFunction :: Parser SaplingAST
parseFunction :: Parser TricuAST
parseFunction = do
LIdentifier name <- satisfy isIdentifier
args <- many (satisfy isIdentifier)
@ -58,20 +58,20 @@ parseFunction = do
body <- parseExpression
return (SFunc name (map getIdentifier args) body)
parseAtomicBase :: Parser SaplingAST
parseAtomicBase :: Parser TricuAST
parseAtomicBase = choice
[ try parseVarWithoutAssignment
, parseTreeLeaf
, parseGrouped
]
parseVarWithoutAssignment :: Parser SaplingAST
parseVarWithoutAssignment :: Parser TricuAST
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 TricuAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
param <- satisfy isIdentifier
@ -81,13 +81,13 @@ parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
return (SLambda [getIdentifier param] nestedLambda)
parseLambdaExpression :: Parser SaplingAST
parseLambdaExpression :: Parser TricuAST
parseLambdaExpression = choice
[ try parseLambdaApplication
, parseAtomicLambda
]
parseAtomicLambda :: Parser SaplingAST
parseAtomicLambda :: Parser TricuAST
parseAtomicLambda = choice
[ parseVar
, parseTreeLeaf
@ -97,32 +97,32 @@ parseAtomicLambda = choice
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
parseApplication :: Parser SaplingAST
parseApplication :: Parser TricuAST
parseApplication = do
func <- parseAtomicBase
args <- many parseAtomic
return $ foldl (\acc arg -> SApp acc arg) func args
parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication :: Parser TricuAST
parseLambdaApplication = do
func <- parseAtomicLambda
args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool
isTreeTerm :: TricuAST -> Bool
isTreeTerm TLeaf = True
isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True
isTreeTerm _ = False
parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf :: Parser TricuAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name
getIdentifier _ = error "Expected identifier"
parseTreeTerm :: Parser SaplingAST
parseTreeTerm :: Parser TricuAST
parseTreeTerm = do
base <- parseTreeLeafOrParenthesized
rest <- many parseTreeLeafOrParenthesized
@ -133,18 +133,18 @@ parseTreeTerm = do
TStem t -> TFork t next
TFork _ _ -> TFork acc next
parseTreeLeafOrParenthesized :: Parser SaplingAST
parseTreeLeafOrParenthesized :: Parser TricuAST
parseTreeLeafOrParenthesized = choice
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
, parseTreeLeaf
]
foldTree :: [SaplingAST] -> SaplingAST
foldTree :: [TricuAST] -> TricuAST
foldTree [] = TLeaf
foldTree [x] = x
foldTree (x:y:rest) = TFork x (foldTree (y:rest))
parseAtomic :: Parser SaplingAST
parseAtomic :: Parser TricuAST
parseAtomic = choice
[ parseVar
, parseTreeLeaf
@ -153,44 +153,44 @@ parseAtomic = choice
, parseLiteral
]
parseGrouped :: Parser SaplingAST
parseGrouped :: Parser TricuAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
parseLiteral :: Parser SaplingAST
parseLiteral :: Parser TricuAST
parseLiteral = choice
[ parseIntLiteral
, parseStrLiteral
]
parens :: Parser SaplingAST -> Parser SaplingAST
parens :: Parser TricuAST -> Parser TricuAST
parens p = do
satisfy (== LOpenParen)
result <- p
satisfy (== LCloseParen)
return result
parseListLiteral :: Parser SaplingAST
parseListLiteral :: Parser TricuAST
parseListLiteral = do
satisfy (== LOpenBracket)
elements <- many parseListItem
satisfy (== LCloseBracket)
return (SList elements)
parseListItem :: Parser SaplingAST
parseListItem :: Parser TricuAST
parseListItem = choice
[ parseGroupedItem
, parseListLiteral
, parseSingleItem
]
parseGroupedItem :: Parser SaplingAST
parseGroupedItem :: Parser TricuAST
parseGroupedItem = do
satisfy (== LOpenParen)
inner <- parseExpression
satisfy (== LCloseParen)
return inner
parseSingleItem :: Parser SaplingAST
parseSingleItem :: Parser TricuAST
parseSingleItem = do
token <- satisfy isListItem
case token of
@ -203,19 +203,19 @@ isListItem (LIdentifier _) = True
isListItem LKeywordT = True
isListItem _ = False
parseVar :: Parser SaplingAST
parseVar :: Parser TricuAST
parseVar = do
LIdentifier name <- satisfy isIdentifier
if (name == "t" || name == "__result")
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
else return (SVar name)
parseIntLiteral :: Parser SaplingAST
parseIntLiteral :: Parser TricuAST
parseIntLiteral = do
LIntegerLiteral value <- satisfy isIntegerLiteral
return (SInt value)
parseStrLiteral :: Parser SaplingAST
parseStrLiteral :: Parser TricuAST
parseStrLiteral = do
LStringLiteral value <- satisfy isStringLiteral
return (SStr value)

4
src/REPL.hs
View File

@ -15,7 +15,7 @@ repl env = runInputT defaultSettings (loop env)
where
loop :: Map.Map String T -> InputT IO ()
loop env = do
minput <- getInputLine "sapling < "
minput <- getInputLine "tricu < "
case minput of
Nothing -> outputStrLn "Goodbye!"
Just ":_exit" -> outputStrLn "Goodbye!"
@ -27,7 +27,7 @@ repl env = runInputT defaultSettings (loop env)
newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of
Just r -> do
outputStrLn $ "sapling > " ++ show r
outputStrLn $ "tricu > " ++ show r
outputStrLn $ "DECODE -: " ++ decodeResult r
Nothing -> return ()
loop newEnv