Merge pull request 'Resolves issue with parsing comments' (#2) from fix/comments-0001 into main

Reviewed-on: #2

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

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

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

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

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

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 
 

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)