From dbfb7c4f285fda49c59648ef16c6d6bfdd4e59bd Mon Sep 17 00:00:00 2001
From: Marvin Borner
Date: Fri, 4 Mar 2022 01:10:12 +0100
Subject: Syntax

---
 src/Fun/Compiler.hs | 21 +++++++++++++++++----
 1 file changed, 17 insertions(+), 4 deletions(-)

(limited to 'src/Fun/Compiler.hs')

diff --git a/src/Fun/Compiler.hs b/src/Fun/Compiler.hs
index 46cfe13..a118103 100644
--- a/src/Fun/Compiler.hs
+++ b/src/Fun/Compiler.hs
@@ -3,6 +3,7 @@ module Fun.Compiler where
 import           Control.Exception
 import           Fun.Grammar
 import           Fun.Parser
+import           Fun.Syntax
 import           Fun.Tree
 import           System.Exit
 import           System.IO
@@ -17,27 +18,39 @@ traceBranch c (OrTrace t1 t2) =
     ++ (traceTree (c + 2) t2)
 
 traceTree :: Int -> [Trace] -> String -- TODO: Indent/arrow first map
-traceTree c ts = foldr join "" (map (traceBranch c) ts)
+traceTree c ts = foldr join "" $ map (traceBranch c) ts
   where join = (\a b -> a ++ if b == "" then b else " " ++ b)
 
 genTrace :: [Trace] -> String
 genTrace ts = "Trace of expectance:\n" ++ traceTree 0 ts
 
 parse :: String -> Either String Tree
-parse file = case tree file of
-  Left a -> Left $ "Parse fault!\n" ++ case a of
+parse s = case tree s of
+  Left a -> Left $ "Parse error!\n" ++ case a of
     State [] Nothing    -> "No context available"
     State t  Nothing    -> genTrace t
     State [] (Just str) -> "Around here:\n" ++ str
     State t  (Just str) -> genTrace t ++ "\nAround here:\n" ++ str
   Right (a, b) -> Right a
 
+check :: Tree -> Either String Tree
+check t = case checkTree t of
+  Left  a -> Left $ "Syntax error!\n" ++ (join a)
+  Right a -> Right a
+ where
+  join = foldr (\(SyntaxError a) b -> a ++ if b == "" then b else "\n" ++ b) ""
+
+-- TODO: Find higher-order infix
+f <~ e = case e of
+  Left  e -> Left e
+  Right e -> f e
+
 compile :: String -> IO ()
 compile path = do
   file <- try $ readFile path
   case file of
     Left  exception -> print (exception :: IOError)
-    Right file      -> case parse file of
+    Right file      -> case check <~ parse file of
       Left err -> do
         hPutStrLn stderr err
         exitWith (ExitFailure 1)
-- 
cgit v1.2.3