Fix concurrent cache invalidation bug, code cleanup (#138)

There are a few edge cases with the caching scheme we use that can
result in incorrect or missing language intelligence in certain cases.
Events which change a file _without_ triggering a change or save handler
in the lsp can result in a stale cache and consequently the
aforementioned issues.

This resolves most cases 
- We check file metadata to invalidate the hie cache if a newer hie file
is detected
- If a file is saved then we invalidate the file state cache (this
doesn't solve all stale file state cache issues but works for cases
which use a file watcher such as ghciwatch for a recompile).

expect_tests/HirTest.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
 
-module HirTest (tests) where
+module HirTest where
 
 import AST.Haskell qualified as H
 import Data.Text qualified as T
@@ -19,9 +19,10 @@ checkParse name source ex = test name ex $ do
 checkHir :: String -> T.Text -> Expect -> TestTree
 checkHir name source ex = test name ex $ do
   let tree = H.parse source
-  let (es, hir) = Hir.parseHaskell tree
+  let (_es, hir) = Hir.parseHaskell tree
   pure $ TL.toStrict $ Pretty.pShowNoColor hir
 
+src1 :: T.Text
 src1 =
   [trimming|
   module First where
@@ -30,6 +31,7 @@ src1 =
   import Second (First, C(.., first, type Another, (+++))) as Another
   |]
 
+src2 :: T.Text
 src2 =
   [trimming|
   module Second
@@ -43,6 +45,7 @@ src2 =
 
   |]
 
+src3 :: T.Text
 src3 =
   [trimming|
   module Third where
@@ -74,6 +77,7 @@ src3 =
     first :: a -> a
   |]
 
+tests :: TestTree
 tests =
   testGroup
     "HirTest"

expect_tests/Main.hs

@@ -1,6 +1,5 @@
 module Main where
 
-import Data.Text qualified as T
 import HirTest qualified
 import Test.Tasty
 import Test.Tasty.Expect

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

test/Main.hs

@@ -1,7 +1,5 @@
 module Main where
 
-import Data.Text qualified as T
-import Language.Haskell.Lexer qualified as Lexer
 import Spec qualified
 import Test.Hspec.Runner
 

test/StaticLS/HISpec.hs

@@ -8,7 +8,6 @@ import Data.Path qualified as Path
 import StaticLS.HI
 import StaticLS.HI.File
 import StaticLS.HIE.File
-import StaticLS.HIE.Position
 import StaticLS.HieView qualified as HieView
 import StaticLS.HieView.Name qualified as HieView.Name
 import StaticLS.HieView.Query qualified as HieView.Query

test/StaticLS/IDE/Diagnostics/ParseGHCSpec.hs

@@ -6,7 +6,6 @@ import Data.Path qualified as Path
 import NeatInterpolation
 import StaticLS.IDE.Diagnostics.ParseGHC
 import Test.Hspec
-import Text.RawString.QQ
 
 spec :: Spec
 spec = do

test/TestImport.hs

@@ -9,7 +9,6 @@ import Data.Rope qualified as Rope
 import Data.Text.IO qualified as T
 import StaticLS.Logger
 import StaticLS.Monad
-import StaticLS.Semantic qualified as Semantic
 import StaticLS.StaticEnv as StaticEnv
 import StaticLS.StaticEnv.Options as Options
 import System.Directory (doesFileExist, listDirectory)
@@ -27,7 +26,7 @@ runStaticLsSimple action = do
 updateTestFileState :: AbsPath -> StaticLsM ()
 updateTestFileState path = do
   contentsText <- liftIO $ T.readFile (Path.toFilePath path)
-  let contents = Rope.fromText contentsText
+  let _contents = Rope.fromText contentsText
   -- _ <- Semantic.updateSemantic path contents
   pure ()