Use Queue for ghci output

digitallyinduced · Oct 1, 2022 · 19a1ebe · 19a1ebe
1 parent 8a5927f
commit 19a1ebe
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 24 deletions.
diff --git a/IHP/IDE/StatusServer.hs b/IHP/IDE/StatusServer.hs
@@ -1,4 +1,4 @@
-module IHP.IDE.StatusServer (startStatusServer, stopStatusServer, clearStatusServer, notifyBrowserOnApplicationOutput, continueStatusServer) where
+module IHP.IDE.StatusServer (startStatusServer, stopStatusServer, clearStatusServer, notifyBrowserOnApplicationOutput, continueStatusServer, consumeGhciOutput) where
 
 import IHP.ViewPrelude hiding (catch)
 import qualified Network.Wai as Wai
@@ -17,6 +17,7 @@ import IHP.IDE.ToolServer.Types
 import IHP.IDE.ToolServer.Routes ()
 import qualified Network.URI as URI
 import qualified Control.Exception as Exception
+import qualified Control.Concurrent.Chan.Unagi as Queue
 
 -- async (notifyOutput (standardOutput, errorOutput) clients)
 
@@ -41,10 +42,7 @@ continueStatusServer statusServerState@(StatusServerPaused { .. }) = do
                 (app clients statusServerState)
                 (statusServerApp (standardOutput, errorOutput))
 
-        let port = ?context
-                |> get #portConfig
-                |> get #appPort
-                |> fromIntegral
+        let port = ?context.portConfig.appPort |> fromIntegral
 
         server <- async $ Warp.run port warpApp
 
@@ -76,6 +74,14 @@ clearStatusServer StatusServerPaused { .. } = do
     writeIORef errorOutput []
 clearStatusServer StatusServerNotStarted = pure ()
 
+consumeGhciOutput :: (?context :: Context) => IO ()
+consumeGhciOutput = forever do
+    outputLine <- Queue.readChan ?context.ghciOutChan
+    appState <- readIORef ?context.appStateRef
+
+    notifyBrowserOnApplicationOutput appState.statusServerState outputLine
+
+
 notifyBrowserOnApplicationOutput :: (?context :: Context) => StatusServerState -> OutputLine -> IO ()
 notifyBrowserOnApplicationOutput StatusServerStarted { serverRef, clients, standardOutput, errorOutput } line = do
     let shouldIgnoreLine = (line == ErrorOutput "Warning: -debug, -threaded and -ticky are ignored by GHCi")

diff --git a/IHP/IDE/Types.hs b/IHP/IDE/Types.hs
@@ -12,6 +12,7 @@ import Data.UUID
 import qualified IHP.Log.Types as Log
 import qualified IHP.Log as Log
 import qualified Data.ByteString.Builder as ByteString
+import qualified Control.Concurrent.Chan.Unagi as Queue
 
 data ManagedProcess = ManagedProcess
     { inputHandle :: !Handle
@@ -43,7 +44,6 @@ data Action =
     | UpdateAppGHCIState AppGHCIState
     | AppModulesLoaded { success :: !Bool }
     | AppStarted
-    | ReceiveAppOutput { line :: !OutputLine }
     | AssetChanged
     | HaskellFileChanged
     | SchemaChanged
@@ -156,6 +156,8 @@ data Context = Context
     , appStateRef :: !(IORef AppState)
     , isDebugMode :: !Bool
     , logger :: !Log.Logger
+    , ghciInChan :: !(Queue.InChan OutputLine) -- ^ Output of the app ghci is written here
+    , ghciOutChan :: !(Queue.OutChan OutputLine) -- ^ Output of the app ghci is consumed here
     }
 
 dispatch :: (?context :: Context) => Action -> IO ()

diff --git a/exe/IHP/IDE/DevServer.hs b/exe/IHP/IDE/DevServer.hs
@@ -29,6 +29,7 @@ import Data.Default (def, Default (..))
 import qualified IHP.IDE.CodeGen.MigrationGenerator as MigrationGenerator
 import Main.Utf8 (withUtf8)
 import qualified IHP.FrameworkConfig as FrameworkConfig
+import qualified Control.Concurrent.Chan.Unagi as Queue
 
 main :: IO ()
 main = withUtf8 do
@@ -43,7 +44,8 @@ main = withUtf8 do
     isDebugMode <- maybe False (\value -> value == "1") <$> Env.lookupEnv "DEBUG"
 
     logger <- Log.newLogger def
-    let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger }
+    (ghciInChan, ghciOutChan) <- Queue.newChan
+    let ?context = Context { actionVar, portConfig, appStateRef, isDebugMode, logger, ghciInChan, ghciOutChan }
 
     -- Print IHP Version when in debug mode
     when isDebugMode (Log.debug ("IHP Version: " <> Version.ihpVersion))
@@ -56,14 +58,16 @@ main = withUtf8 do
     installHandler sigINT (Catch catchHandler) Nothing
 
     start
-    async Telemetry.reportTelemetry
-    forever do
-        appState <- readIORef appStateRef
-        when isDebugMode (Log.debug $ " ===> " <> (tshow appState))
-        action <- takeMVar actionVar
-        when isDebugMode (Log.debug $ tshow action)
-        nextAppState <- handleAction appState action
-        writeIORef appStateRef nextAppState
+
+    withAsync consumeGhciOutput \_ -> do
+        async Telemetry.reportTelemetry
+        forever do
+            appState <- readIORef appStateRef
+            when isDebugMode (Log.debug $ " ===> " <> (tshow appState))
+            action <- takeMVar actionVar
+            when isDebugMode (Log.debug $ tshow action)
+            nextAppState <- handleAction appState action
+            writeIORef appStateRef nextAppState
 
 
 handleAction :: (?context :: Context) => AppState -> Action -> IO AppState
@@ -87,9 +91,6 @@ handleAction state@(AppState { statusServerState = StatusServerNotStarted }) (Up
 handleAction state@(AppState { statusServerState = StatusServerStarted { } }) (UpdateStatusServerState StatusServerNotStarted) = pure state { statusServerState = StatusServerNotStarted }
 handleAction state@(AppState { statusServerState = StatusServerPaused { } }) (UpdateStatusServerState statusServerState) = pure state { statusServerState = StatusServerNotStarted }
 handleAction state (UpdateFileWatcherState fileWatcherState) = pure state { fileWatcherState }
-handleAction state@(AppState { statusServerState }) ReceiveAppOutput { line } = do
-    notifyBrowserOnApplicationOutput statusServerState line
-    pure state
 handleAction state@(AppState { appGHCIState, statusServerState, postgresState }) (AppModulesLoaded { success = True }) = do
     case appGHCIState of
         AppGHCILoading { .. } -> do
@@ -158,7 +159,7 @@ handleAction state@(AppState { liveReloadNotificationServerState, appGHCIState,
 
     lastSchemaCompilerError <- readIORef state.lastSchemaCompilerError
     case lastSchemaCompilerError of
-        Just exception -> dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) })
+        Just exception -> receiveAppOutput (ErrorOutput (cs $ displayException exception))
         Nothing -> pure ()
 
     let appGHCIState' =
@@ -304,15 +305,15 @@ startAppGHCI = do
                             else if "modules loaded." `isInfixOf` line
                                 then do
                                     dispatch AppModulesLoaded { success = True }
-                                else dispatch ReceiveAppOutput { line = StandardOutput line }
+                                else receiveAppOutput (StandardOutput line)
 
     async $ forever $ ByteString.hGetLine errorHandle >>= \line -> do
         unless isDebugMode (Log.info line)
         if "cannot find object file for module" `isInfixOf` line
             then do
                 forEach loadAppCommands (sendGhciCommand process)
-                dispatch ReceiveAppOutput { line = ErrorOutput "Linking Issue: Reloading Main" }
-            else dispatch ReceiveAppOutput { line = ErrorOutput line }
+                receiveAppOutput (ErrorOutput "Linking Issue: Reloading Main")
+            else receiveAppOutput (ErrorOutput line)
 
 
     -- Compile Schema before loading the app
@@ -322,6 +323,8 @@ startAppGHCI = do
 
     dispatch (UpdateAppGHCIState (AppGHCILoading { .. }))
 
+receiveAppOutput :: (?context :: Context) => OutputLine -> IO ()
+receiveAppOutput line = Queue.writeChan ?context.ghciInChan line
 
 startLoadedApp :: (?context :: Context) => AppGHCIState -> IO ()
 startLoadedApp (AppGHCIModulesLoaded { .. }) = do
@@ -356,7 +359,7 @@ updateDatabaseIsOutdated state = ((do
             writeIORef databaseNeedsMigrationRef databaseNeedsMigration
         ) `catch` (\(exception :: SomeException) -> do
             Log.error (tshow exception)
-            dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ tshow exception) })
+            receiveAppOutput (ErrorOutput (cs $ tshow exception))
         ))
 
 tryCompileSchema :: (?context :: Context) => IO ()
@@ -367,7 +370,7 @@ tryCompileSchema =
         writeIORef state.lastSchemaCompilerError Nothing
     ) `catch` (\(exception :: SomeException) -> do
             Log.error (tshow exception)
-            dispatch (ReceiveAppOutput { line = ErrorOutput (cs $ displayException exception) })
+            receiveAppOutput (ErrorOutput (cs $ displayException exception))
 
             state <- readIORef ?context.appStateRef
             writeIORef state.lastSchemaCompilerError (Just exception)