Remove one level of tracking files of interest and open VRs (#1650)

Previously we tracked this both at the Shake level and at the LSP
level which doesn’t make any sense. This PR removes the outer LSP
layer.

compiler/haskell-ide-core/src/Development/IDE/State/Service.hs

@@ -13,7 +13,7 @@ module Development.IDE.State.Service(
     getServiceEnv,
     IdeState, initialise, shutdown,
     runAction, runActions,
-    setFilesOfInterest,
+    setFilesOfInterest, modifyFilesOfInterest,
     writeProfile,
     getDiagnostics, unsafeClearDiagnostics,
     logDebug, logSeriousError
@@ -26,6 +26,8 @@ import           Development.IDE.State.FileStore
 import qualified Development.IDE.Logger as Logger
 import           Data.Set                                 (Set)
 import qualified Data.Set                                 as Set
+import qualified Data.Text as T
+import Data.Tuple.Extra
 import           Development.IDE.Functions.GHCError
 import Development.IDE.Types.Diagnostics (NormalizedFilePath)
 import           Development.Shake                        hiding (Diagnostic, Env, newCache)
@@ -109,12 +111,13 @@ runActions x = join . shakeRun x
 
 -- | Set the files-of-interest which will be built and kept-up-to-date.
 setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
-setFilesOfInterest state files = do
-    Env{..} <- getIdeGlobalState state
-    -- update vars synchronously
-    modifyVar_ envOfInterestVar $ const $ return files
+setFilesOfInterest state files = modifyFilesOfInterest state (const files)
 
-    -- run shake to update results regarding the files of interest
+modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
+modifyFilesOfInterest state f = do
+    Env{..} <- getIdeGlobalState state
+    files <- modifyVar envOfInterestVar $ pure . dupe . f
+    logDebug state $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
     void $ shakeRun state []
 
 getServiceEnv :: Action Env

daml-foundations/daml-ghc/daml-compiler/src/DA/Service/Daml/Compiler/Impl/Handle.hs

@@ -8,9 +8,11 @@ module DA.Service.Daml.Compiler.Impl.Handle
     IdeState
   , getIdeState
   , withIdeState
-  , setFilesOfInterest
+  , CompilerService.setFilesOfInterest
+  , CompilerService.modifyFilesOfInterest
   , onFileModified
-  , setOpenVirtualResources
+  , CompilerService.setOpenVirtualResources
+  , CompilerService.modifyOpenVirtualResources
   , getAssociatedVirtualResources
   , gotoDefinition
   , atPoint
@@ -124,23 +126,6 @@ toIdeLogger h = IdeLogger.Handle {
 
 ------------------------------------------------------------------------------
 
--- | Update the files-of-interest, which we recieve asynchronous notifications for.
-setFilesOfInterest
-    :: IdeState
-    -> [NormalizedFilePath]
-    -> IO ()
-setFilesOfInterest service files = do
-    CompilerService.logDebug service $ "Setting files of interest to: " <> T.pack (show files)
-    CompilerService.setFilesOfInterest service (S.fromList files)
-
-setOpenVirtualResources
-    :: IdeState
-    -> [VirtualResource]
-    -> IO ()
-setOpenVirtualResources service vrs = do
-    CompilerService.logDebug service $ "Setting vrs of interest to: " <> T.pack (show vrs)
-    CompilerService.setOpenVirtualResources service (S.fromList vrs)
-
 getAssociatedVirtualResources
   :: IdeState
   -> NormalizedFilePath
@@ -195,7 +180,7 @@ compileFile service fp = do
     -- We need to mark the file we are compiling as a file of interest.
     -- Otherwise all diagnostics produced during compilation will be garbage
     -- collected afterwards.
-    liftIO $ setFilesOfInterest service [fp]
+    liftIO $ CompilerService.setFilesOfInterest service (S.singleton fp)
     liftIO $ CompilerService.logDebug service $ "Compiling: " <> T.pack (fromNormalizedFilePath fp)
     res <- liftIO $ CompilerService.runAction service (CompilerService.getDalf fp)
     case res of

daml-foundations/daml-ghc/ide/src/Development/IDE/State/API.hs

@@ -12,7 +12,9 @@ module Development.IDE.State.API
     , getDefinition
     , shutdown
     , setFilesOfInterest
+    , modifyFilesOfInterest
     , setOpenVirtualResources
+    , modifyOpenVirtualResources
     , setBufferModified
     , runAction
     , runActions

daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs

@@ -1,5 +1,6 @@
 -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE OverloadedStrings #-}
 module Development.IDE.State.Service.Daml(
     Env(..),
     getServiceEnv,
@@ -7,7 +8,7 @@ module Development.IDE.State.Service.Daml(
     getDamlServiceEnv,
     IdeState, initialise, shutdown,
     runAction, runActions,
-    setFilesOfInterest, setOpenVirtualResources,
+    setFilesOfInterest, modifyFilesOfInterest, setOpenVirtualResources, modifyOpenVirtualResources,
     writeProfile,
     getDiagnostics, unsafeClearDiagnostics,
     logDebug, logSeriousError
@@ -19,6 +20,8 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Tuple.Extra
 import Development.Shake
 
 import qualified Development.IDE.Logger as Logger
@@ -70,9 +73,13 @@ getDamlServiceEnv :: Action DamlEnv
 getDamlServiceEnv = getIdeGlobalAction
 
 setOpenVirtualResources :: IdeState -> Set VirtualResource -> IO ()
-setOpenVirtualResources state resources = do
+setOpenVirtualResources state resources = modifyOpenVirtualResources state (const resources)
+
+modifyOpenVirtualResources :: IdeState -> (Set VirtualResource -> Set VirtualResource) -> IO ()
+modifyOpenVirtualResources state f = do
     DamlEnv{..} <- getIdeGlobalState state
-    modifyVar_ envOpenVirtualResources $ const $ return resources
+    vrs <- modifyVar envOpenVirtualResources $ pure . dupe . f
+    logDebug state $ "Set vrs of interest to: " <> T.pack (show $ Set.toList vrs)
     void $ shakeRun state []
 
 initialise

daml-foundations/daml-ghc/language-server/src/DA/Service/Daml/LanguageServer.hs

@@ -24,14 +24,12 @@ import qualified Development.IDE.Logger as Logger
 import DAML.Project.Consts
 
 import qualified Data.Aeson                                as Aeson
-import           Data.IORef                                (IORef, atomicModifyIORef', newIORef)
 import qualified Data.Rope.UTF16 as Rope
 import qualified Data.Set                                  as S
 import qualified Data.Text as T
 
 import Development.IDE.State.FileStore
 import qualified Development.IDE.Types.Diagnostics as Compiler
-import           Development.IDE.Types.LSP as Compiler
 
 import qualified Network.URI                               as URI
 
@@ -48,16 +46,9 @@ textShow = T.pack . show
 -- Types
 ------------------------------------------------------------------------
 
--- | Language server state
-data State = State
-    { sOpenDocuments        :: !(S.Set Compiler.NormalizedFilePath)
-    , sOpenVirtualResources :: !(S.Set Compiler.VirtualResource)
-    }
-
 -- | Implementation handle
 data IHandle p t = IHandle
-    { ihState     :: !(IORef State)
-    , ihLoggerH   :: !Logger.Handle
+    { ihLoggerH   :: !Logger.Handle
     , ihCompilerH :: !Compiler.IdeState
     }
 
@@ -71,7 +62,7 @@ handleRequest
     -> (ErrorCode -> ResponseMessage ())
     -> ServerRequest
     -> IO FromServerMessage
-handleRequest (IHandle _stateRef loggerH compilerH) makeResponse makeErrorResponse = \case
+handleRequest (IHandle loggerH compilerH) makeResponse makeErrorResponse = \case
     Shutdown -> do
       Logger.logInfo loggerH "Shutdown request received, terminating."
       System.Exit.exitSuccess
@@ -88,7 +79,7 @@ handleRequest (IHandle _stateRef loggerH compilerH) makeResponse makeErrorRespon
 
 
 handleNotification :: LspFuncs () -> IHandle () LF.Package -> ServerNotification -> IO ()
-handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case
+handleNotification lspFuncs (IHandle loggerH compilerH) = \case
 
     DidOpenTextDocument (DidOpenTextDocumentParams item) -> do
         case URI.parseURI $ T.unpack $ getUri $ _uri (item :: TextDocumentItem) of
@@ -145,59 +136,27 @@ handleNotification lspFuncs (IHandle stateRef loggerH compilerH) = \case
     -- Internally it should be done via the IO oracle. See PROD-2808.
     handleDidOpenFile (TextDocumentItem uri _ _ contents) = do
         Just filePath <- pure $ Compiler.toNormalizedFilePath <$> Compiler.uriToFilePath' uri
-        documents <- atomicModifyIORef' stateRef $
-          \state -> let documents = S.insert filePath $ sOpenDocuments state
-                    in ( state { sOpenDocuments = documents }
-                       , documents
-                       )
-
-
-
-        -- Update the file contents
         Compiler.onFileModified compilerH filePath (Just contents)
-
-        -- Update the list of open files
-        Compiler.setFilesOfInterest compilerH (S.toList documents)
-
+        Compiler.modifyFilesOfInterest compilerH (S.insert filePath)
         Logger.logInfo loggerH $ "Opened text document: " <> textShow filePath
 
     handleDidOpenVirtualResource uri = do
          case Compiler.uriToVirtualResource uri of
-           Nothing -> do
-               Logger.logWarning loggerH $ "Failed to parse virtual resource URI: " <> textShow uri
-               pure ()
+           Nothing -> Logger.logWarning loggerH $ "Failed to parse virtual resource URI: " <> textShow uri
            Just vr -> do
                Logger.logInfo loggerH $ "Opened virtual resource: " <> textShow vr
-               resources <- atomicModifyIORef' stateRef $
-                 \state -> let resources = S.insert vr $ sOpenVirtualResources state
-                           in ( state { sOpenVirtualResources = resources }
-                              , resources
-                              )
-               Compiler.setOpenVirtualResources compilerH $ S.toList resources
+               Compiler.modifyOpenVirtualResources compilerH (S.insert vr)
 
     handleDidCloseFile filePath = do
          Logger.logInfo loggerH $ "Closed text document: " <> textShow (Compiler.fromNormalizedFilePath filePath)
-         documents <- atomicModifyIORef' stateRef $
-           \state -> let documents = S.delete filePath $ sOpenDocuments state
-                     in ( state { sOpenDocuments = documents }
-                        , documents
-                        )
-         Compiler.setFilesOfInterest compilerH (S.toList documents)
          Compiler.onFileModified compilerH filePath Nothing
+         Compiler.modifyFilesOfInterest compilerH (S.delete filePath)
 
     handleDidCloseVirtualResource uri = do
         Logger.logInfo loggerH $ "Closed virtual resource: " <> textShow uri
         case Compiler.uriToVirtualResource uri of
-           Nothing -> do
-               Logger.logWarning loggerH "Failed to parse virtual resource URI!"
-               pure ()
-           Just vr -> do
-               resources <- atomicModifyIORef' stateRef $
-                 \state -> let resources = S.delete vr $ sOpenVirtualResources state
-                           in (state { sOpenVirtualResources = resources }
-                              , resources
-                              )
-               Compiler.setOpenVirtualResources compilerH $ S.toList resources
+           Nothing -> Logger.logWarning loggerH "Failed to parse virtual resource URI!"
+           Just vr -> Compiler.modifyOpenVirtualResources compilerH (S.delete vr)
 
 ------------------------------------------------------------------------
 -- Server execution
@@ -210,12 +169,10 @@ runLanguageServer
 runLanguageServer loggerH getIdeState = do
     sdkVersion <- liftIO (getSdkVersion `catchIO` const (pure "Unknown (not started via the assistant)"))
     liftIO $ Logger.logInfo loggerH (T.pack $ "SDK version: " <> sdkVersion)
-    state     <- liftIO $ newIORef $ State S.empty S.empty
     let getHandlers lspFuncs = do
             compilerH <- getIdeState (sendFunc lspFuncs) (makeLSPVFSHandle lspFuncs)
             let ihandle = IHandle
-                    { ihState = state
-                    , ihLoggerH = loggerH
+                    { ihLoggerH = loggerH
                     , ihCompilerH = compilerH
                     }
             pure $ Handlers (handleRequest ihandle) (handleNotification lspFuncs ihandle)

daml-foundations/daml-tools/da-hs-daml-cli/DA/Cli/Damlc/Test.hs

@@ -14,6 +14,7 @@ import qualified DA.Pretty
 import DA.Cli.Damlc.Base
 import Data.Maybe
 import Data.List.Extra
+import qualified Data.Set as S
 import Data.Tuple.Extra
 import Control.Monad.Extra
 import           DA.Service.Daml.Compiler.Impl.Handle as Compiler
@@ -54,7 +55,7 @@ execTest inFiles color mbJUnitOutput cliOptions = do
 testRun :: IdeState -> [NormalizedFilePath] -> LF.Version -> UseColor -> Maybe FilePath -> IO ()
 testRun h inFiles lfVersion color mbJUnitOutput  = do
     -- make sure none of the files disappear
-    liftIO $ Compiler.setFilesOfInterest h inFiles
+    liftIO $ Compiler.setFilesOfInterest h (S.fromList inFiles)
 
     -- take the transitive closure of all imports and run on all of them
     -- If some dependencies can't be resolved we'll get a Diagnostic out anyway, so don't worry