Improve error report when when parsing the Schema.sql fails

Fixes #1498
digitallyinduced · Sep 15, 2022 · 4a589c9 · 4a589c9
1 parent 7c793e3
commit 4a589c9
Show file tree

Hide file tree

Showing 4 changed files with 34 additions and 7 deletions.
diff --git a/IHP/IDE/StatusServer.hs b/IHP/IDE/StatusServer.hs
@@ -251,6 +251,7 @@ renderErrorView standardOutput errorOutput isCompiling = [hsx|
                     (filePath, rest) = ByteString.breakSubstring ": " line
                     openEditor = "http://localhost:" <> tshow toolServerPort <> (pathTo OpenEditorAction) <> "?path=" <> cs plainFilePath <> "&line=" <> cs fileLine <> "&col=" <> cs fileCol
                     (plainFilePath, fileLine, fileCol) = case ByteString.split ':' filePath of
+                            [path, line, col, rest] -> (path, line, col) -- This happens for parser errors from the IHP.SchemaCompiler.compile function
                             [path, line, col] -> (path, line, col)
                             [path, line] -> (path, line, "0")
                             otherwise -> (filePath, "0", "0")

diff --git a/IHP/IDE/Types.hs b/IHP/IDE/Types.hs
@@ -131,12 +131,14 @@ data AppState = AppState
     , fileWatcherState :: !FileWatcherState
     , toolServerState :: !ToolServerState
     , databaseNeedsMigration :: !(IORef Bool)
+    , lastSchemaCompilerError :: !(IORef (Maybe SomeException))
     } deriving (Show)
 
 emptyAppState :: IO AppState
 emptyAppState = do
     clients <- newIORef mempty
     databaseNeedsMigration <- newIORef False
+    lastSchemaCompilerError <- newIORef Nothing
     pure AppState
         { postgresState = PostgresNotStarted
         , appGHCIState = AppGHCINotStarted
@@ -145,6 +147,7 @@ emptyAppState = do
         , fileWatcherState = FileWatcherNotStarted
         , toolServerState = ToolServerNotStarted
         , databaseNeedsMigration
+        , lastSchemaCompilerError
         }
 
 data Context = Context

diff --git a/IHP/SchemaCompiler.hs b/IHP/SchemaCompiler.hs
@@ -15,12 +15,17 @@ import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner
 import IHP.IDE.SchemaDesigner.Types
 import Control.Monad.Fail
 import qualified IHP.IDE.SchemaDesigner.Compiler as SqlCompiler
+import qualified Control.Exception as Exception
+
+data CompileException = CompileException ByteString deriving (Show)
+instance Exception CompileException where
+    displayException (CompileException message) = cs message
 
 compile :: IO ()
 compile = do
     let options = fullCompileOptions
     SchemaDesigner.parseSchemaSql >>= \case
-        Left parserError -> fail (cs parserError)
+        Left parserError -> Exception.throwIO (CompileException parserError)
         Right statements -> do
             -- let validationErrors = validate database
             -- unless (null validationErrors) (error $ "Schema.hs contains errors: " <> cs (unsafeHead validationErrors))

diff --git a/exe/IHP/IDE/DevServer.hs b/exe/IHP/IDE/DevServer.hs
@@ -95,8 +95,9 @@ handleAction state@(AppState { appGHCIState, statusServerState, postgresState })
         AppGHCILoading { .. } -> do
             let appGHCIState' = AppGHCIModulesLoaded { .. }
 
+            hasSchemaCompilerError <- isJust <$> readIORef state.lastSchemaCompilerError
             case postgresState of
-                PostgresStarted {} -> do
+                PostgresStarted {} | not hasSchemaCompilerError -> do
                     stopStatusServer statusServerState
                     startLoadedApp appGHCIState
 
@@ -155,6 +156,11 @@ handleAction state@(AppState { liveReloadNotificationServerState, appGHCIState,
 
     clearStatusServer statusServerState
 
+    lastSchemaCompilerError <- readIORef state.lastSchemaCompilerError
+    case lastSchemaCompilerError of
+        Just exception -> dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) })
+        Nothing -> pure ()
+
     let appGHCIState' =
             case appGHCIState of
                 AppGHCILoading { .. } -> AppGHCILoading { .. }
@@ -163,9 +169,7 @@ handleAction state@(AppState { liveReloadNotificationServerState, appGHCIState,
     pure state { appGHCIState = appGHCIState' }
 
 handleAction state SchemaChanged = do
-    async do
-        SchemaCompiler.compile `catch` (\(exception :: SomeException) -> do Log.error (tshow exception); dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ tshow exception) }))
-
+    async tryCompileSchema
     async (updateDatabaseIsOutdated state)
     pure state
 
@@ -312,7 +316,7 @@ startAppGHCI = do
 
 
     -- Compile Schema before loading the app
-    SchemaCompiler.compile `catch` (\(e :: SomeException) -> Log.error (tshow e))
+    tryCompileSchema
 
     forEach loadAppCommands (sendGhciCommand process)
 
@@ -353,4 +357,18 @@ updateDatabaseIsOutdated state = ((do
         ) `catch` (\(exception :: SomeException) -> do
             Log.error (tshow exception)
             dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ tshow exception) })
-        ))
+        ))
+
+tryCompileSchema :: (?context :: Context) => IO ()
+tryCompileSchema =
+    (do
+        SchemaCompiler.compile
+        state <- readIORef ?context.appStateRef
+        writeIORef state.lastSchemaCompilerError Nothing
+    ) `catch` (\(exception :: SomeException) -> do
+            Log.error (tshow exception)
+            dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) })
+
+            state <- readIORef ?context.appStateRef
+            writeIORef state.lastSchemaCompilerError (Just exception)
+        )