persist modules in separate thread after delay

src/Compiler/Compile.hs

@@ -20,6 +20,7 @@ module Compiler.Compile( -- * Compile
                        , compileValueDef, compileTypeDef
                        , compileProgram
                        , gammaFind
+                       , codeGen
 
                          -- * Types
                        , Module(..)

src/LanguageServer/Handler/TextDocument.hs

@@ -9,11 +9,12 @@ module LanguageServer.Handler.TextDocument
     didSaveHandler,
     didCloseHandler,
     recompileFile,
+    persistModules,
   )
 where
 
 import Common.Error (checkError, Error)
-import Compiler.Compile (Terminal (..), compileModuleOrFile, Loaded (..), CompileTarget (..), compileFile)
+import Compiler.Compile (Terminal (..), compileModuleOrFile, Loaded (..), CompileTarget (..), compileFile, codeGen)
 import Control.Lens ((^.))
 import Control.Monad.Trans (liftIO)
 import qualified Data.Map as M
@@ -24,7 +25,7 @@ import Language.LSP.Server (Handlers, flushDiagnosticsBySource, publishDiagnosti
 import qualified Language.LSP.Protocol.Types as J
 import qualified Language.LSP.Protocol.Lens as J
 import LanguageServer.Conversions (toLspDiagnostics)
-import LanguageServer.Monad (LSM, modifyLoaded, getLoaded, putLoaded, getTerminal, getFlags, LSState (documentInfos), getLSState, modifyLSState)
+import LanguageServer.Monad (LSM, getLoaded, putLoaded, getTerminal, getFlags, LSState (documentInfos), getLSState, modifyLSState)
 import Language.LSP.VFS (virtualFileText, VFS(..), VirtualFile, file_version, virtualFileVersion)
 import qualified Data.Text.Encoding as T
 import Data.Functor ((<&>))
@@ -38,6 +39,9 @@ import qualified Control.Exception as Exc
 import Compiler.Options (Flags)
 import Common.File (getFileTime, FileTime, getFileTimeOrCurrent, getCurrentTime)
 import GHC.IO (unsafePerformIO)
+import Compiler.Module (Module(..))
+import Control.Monad (when)
+import Data.Time (addUTCTime, addLocalTime)
 
 didOpenHandler :: Handlers LSM
 didOpenHandler = notificationHandler J.SMethod_TextDocumentDidOpen $ \msg -> do
@@ -132,3 +136,38 @@ recompileFile compileTarget uri version force flags =
     Nothing -> return Nothing
   where
     normUri = J.toNormalizedUri uri
+
+persistModules :: LSM ()
+persistModules = do
+  mld <- getLoaded
+  case mld of
+    Just ld -> mapM_ persistModule (loadedModules ld)
+    Nothing -> return ()
+
+persistModule :: Module -> LSM ()
+persistModule m = do
+  let generate = do
+        -- trace "Generating" $ return ()
+        mld <- getLoaded
+        case mld of
+          Just loaded -> do
+            term <- getTerminal
+            flags <- getFlags
+            (loaded, file) <- liftIO $ codeGen term flags Object loaded{loadedModule = m}
+            putLoaded loaded
+            return ()
+          Nothing -> return ()
+  -- trace ("Module " ++ show (modName m)) $ 
+  case modOutputTime m of
+    Nothing -> do
+      -- trace "No output time" $ return ()
+      generate
+    -- If it has been 5 seconds since the last time the module was changed
+    --  and it isn't updated on disk persist again.
+    --  We don't do it all the time, because with virtual files and editor changes it would be too much
+    Just t -> do
+      ct <- liftIO getCurrentTime
+      when ((ct > addUTCTime 5 (modTime m)) && (modTime m > t)) $ do
+        -- trace ("Last output time" ++ show t) $ return ()
+        generate
+  return ()

src/LanguageServer/Monad.hs

@@ -16,7 +16,6 @@ module LanguageServer.Monad
     modifyLSState,
     getLoaded,
     putLoaded,
-    modifyLoaded,
     getLoadedModule,
     runLSM,
   )
@@ -31,7 +30,7 @@ import Language.LSP.Server (LanguageContextEnv, LspT, runLspT, sendNotification,
 import qualified Language.LSP.Protocol.Types as J
 import qualified Language.LSP.Protocol.Message as J
 
-import Compiler.Compile (Terminal (..), Loaded (loadedModules), Module (..))
+import Compiler.Compile (Terminal (..), Loaded (..), Module (..))
 import Lib.PPrint (Pretty(..), asString, writePrettyLn)
 import Control.Concurrent.Chan (readChan)
 import Type.Pretty (ppType, defaultEnv, Env (context, importsMap), ppScheme)
@@ -59,12 +58,12 @@ import Platform.Filetime (FileTime)
 
 -- The language server's state, e.g. holding loaded/compiled modules.
 data LSState = LSState {
-  lsLoaded :: Maybe Loaded, 
-  messages :: TChan (String, J.MessageType), 
-  flags:: Flags, 
-  terminal:: Terminal, 
-  pendingRequests :: TVar (Set.Set J.SomeLspId), 
-  cancelledRequests :: TVar (Set.Set J.SomeLspId), 
+  lsLoaded :: Maybe Loaded,
+  messages :: TChan (String, J.MessageType),
+  flags:: Flags,
+  terminal:: Terminal,
+  pendingRequests :: TVar (Set.Set J.SomeLspId),
+  cancelledRequests :: TVar (Set.Set J.SomeLspId),
   documentVersions :: TVar (M.Map J.Uri J.Int32),
   documentInfos :: M.Map FilePath (D.ByteString, FileTime, J.Int32) }
 
@@ -142,10 +141,6 @@ getLoadedModule uri = do
   lmaybe <- getLoaded
   return $ loadedModuleFromUri lmaybe uri
 
--- Updates the loaded state holding compiled modules
-modifyLoaded :: (Maybe Loaded -> Loaded) -> LSM ()
-modifyLoaded m = modifyLSState $ \s -> s {lsLoaded = case lsLoaded s of {Nothing -> Just (m Nothing); Just l' -> Just $ mergeLoaded (m $ Just l') l'}}
-
 -- Runs the language server's state monad.
 runLSM :: LSM a -> MVar LSState -> LanguageContextEnv () -> IO a
 runLSM lsm stVar cfg = runReaderT (runLspT cfg lsm) stVar
@@ -154,7 +149,8 @@ getTerminal :: LSM Terminal
 getTerminal = terminal <$> getLSState
 
 mergeLoaded :: Loaded -> Loaded -> Loaded
-mergeLoaded a b =
-  let aModules = loadedModules a
-      aModNames = map modName aModules in
-  a{loadedModules= aModules ++ filter (\m -> modName m `notElem` aModNames) (loadedModules b)}
+mergeLoaded newL oldL =
+  let compiledName = modName $ loadedModule newL
+      newModules = filter (\m -> modName m /= compiledName) (loadedModules newL)
+      newModNames = compiledName:map modName newModules in
+  newL{loadedModules=  loadedModule newL:newModules ++ filter (\m -> modName m `notElem` newModNames) (loadedModules oldL)}

src/LanguageServer/Run.hs

@@ -27,6 +27,7 @@ import Network.Simple.TCP
 import Network.Socket hiding (connect)
 import GHC.IO.IOMode (IOMode(ReadWriteMode))
 import GHC.Conc (atomically)
+import LanguageServer.Handler.TextDocument (persistModules)
 
 runLanguageServer :: Flags -> [FilePath] -> IO ()
 runLanguageServer flags files = do
@@ -44,7 +45,7 @@ runLanguageServer flags files = do
         $
         ServerDefinition
           { onConfigurationChange = const $ pure $ Right (),
-            doInitialize = \env _ -> forkIO (reactor rin) >> forkIO (messageHandler (messages initStateVal) env) >> pure (Right env),
+            doInitialize = \env _ -> forkIO (doPersist state env) >> forkIO (reactor rin) >> forkIO (messageHandler (messages initStateVal) env) >> pure (Right env),
             staticHandlers = \_caps -> lspHandlers rin,
             interpretHandler = \env -> Iso (\lsm -> runLSM lsm state env) liftIO,
             options =
@@ -87,3 +88,7 @@ reactor inp = do
     ReactorAction act <- atomically $ readTChan inp
     act
 
+doPersist state env =
+  forever $ do
+    threadDelay 1000000
+    runLSM persistModules state env