From a8f72290a2f97893538fd06ec3df0c7ebec40b9b Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sun, 29 Dec 2024 20:29:41 -0600 Subject: [PATCH] Resolves issue with parsing comments --- src/Eval.hs | 7 ++++--- src/Lexer.hs | 51 +++++++++++++++++++++++++++---------------------- src/Main.hs | 14 +++++++------- src/Parser.hs | 27 ++++++++++++++++---------- src/REPL.hs | 30 ++++++++++++++++++++--------- src/Research.hs | 7 ++++--- test/Spec.hs | 15 +-------------- 7 files changed, 82 insertions(+), 69 deletions(-) diff --git a/src/Eval.hs b/src/Eval.hs index d840b28..f837b3b 100644 --- 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 index 58b3a45..2e2303d 100644 --- 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 index b3434c8..80c2959 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,14 +1,14 @@ 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 Text.Megaparsec (runParser) import qualified Data.Map as Map -import Text.Megaparsec (runParser) main :: IO () main = do diff --git a/src/Parser.hs b/src/Parser.hs index f0e2ac0..beb157b 100644 --- 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 index 3a601fd..d283956 100644 --- 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 index 317b842..e12981e 100644 --- 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 index b8faef9..434e229 100644 --- 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)