Fix concurrent cache invalidation bug, code cleanup

package.yaml

@@ -39,6 +39,7 @@ dependencies:
   - sqlite-simple >= 0.4.18 && < 0.5
   - template-haskell >= 2.19.0 && < 2.23
   - text >= 2.0.1 && < 2.2
+  - time >= 1.0 && < 2.0
   - bytestring >=0.10 && <0.13
   - transformers >= 0.5.6.2 && < 0.7
   - unliftio-core >= 0.2.1 && < 0.3

src/Data/ConcurrentCache.hs

@@ -7,15 +7,19 @@
 module Data.ConcurrentCache (
   ConcurrentCache,
   new,
+  Data.ConcurrentCache.lookup,
   remove,
   insert,
 ) where
 
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
 import Data.Hashable (Hashable)
+import StaticLS.Maybe
 import UnliftIO (onException)
 import UnliftIO.Exception (mask)
 import UnliftIO.IORef (IORef)
@@ -37,6 +41,13 @@ remove k cache = do
   IORef.atomicModifyIORef' cache.map \m -> do
     (HashMap.delete k m, ())
 
+lookup :: (MonadIO m, Hashable k) => k -> ConcurrentCache k v -> m (Maybe v)
+lookup k cache = do
+  runMaybeT $ do
+    cacheMap <- lift $ IORef.readIORef cache.map
+    (m :: MVar (Maybe v)) <- toAlt $ HashMap.lookup k cacheMap
+    MaybeT $ MVar.readMVar m
+
 insert :: (Hashable k, MonadUnliftIO m) => k -> m v -> ConcurrentCache k v -> m v
 insert k act cache = mask \restore -> do
   var <- MVar.newEmptyMVar

src/StaticLS/FilePath.hs

@@ -1,14 +1,23 @@
-module StaticLS.FilePath (modToFilePath, subRootExtensionFilepath) where
+module StaticLS.FilePath (modToFilePath, subRootExtensionFilepath, getFileModifiedAt) where
 
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
 import Data.List qualified as List
 import Data.Path (AbsPath, Path (..), RelPath)
 import Data.Path qualified as Path
+import Data.Time
 import GHC.Plugins qualified as GHC
 import StaticLS.SrcFiles
 import System.Directory qualified as Dir
 import System.FilePath ((-<.>))
+import System.IO.Error
+
+getFileModifiedAt :: (MonadIO m) => AbsPath -> MaybeT m UTCTime
+getFileModifiedAt path = do
+  MaybeT $
+    liftIO $
+      (Just <$> Dir.getModificationTime (Path.toFilePath path))
+        `catchIOError` const (pure Nothing)
 
 modToFilePath :: GHC.ModuleName -> String -> RelPath
 modToFilePath modName ext =

src/StaticLS/Handlers.hs

@@ -160,8 +160,9 @@ handleDidChange = LSP.notificationHandler LSP.SMethod_TextDocumentDidChange $ \m
 handleDidSave :: Handlers (LspT c StaticLsM)
 handleDidSave = LSP.notificationHandler LSP.SMethod_TextDocumentDidSave $ \message -> do
   let params = message._params
-  let _uri = params._textDocument._uri
-  pure ()
+  let uri = params._textDocument._uri
+  -- Useful to invalidate for file watchers if a branch checkout invalidates the file state cache
+  updateFileStateForUri uri
 
 handleDidClose :: Handlers (LspT c StaticLsM)
 handleDidClose = LSP.notificationHandler LSP.SMethod_TextDocumentDidClose $ \_ -> do

src/StaticLS/HieView/Query.hs

@@ -105,7 +105,7 @@ fileEvidenceBinds file =
       )
       file
  where
-  evSourceNames (EvInstBind {cls}) = Nothing
+  evSourceNames (EvInstBind {}) = Nothing
   evSourceNames (EvLetBind (EvBindDeps {deps})) = Just deps
   evSourceNames EvOther = Nothing
 

src/StaticLS/HieView/Type.hs

@@ -1,7 +1,7 @@
 module StaticLS.HieView.Type (
   Type,
-  TypeArray,
-  FlatType,
+  TypeArray (..),
+  FlatType (..),
   TypeIndex (..),
   fromGHCHieType,
   fromGHCHieTypeFlat,

src/StaticLS/Hir/Make.hs

@@ -22,9 +22,9 @@ mkModuleText parts =
     , text = T.intercalate "." (NE.toList parts)
     }
 
-mkModuleName :: NonEmpty Text -> ModuleName
-mkModuleName parts =
-  ModuleName
-    { mod = mkModuleText parts
-    -- , node = AST.defaultNode
-    }
+-- mkModuleName :: NonEmpty Text -> ModuleName
+-- mkModuleName parts =
+--  ModuleName
+--    { mod = mkModuleText parts
+--    , node = AST.defaultNode
+--    }

src/StaticLS/IDE/CodeActions/AddTypeSig.hs

@@ -32,7 +32,7 @@ type BindName = Haskell.PrefixId :+ Haskell.Variable :+ Nil
 
 -- For now, it only works with top level declarations
 getDeclarationNameAtPos :: Haskell.Haskell -> Pos -> LineCol -> AST.Err (Maybe BindName)
-getDeclarationNameAtPos haskell pos lineCol = do
+getDeclarationNameAtPos haskell pos _lineCol = do
   let node = AST.getDeepestContaining @AddTypeContext (Range.point pos) haskell.dynNode
   case node of
     Just bind

src/StaticLS/IDE/CodeActions/AutoExport.hs

@@ -43,5 +43,5 @@ getDeclarationsAtPoint range decls =
 codeAction :: CodeActionContext -> StaticLsM [Assist]
 codeAction cx = do
   hir <- getHir cx.path
-  let decls = getDeclarationsAtPoint (Range.point cx.pos) hir.decls
+  let _decls = getDeclarationsAtPoint (Range.point cx.pos) hir.decls
   pure []

src/StaticLS/IDE/CodeActions/AutoImport.hs

@@ -104,7 +104,7 @@ createAutoImportCodeActions path mQualifier importMod =
         ]
 
 codeAction :: CodeActionContext -> StaticLsM [Assist]
-codeAction CodeActionContext {path, lineCol, pos} = do
+codeAction CodeActionContext {path, pos} = do
   hir <- getHir path
   modulesToImport <- getModulesToImport path pos
 
@@ -135,7 +135,7 @@ data ImportInsertPoint
   | AfterImportInsertPoint !Pos
 
 getImportsInsertPoint :: Rope -> Haskell.Haskell -> AST.Err ImportInsertPoint
-getImportsInsertPoint rope hs = do
+getImportsInsertPoint _rope hs = do
   imports <- Tree.getImports hs
   header <- Tree.getHeader hs
   let headerPos =

src/StaticLS/IDE/Definition.hs

@@ -191,7 +191,7 @@ findDefString qual = do
 hieDbFindDefString :: (HasStaticEnv m, MonadIO m) => Text -> Maybe Hir.ModuleName -> MaybeT m [HieDb.DefRow]
 hieDbFindDefString name mod = do
   -- we need to resolve the mod first
-  let modText = (.mod.text) <$> mod
+  let _modText = (.mod.text) <$> mod
   runHieDbMaybeT
     ( \hieDb ->
         SQL.queryNamed

src/StaticLS/IDE/Monad.hs

@@ -40,13 +40,15 @@ where
 
 import AST.Haskell qualified as Haskell
 import AST.Traversal qualified as AST
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 import Data.ConcurrentCache (ConcurrentCache)
 import Data.ConcurrentCache qualified as ConcurrentCache
 import Data.HashMap.Strict qualified as HashMap
 import Data.LineCol (LineCol)
+import Data.Maybe
 import Data.Path (AbsPath, toFilePath)
 import Data.Path qualified as Path
 import Data.Pos (Pos)
@@ -57,6 +59,8 @@ import Data.Rope qualified as Rope
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
+import Data.Time
+import StaticLS.FilePath
 import StaticLS.HIE.File qualified as HIE.File
 import StaticLS.HieView qualified as HieView
 import StaticLS.Hir qualified as Hir
@@ -193,11 +197,13 @@ data CachedHieFile = CachedHieFile
   , file :: HIE.File.HieFile
   , fileView :: HieView.File
   , hieTokenMap :: RangeMap PositionDiff.Token
+  , modifiedAt :: UTCTime
   }
 
 getHieCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile
 getHieCacheResult path = do
   file <- HIE.File.getHieFileFromPath path
+  modifiedAt <- getFileModifiedAt path
   let fileView = HieView.viewHieFile file
   let hieSource = fileView.source
   let tokens = PositionDiff.lex $ T.unpack hieSource
@@ -208,12 +214,26 @@ getHieCacheResult path = do
           , file = file
           , fileView
           , hieTokenMap = PositionDiff.tokensToRangeMap tokens
+          , modifiedAt = modifiedAt
           }
   pure hieFile
 
+invalidateStaleHieCacheFile :: (MonadIde m, MonadIO m) => AbsPath -> m ()
+invalidateStaleHieCacheFile path = do
+  fmap (fromMaybe ()) $ runMaybeT $ do
+    env <- getIdeEnv
+    latestHieModifiedAt <- getFileModifiedAt path
+    cachedHieFile <- MaybeT $ ConcurrentCache.lookup path env.hieCache
+    case cachedHieFile of
+      Just hieFile -> do
+        when (hieFile.modifiedAt < latestHieModifiedAt) $
+          ConcurrentCache.remove path env.hieCache
+      Nothing -> pure ()
+
 getHieCache :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile
 getHieCache path = do
   env <- getIdeEnv
+  _ <- lift $ invalidateStaleHieCacheFile path
   MaybeT $
     ConcurrentCache.insert
       path
@@ -228,13 +248,15 @@ forceCachedHieFile
     , file = !file
     , fileView = !fileView
     , hieTokenMap = hieTokenMap
+    , modifiedAt = !modifiedAt
     } =
     CachedHieFile
       { hieSource
       , hieSourceRope
       , file
       , fileView
       , hieTokenMap
+      , modifiedAt
       }
 
 getHieCacheWithMap :: (MonadIO m, HasStaticEnv m) => AbsPath -> HieCacheMap -> MaybeT m CachedHieFile
@@ -244,6 +266,7 @@ getHieCacheWithMap path hieCacheMap =
       MaybeT $ pure $ Just hieFile
     Nothing -> do
       file <- HIE.File.getHieFileFromPath path
+      modifiedAt <- getFileModifiedAt path
       let fileView = HieView.viewHieFile file
       let hieSource = fileView.source
       let tokens = PositionDiff.lex $ T.unpack hieSource
@@ -254,6 +277,7 @@ getHieCacheWithMap path hieCacheMap =
               , file = file
               , fileView
               , hieTokenMap = PositionDiff.tokensToRangeMap tokens
+              , modifiedAt = modifiedAt
               }
       pure hieFile
 

static-ls.cabal

@@ -86,6 +86,7 @@ library
     , text >=2.0.1 && <2.2
     , text-range
     , text-rope ==0.2
+    , time >=1.0 && <2.0
     , transformers >=0.5.6.2 && <0.7
     , tree-sitter-ast
     , tree-sitter-haskell
@@ -234,6 +235,7 @@ executable print-hie
     , text >=2.0.1 && <2.2
     , text-range
     , text-rope ==0.2
+    , time >=1.0 && <2.0
     , transformers >=0.5.6.2 && <0.7
     , tree-sitter-ast
     , tree-sitter-haskell
@@ -302,6 +304,7 @@ executable static-ls
     , text >=2.0.1 && <2.2
     , text-range
     , text-rope ==0.2
+    , time >=1.0 && <2.0
     , transformers >=0.5.6.2 && <0.7
     , tree-sitter-ast
     , tree-sitter-haskell
@@ -387,6 +390,7 @@ test-suite expect_tests
     , text >=2.0.1 && <2.2
     , text-range
     , text-rope ==0.2
+    , time >=1.0 && <2.0
     , transformers >=0.5.6.2 && <0.7
     , tree-sitter-ast
     , tree-sitter-haskell
@@ -458,6 +462,7 @@ test-suite static-ls-test
     , text >=2.0.1 && <2.2
     , text-range
     , text-rope ==0.2
+    , time >=1.0 && <2.0
     , transformers >=0.5.6.2 && <0.7
     , tree-sitter-ast
     , tree-sitter-haskell