commit 31106aa28528e30b2db5871d697d40be752051de
parent 8a2dc2dfcf7228c8a612562ee8c4bc54bd41cd71
Author: James Eversole <james@eversole.co>
Date: Mon, 30 Dec 2024 03:03:39 +0000
Merge pull request 'Resolves issue with parsing comments' (#2) from fix/comments-0001 into main
Reviewed-on: https://git.eversole.co/James/tricu/pulls/2
Diffstat:
7 files changed, 82 insertions(+), 69 deletions(-)
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -4,8 +4,9 @@ import Parser
import Research
import Data.Map (Map)
-import qualified Data.Map as Map
import Data.List (foldl')
+
+import qualified Data.Map as Map
import qualified Data.Set as Set
evalSingle :: Map String T -> TricuAST -> Map String T
@@ -51,6 +52,7 @@ evalAST env term = case term of
SStr str -> ofString str
SInt num -> ofNumber num
SList elems -> ofList (map (evalAST Map.empty) elems)
+ SEmpty -> Leaf
SFunc name args body ->
error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle."
@@ -66,9 +68,8 @@ eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
eliminateLambda (SList xs) = SList (map eliminateLambda xs)
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
+-- Chapter 4: Lambda-Abstraction
lambdaToT :: String -> TricuAST -> TricuAST
lambdaToT x (SVar y)
| x == y = tI
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -2,10 +2,12 @@ module Lexer where
import Research
import Text.Megaparsec
-import Text.Megaparsec.Char
+import Text.Megaparsec.Char hiding (space)
+import Text.Megaparsec.Char.Lexer
import Control.Monad (void)
import Data.Void
+
import qualified Data.Set as Set
type Lexer = Parsec Void String
@@ -23,7 +25,6 @@ data LToken
| LOpenBracket
| LCloseBracket
| LNewline
- | LComment String
deriving (Show, Eq, Ord)
keywordT :: Lexer LToken
@@ -75,30 +76,34 @@ closeBracket = char ']' *> pure LCloseBracket
lnewline :: Lexer LToken
lnewline = char '\n' *> pure LNewline
-comment :: Lexer LToken
-comment = do
- string "--"
- content <- many (satisfy (/= '\n'))
- pure (LComment content)
-
sc :: Lexer ()
-sc = skipMany (void (char ' ') <|> void (char '\t') <|> void comment)
+sc = space space1 (skipLineComment "--") (skipBlockComment "|-" "-|")
tricuLexer :: Lexer [LToken]
-tricuLexer = many (sc *> choice
- [ try identifier
- , try keywordT
- , try integerLiteral
- , try stringLiteral
- , assign
- , colon
- , backslash
- , openParen
- , closeParen
- , openBracket
- , closeBracket
- , lnewline
- ] <* sc) <* eof
+tricuLexer = do
+ sc
+ tokens <- many $ do
+ tok <- choice tricuLexer'
+ sc
+ pure tok
+ sc
+ eof
+ pure tokens
+ where
+ tricuLexer' =
+ [ try identifier
+ , try keywordT
+ , try integerLiteral
+ , try stringLiteral
+ , assign
+ , colon
+ , backslash
+ , openParen
+ , closeParen
+ , openBracket
+ , closeBracket
+ ]
+
lexTricu :: String -> [LToken]
lexTricu input = case runParser tricuLexer "" input of
diff --git a/src/Main.hs b/src/Main.hs
@@ -1,15 +1,15 @@
module Main where
-import Eval
-import Lexer
-import Library
-import Parser
-import REPL (repl)
-import Research
+import Eval (evalTricu, result)
+import Library (library)
+import Parser (parseTricu)
+import REPL (repl)
+import Research (T)
-import qualified Data.Map as Map
import Text.Megaparsec (runParser)
+import qualified Data.Map as Map
+
main :: IO ()
main = do
putStrLn "Welcome to the tricu Interpreter"
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -1,16 +1,16 @@
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
-import Data.Void
+import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
+import qualified Data.Set as Set
+
type Parser = Parsec Void [LToken]
data TricuAST
@@ -24,17 +24,24 @@ data TricuAST
| TStem TricuAST
| TFork TricuAST TricuAST
| SLambda [String] TricuAST
+ | SEmpty
deriving (Show, Eq, Ord)
parseTricu :: String -> [TricuAST]
-parseTricu input =
- let nonEmptyLines = filter (not . null) (lines input)
- in map parseSingle nonEmptyLines
+parseTricu input
+ | null tokens = []
+ | otherwise = map parseSingle tokens
+ where
+ tokens = case lexTricu input of
+ [] -> []
+ tokens -> lines input
parseSingle :: String -> TricuAST
-parseSingle input = case runParser parseExpression "" (lexTricu input) of
- Left err -> error $ handleParseError err
- Right ast -> ast
+parseSingle input = case lexTricu input of
+ [] -> SEmpty
+ tokens -> case runParser parseExpression "" tokens of
+ Left err -> error $ handleParseError err
+ Right ast -> ast
parseExpression :: Parser TricuAST
parseExpression = choice
diff --git a/src/REPL.hs b/src/REPL.hs
@@ -5,10 +5,12 @@ import Lexer
import Parser
import Research
+import Control.Exception (SomeException, catch)
+import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate)
-import qualified Data.Map as Map
import System.Console.Haskeline
-import System.IO (hFlush, stdout)
+
+import qualified Data.Map as Map
repl :: Map.Map String T -> IO ()
repl env = runInputT defaultSettings (loop env)
@@ -23,15 +25,25 @@ repl env = runInputT defaultSettings (loop env)
outputStrLn ""
loop env
Just input -> do
- let clearEnv = Map.delete "__result" env
- newEnv = evalSingle clearEnv (parseSingle input)
- case Map.lookup "__result" newEnv of
- Just r -> do
- outputStrLn $ "tricu > " ++ show r
- outputStrLn $ "DECODE -: \"" ++ decodeResult r ++ "\""
- Nothing -> return ()
+ newEnv <- liftIO $ (processInput env input `catch` errorHandler env)
loop newEnv
+ processInput :: Map.Map String T -> String -> IO (Map.Map String T)
+ processInput env input = do
+ let clearEnv = Map.delete "__result" env
+ newEnv = evalSingle clearEnv (parseSingle input)
+ case Map.lookup "__result" newEnv of
+ Just r -> do
+ putStrLn $ "tricu > " ++ show r
+ putStrLn $ "READ -: \"" ++ decodeResult r ++ "\""
+ Nothing -> return ()
+ return newEnv
+
+ errorHandler :: Map.Map String T -> SomeException -> IO (Map.Map String T)
+ errorHandler env e = do
+ putStrLn $ "Error: " ++ show e
+ return env
+
decodeResult :: T -> String
decodeResult tc = case toNumber tc of
Right num -> show num
diff --git a/src/Research.hs b/src/Research.hs
@@ -1,10 +1,11 @@
module Research where
-import Data.List (intercalate)
import Control.Monad.State
-import qualified Data.Map as Map
+import Data.List (intercalate)
import Data.Map (Map)
+import qualified Data.Map as Map
+
data T = Leaf | Stem T | Fork T T
deriving (Show, Eq, Ord)
@@ -36,7 +37,7 @@ _K = Stem Leaf
-- Identity
-- We use the "point-free" style which drops a redundant node
--- Full _I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
+-- Full I form (SKK): Fork (Stem (Stem Leaf)) (Stem Leaf)
_I :: T
_I = Fork (Stem (Stem Leaf)) Leaf
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -25,7 +25,6 @@ tests :: TestTree
tests = testGroup "Tricu Tests"
[ lexerTests
, parserTests
- , integrationTests
, evaluationTests
, lambdaEvalTests
, libraryTests
@@ -159,18 +158,6 @@ parserTests = testGroup "Parser Tests"
-- parseTricu input @?= expect
]
-integrationTests :: TestTree
-integrationTests = testGroup "Integration Tests"
- [ testCase "Combine lexer and parser" $ do
- let input = "x = t t t"
- expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
- parseSingle input @?= expect
- , testCase "Complex Tree Calculus expression" $ do
- let input = "t (t t t) t"
- expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
- parseSingle input @?= expect
- ]
-
evaluationTests :: TestTree
evaluationTests = testGroup "Evaluation Tests"
[ testCase "Evaluate single Leaf" $ do
@@ -317,7 +304,7 @@ libraryTests = testGroup "Library Tests"
let input = "s (t) (t) (t)"
env = evalTricu library (parseTricu input)
result env @?= Fork Leaf (Stem Leaf)
- , testCase "SKK == I" $ do -- Tests for fully expanded I form
+ , testCase "SKK == I (fully expanded)" $ do
let input = "s k k"
env = evalTricu library (parseTricu input)
result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
