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

0.2.0

Browse Source 
Includes better error handling, additional tests, parsing and lexing
fixes to match the desired behavior defined by the new tests, and a very
basic REPL implementation.
This commit is contained in:
James Eversole
2024-12-20 11:38:09 -06:00
parent a61627f333
commit c16c48b22c
8 changed files with 234 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/Eval.hs
View File

@ -6,31 +6,31 @@ import Research
import qualified Data.Map as Map
import Data.Map (Map)
evalSapling :: Map String T -> SaplingAST -> Map String T
evalSapling env TLeaf = Map.insert "__result" Leaf env
evalSapling env (TStem t) =
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)
in Map.insert "__result" result env
evalSapling env (TFork t1 t2) =
evalSingle env (TFork t1 t2) =
let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
in Map.insert "__result" result env
evalSapling env (SFunc name [] body) =
evalSingle env (SFunc name [] body) =
let value = evalTreeCalculus env body
in Map.insert name value env
evalSapling env (SVar name) =
evalSingle env (SVar name) =
case Map.lookup name env of
Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSapling env ast = Map.insert "__result" (evalTreeCalculus env ast) env
evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env
evalMulti :: Map String T -> [SaplingAST] -> Map String T
evalMulti env [] = env
evalMulti env [lastLine] =
let updatedEnv = evalSapling env lastLine
evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env
evalSapling env [lastLine] =
let updatedEnv = evalSingle env lastLine
in Map.insert "__result" (result updatedEnv) updatedEnv
evalMulti env (line:rest) =
let updatedEnv = evalSapling env line
in evalMulti updatedEnv rest
evalSapling env (line:rest) =
let updatedEnv = evalSingle env line
in evalSapling updatedEnv rest
evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
evalTreeCalculus _ TLeaf = Leaf
@ -51,7 +51,7 @@ evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elem
evalTreeCalculus _ (SFunc name args body) =
error $ "Unexpected function definition " ++ name ++ " in \
\ evalTreeCalculus; functions should be evaluated to Tree Calculus \
\ terms by evalSapling."
\ terms by evalSingle."
result :: Map String T -> T
result r = case (Map.lookup "__result" r) of

22
src/Lexer.hs
View File

@ -4,7 +4,9 @@ import Research
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Void
import qualified Data.Set as Set
-- Lexer type and tokens
type Lexer = Parsec Void String
data LToken
= LKeywordT
@ -19,6 +21,7 @@ data LToken
| LNewline
deriving (Show, Eq, Ord)
-- Lexical rules
keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
@ -38,8 +41,11 @@ stringLiteral :: Lexer LToken
stringLiteral = do
char '"'
content <- many (noneOf ['"'])
char '"' --"
return (LStringLiteral content)
if null content
then fail "Empty string literals are not allowed"
else do
char '"' -- "
return (LStringLiteral content)
assign :: Lexer LToken
assign = char '=' *> pure LAssign
@ -59,13 +65,15 @@ closeBracket = char ']' *> pure LCloseBracket
lnewline :: Lexer LToken
lnewline = char '\n' *> pure LNewline
-- Whitespace consumer
sc :: Lexer ()
sc = skipMany (char ' ' <|> char '\t')
-- Lexer definition
saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice
[ try keywordT
, try identifier
[ try identifier
, try keywordT
, try integerLiteral
, try stringLiteral
, assign
@ -74,8 +82,10 @@ saplingLexer = many (sc *> choice
, openBracket
, closeBracket
, lnewline
]) <* eof
] <* sc) <* eof
-- Lexing function with enhanced error handling
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
Left err -> error "Failed to lex input"
Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens

7
src/Main.hs
View File

@ -3,14 +3,11 @@ module Main where
import Eval
import Lexer
import Parser
import REPL (repl)
import Research
import Data.Map as Map
import Text.Megaparsec (runParser)
main :: IO ()
main = putStr
$ show
$ result
$ evalMulti Map.empty (parseMulti
"false = t\nnot = t (t (t t) (t t t)) t\ntrue = not false\ntrue")
main = repl Map.empty --(Map.fromList [("__result", Leaf)])

89
src/Parser.hs
View File

@ -1,10 +1,15 @@
module Parser where
import Lexer
import Research
import Research hiding (toList)
import Control.Exception (throw)
import Data.List.NonEmpty (toList)
import qualified Data.Set as Set
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Void
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken]
data SaplingAST
@ -19,10 +24,15 @@ data SaplingAST
| TFork SaplingAST SaplingAST
deriving (Show, Eq, Ord)
parseSapling :: String -> SaplingAST
parseSapling "" = error "Empty input provided to parseSapling"
parseSapling input = case runParser parseExpression "" (lexSapling input) of
Left err -> error "Failed to parse input"
parseSapling :: String -> [SaplingAST]
parseSapling input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSingle nonEmptyLines
parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err
Right ast -> ast
scnParser :: Parser ()
@ -48,7 +58,7 @@ parseFunction = do
parseApplication :: Parser SaplingAST
parseApplication = do
func <- parseAtomicBase
args <- many parseAtomic
args <- many parseAtomicApplication
case func of
TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
_ -> return (SApp func args)
@ -66,7 +76,7 @@ parseAtomicBase = choice
]
parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> pure TLeaf
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name
@ -86,7 +96,7 @@ parseTreeTerm = do
parseTreeLeafOrParenthesized :: Parser SaplingAST
parseTreeLeafOrParenthesized = choice
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
, satisfy isKeywordT *> pure TLeaf
, parseTreeLeaf
]
foldTree :: [SaplingAST] -> SaplingAST
@ -103,6 +113,22 @@ parseAtomic = choice
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
]
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"
parseLiteral :: Parser SaplingAST
parseLiteral = choice
[ parseIntLiteral
@ -125,21 +151,21 @@ parseListLiteral = do
parseListItem :: Parser SaplingAST
parseListItem = choice
[ parseGroupedItem -- Handle expressions inside parentheses
, parseListLiteral -- Allow nested lists
, parseSingleItem -- Handle single tokens like `t` or identifiers
[ parseGroupedItem
, parseListLiteral
, parseSingleItem
]
parseGroupedItem :: Parser SaplingAST
parseGroupedItem = do
satisfy (== LOpenParen)
satisfy (== LOpenParen)
inner <- parseExpression
satisfy (== LCloseParen)
return inner
parseSingleItem :: Parser SaplingAST
parseSingleItem = do
token <- satisfy isListItem
token <- satisfy isListItem
case token of
LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf
@ -151,9 +177,11 @@ isListItem LKeywordT = True
isListItem _ = False
parseVar :: Parser SaplingAST
parseVar = do
parseVar = do
LIdentifier name <- satisfy isIdentifier
return (SVar name)
if (name == "t" || name == "__result")
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
else return (SVar name)
parseIntLiteral :: Parser SaplingAST
parseIntLiteral = do
@ -165,11 +193,6 @@ parseStrLiteral = do
LStringLiteral value <- satisfy isStringLiteral
return (SStr value)
parseMulti :: String -> [SaplingAST]
parseMulti input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSapling nonEmptyLines
-- Boolean Helpers
isKeywordT (LKeywordT) = True
isKeywordT _ = False
@ -183,5 +206,27 @@ isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False
isNewline (LNewline) = True
isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
esNewline (LNewline) = True
isNewline _ = False
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle =
let errors = bundleErrors bundle
errorList = toList errors
formattedErrors = map showError errorList
in unlines ("Parse error(s) encountered:" : formattedErrors)
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)
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)

25
src/REPL.hs Normal file
View File

@ -0,0 +1,25 @@
module REPL where
import Eval
import Lexer
import Parser
import Research
import Control.Monad (void)
import qualified Data.Map as Map
import System.IO (hFlush, stdout)
repl :: Map.Map String T -> IO ()
repl env = do
putStr "sapling > "
hFlush stdout
input <- getLine
if input == "_:exit"
then putStrLn "Goodbye!"
else do
let clearEnv = Map.delete "__result" env
let newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of
Just r -> putStrLn $ "sapling < " ++ show r
Nothing -> pure ()
repl newEnv

18
src/Research.hs
View File

@ -24,8 +24,8 @@ reduce expr =
step :: T -> T
step (Fork left right) = reduce (apply (reduce left) (reduce right))
step (Stem inner) = Stem (reduce inner)
step t = t
step (Stem inner) = Stem (reduce inner)
step t = t
-- SKI Combinators
_S :: T
@ -54,20 +54,20 @@ toString str = toList (map toNumber (map fromEnum str))
ofString :: T -> String
ofString tc = map (toEnum . ofNumber) (ofList tc)
toNumber :: Int -> T
toNumber :: Int -> T
toNumber 0 = Leaf
toNumber n =
Fork
(if odd n then Stem Leaf else Leaf)
(toNumber (n `div` 2))
(toNumber (n `div` 2))
ofNumber :: T -> Int
ofNumber Leaf = 0
ofNumber (Fork Leaf rest) = 2 * ofNumber rest
ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
ofNumber _ = error "Invalid Tree Calculus number"
ofNumber _ = error "Invalid Tree Calculus number"
toList :: [T] -> T
toList :: [T] -> T
toList [] = Leaf
toList (x:xs) = Fork x (toList xs)
@ -92,13 +92,13 @@ toAscii tree = go tree "" True
++ go right (prefix ++ (if isLast then " " else "| ")) True
rules :: IO ()
rules = putStr $ header
++ (unlines $ tcRules)
rules = putStr $ header
++ (unlines $ tcRules)
++ (unlines $ haskellRules)
++ footer
where
tcRules :: [String]
tcRules =
tcRules =
[ "| |"
, "| ┌--------- | Tree Calculus | ---------┐ |"
, "| | 1. t t a b -> a | |"