Return error from parseTestFile

5 files changed, 58 insertions, 26 deletions

diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 06558a8..6661f8b 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -81,6 +81,7 @@ executable erebos-tester
         src/main.c
 
     other-extensions:
+        CPP
         TemplateHaskell
     default-extensions:
         DefaultSignatures
diff --git a/minici.yaml b/minici.yaml
index a3f87f5..95dc61d 100644
--- a/minici.yaml
+++ b/minici.yaml
@@ -1,3 +1,3 @@
 job build:
   shell:
-    - cabal build -fci
+    - cabal build -fci --constraint='megaparsec >= 9.7.0'
diff --git a/src/Main.hs b/src/Main.hs
index 64741e4..abc96ac 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,6 +8,7 @@ import Data.Maybe
 import Data.Text qualified as T
 
 import Text.Read (readMaybe)
+import Text.Megaparsec (errorBundlePretty, showErrorComponent)
 
 import System.Console.GetOpt
 import System.Directory
@@ -170,7 +171,17 @@ main = do
             | otherwise       = OutputStyleQuiet
     out <- startOutput outputStyle useColor
 
-    ( modules, allModules ) <- parseTestFiles $ map fst files
+    ( modules, allModules ) <- parseTestFiles (map fst files) >>= \case
+        Right res -> do
+            return res
+        Left err -> do
+            case err of
+                ImportModuleError bundle ->
+                    putStr (errorBundlePretty bundle)
+                _ -> do
+                    putStrLn (showErrorComponent err)
+            exitFailure
+
     tests <- forM (zip modules files) $ \( Module {..}, ( filePath, mbTestName )) -> do
         case mbTestName of
             Nothing -> return moduleTests
diff --git a/src/Parser.hs b/src/Parser.hs
index d90b796..b2d666c 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -2,9 +2,11 @@
 
 module Parser (
     parseTestFiles,
+    CustomTestError(..),
 ) where
 
 import Control.Monad
+import Control.Monad.Except
 import Control.Monad.State
 
 import Data.IORef
@@ -22,7 +24,6 @@ import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer qualified as L
 
 import System.Directory
-import System.Exit
 import System.FilePath
 import System.IO.Error
 
@@ -174,27 +175,23 @@ parseTestModule absPath = do
     eof
     return Module {..}
 
-parseTestFiles :: [ FilePath ] -> IO ( [ Module ], [ Module ] )
+parseTestFiles :: [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] ))
 parseTestFiles paths = do
     parsedModules <- newIORef []
-    requestedModules <- reverse <$> foldM (go parsedModules) [] paths
-    allModules <- map snd <$> readIORef parsedModules
-    return ( requestedModules, allModules )
+    runExceptT $ do
+        requestedModules <- reverse <$> foldM (go parsedModules) [] paths
+        allModules <- map snd <$> liftIO (readIORef parsedModules)
+        return ( requestedModules, allModules )
   where
     go parsedModules res path = do
-        let moduleName = error "current module name should be set at the beginning of parseTestModule"
-        parseTestFile parsedModules moduleName path >>= \case
-            Left (ImportModuleError bundle) -> do
-                putStr (errorBundlePretty bundle)
-                exitFailure
+        liftIO (parseTestFile parsedModules Nothing path) >>= \case
             Left err -> do
-                putStr (showErrorComponent err)
-                exitFailure
+                throwError err
             Right cur -> do
                 return $ cur : res
 
-parseTestFile :: IORef [ ( FilePath, Module ) ] -> ModuleName -> FilePath -> IO (Either CustomTestError Module)
-parseTestFile parsedModules moduleName path = do
+parseTestFile :: IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module)
+parseTestFile parsedModules mbModuleName path = do
     absPath <- makeAbsolute path
     (lookup absPath <$> readIORef parsedModules) >>= \case
         Just found -> return $ Right found
@@ -207,10 +204,10 @@ parseTestFile parsedModules moduleName path = do
                     , testContext = SomeExpr (Undefined "void" :: Expr Void)
                     , testNextTypeVar = 0
                     , testTypeUnif = M.empty
-                    , testCurrentModuleName = moduleName
+                    , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName
                     , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do
                         let projectRoot = iterate takeDirectory absPath !! length current
-                        parseTestFile parsedModules mname $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
+                        parseTestFile parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath
                     }
             mbContent <- (Just <$> TL.readFile path) `catchIOError` \e ->
                 if isDoesNotExistError e then return Nothing else ioError e
@@ -222,4 +219,4 @@ parseTestFile parsedModules moduleName path = do
                         Right testModule -> do
                             modifyIORef parsedModules (( absPath, testModule ) : )
                             return $ Right testModule
-                Nothing -> return $ Left $ ModuleNotFound moduleName
+                Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName
diff --git a/src/TestMode.hs b/src/TestMode.hs
index 90ccdae..ab938e6 100644
--- a/src/TestMode.hs
+++ b/src/TestMode.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module TestMode (
     testMode,
 ) where
@@ -14,6 +16,9 @@ import Data.Text.IO qualified as T
 
 import System.IO.Error
 
+import Text.Megaparsec.Error
+import Text.Megaparsec.Pos
+
 import Output
 import Parser
 import Run
@@ -86,13 +91,31 @@ commands =
 cmdLoad :: Command
 cmdLoad = do
     [ path ] <- asks tmiParams
-    ( modules, allModules ) <- liftIO $ parseTestFiles [ T.unpack path ]
-    let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
-    modify $ \s -> s
-        { tmsModules = modules
-        , tmsGlobals = globalDefs
-        }
-    cmdOut "load-done"
+    liftIO (parseTestFiles [ T.unpack path ]) >>= \case
+        Right ( modules, allModules ) -> do
+            let globalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules
+            modify $ \s -> s
+                { tmsModules = modules
+                , tmsGlobals = globalDefs
+                }
+            cmdOut "load-done"
+
+        Left (ModuleNotFound moduleName) -> do
+            cmdOut $ "load-failed module-not-found" <> textModuleName moduleName
+        Left (FileNotFound notFoundPath) -> do
+            cmdOut $ "load-failed file-not-found " <> T.pack notFoundPath
+        Left (ImportModuleError bundle) -> do
+#if MIN_VERSION_megaparsec(9,7,0)
+            mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle
+#endif
+            cmdOut $ "load-failed parse-error"
+  where
+    showParseError _ SourcePos {..} _ = concat
+        [ "parse-error"
+        , " ", sourceName
+        , ":", show $ unPos sourceLine
+        , ":", show $ unPos sourceColumn
+        ]
 
 cmdRun :: Command
 cmdRun = do