diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 229576bf8..dc7a706c4 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -20,6 +20,7 @@ module Compiler.Compile( -- * Compile , compileValueDef, compileTypeDef , compileProgram , gammaFind + , codeGen -- * Types , Module(..) diff --git a/src/LanguageServer/Handler/TextDocument.hs b/src/LanguageServer/Handler/TextDocument.hs index 2bf37cbed..b72e69941 100644 --- a/src/LanguageServer/Handler/TextDocument.hs +++ b/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,40 @@ 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 + return () + -- TODO: This works, but needs to check that the dependencies are persisted first. + -- 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 () \ No newline at end of file diff --git a/src/LanguageServer/Monad.hs b/src/LanguageServer/Monad.hs index b42ffca9d..c54403100 100644 --- a/src/LanguageServer/Monad.hs +++ b/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)} diff --git a/src/LanguageServer/Run.hs b/src/LanguageServer/Run.hs index 4942c5cf8..c7e857b88 100644 --- a/src/LanguageServer/Run.hs +++ b/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 @@ -87,3 +88,7 @@ reactor inp = do ReactorAction act <- atomically $ readTChan inp act +doPersist state env = + forever $ do + threadDelay 1000000 + runLSM persistModules state env