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
committed by James Eversole
parent 1e23465bc3
commit 7a7ee6886a
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