From d742f8862901d178110a275e80d3de0f4c2c1585 Mon Sep 17 00:00:00 2001 From: Shan Ali Date: Tue, 29 Jul 2025 13:23:36 -0400 Subject: [PATCH 1/5] fix: removed old complicated ConcurrentCache wrapper --- src/Data/ConcurrentCache.hs | 80 -------------------------------- test/Data/ConcurrentCacheSpec.hs | 54 --------------------- 2 files changed, 134 deletions(-) delete mode 100644 src/Data/ConcurrentCache.hs delete mode 100644 test/Data/ConcurrentCacheSpec.hs diff --git a/src/Data/ConcurrentCache.hs b/src/Data/ConcurrentCache.hs deleted file mode 100644 index ada3f71a..00000000 --- a/src/Data/ConcurrentCache.hs +++ /dev/null @@ -1,80 +0,0 @@ --- This module provides a concurrent cache --- The cache has the property that if --- 'insert k v1' and 'insert k v2' are called concurrently, --- then only one of the computations v1 or v2 will run, and the one that runs will be cached --- so that subsequence inserts will return the cached value. - -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) -import UnliftIO.IORef qualified as IORef -import UnliftIO.MVar (MVar) -import UnliftIO.MVar qualified as MVar - -data ConcurrentCache k v = ConcurrentCache - { map :: IORef (HashMap k (MVar (Maybe v))) - } - -new :: (MonadIO m) => m (ConcurrentCache k v) -new = do - map <- IORef.newIORef HashMap.empty - pure ConcurrentCache {map} - -remove :: (Hashable k, MonadIO m) => k -> ConcurrentCache k v -> m () -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 - res <- IORef.atomicModifyIORef' cache.map \m -> do - case HashMap.lookup k m of - Just var -> (m, Right var) - Nothing -> (HashMap.insert k var m, Left var) - case res of - Left var -> do - -- we inserted a new var - v <- - -- the computation might throw an exception - (restore act) `onException` do - -- we need to put Nothing so that threads don't block indefinitely on this var - MVar.putMVar var Nothing - -- remove the key so that we can insert new data - remove k cache - MVar.putMVar var (Just v) - pure v - Right var -> do - -- we got an existing var, either the computation is still running or it completed. - -- Wait for the computation to complete. - res <- restore (MVar.readMVar var) - case res of - Just v -> pure v - Nothing -> do - -- the computation failed - -- loop until the thread running the computation removes the key - -- don't remove the key here because we only want one thread removing the key - restore (insert k act cache) diff --git a/test/Data/ConcurrentCacheSpec.hs b/test/Data/ConcurrentCacheSpec.hs deleted file mode 100644 index f53afb52..00000000 --- a/test/Data/ConcurrentCacheSpec.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Data.ConcurrentCacheSpec (spec) where - -import Control.Exception (Exception) -import Control.Exception.Base (throw) -import Data.ConcurrentCache qualified as ConcurrentCache -import Data.IORef qualified as IORef -import Data.Typeable (Typeable) -import Test.Hspec - -yieldList :: [a] -> IO (IO (Maybe a)) -yieldList xs = do - ref <- IORef.newIORef xs - pure do - res <- - IORef.atomicModifyIORef' ref \xs -> - case xs of - [] -> ([], Nothing) - x : xs -> (xs, Just x) - case res of - Nothing -> pure Nothing - Just !x -> pure $ Just x - -data Exn = Exn - deriving (Show, Eq, Typeable) - -instance Exception Exn - -spec :: Spec -spec = do - it "multiple" do - cache <- ConcurrentCache.new - act <- yieldList [1 :: Int .. 10000000] - res1 <- ConcurrentCache.insert 'a' act cache - res1 `shouldBe` Just 1 - res3 <- ConcurrentCache.insert 'b' act cache - res3 `shouldBe` Just 2 - res2 <- ConcurrentCache.insert 'a' act cache - res2 `shouldBe` Just 1 - pure @IO () - it "exception" do - cache <- ConcurrentCache.new - act <- yieldList [throw Exn, 1 :: Int, throw Exn, 2 :: Int] - ConcurrentCache.insert 'a' act cache `shouldThrow` (== Exn) - res1 <- ConcurrentCache.insert 'a' act cache - res1 `shouldBe` Just 1 - res2 <- ConcurrentCache.insert 'a' act cache - res2 `shouldBe` Just 1 - ConcurrentCache.insert 'b' act cache `shouldThrow` (== Exn) - res3 <- ConcurrentCache.insert 'b' act cache - res3 `shouldBe` Just 2 - res4 <- ConcurrentCache.insert 'b' act cache - res4 `shouldBe` Just 2 - pure @IO () - pure () From 1706e09b71e50c8f3614865af12d37aa7ab08a6f Mon Sep 17 00:00:00 2001 From: Shan Ali Date: Tue, 29 Jul 2025 13:26:33 -0400 Subject: [PATCH 2/5] feat: updated concurrent cache to no longer store all caches --- src/StaticLS/IDE/Monad.hs | 294 +++++++++++++++----------------------- static-ls.cabal | 2 - 2 files changed, 119 insertions(+), 177 deletions(-) diff --git a/src/StaticLS/IDE/Monad.hs b/src/StaticLS/IDE/Monad.hs index 74d5c158..c465c784 100644 --- a/src/StaticLS/IDE/Monad.hs +++ b/src/StaticLS/IDE/Monad.hs @@ -1,51 +1,11 @@ module StaticLS.IDE.Monad where --- ( --- MonadIde, --- IdeEnv (..), --- HasIdeEnv (..), --- getHaskell, --- getSourceRope, --- getSource, --- getHieToSrcDiffMap, --- getSrcToHieDiffMap, --- getHieSourceRope, --- getHieSource, --- getHieFile, --- getHieCacheImpl, --- CachedHieFile (..), --- MonadHieFile (..), --- SetHieCache (..), --- HasHieCache (..), --- DiffCache (..), --- HasDiffCacheRef (..), --- GetDiffCache (..), --- TouchCachesParallel (..), --- touchCachesParallelImpl, --- getDiffCacheImpl, --- getHieToSource, --- getSourceToHie, --- removeDiffCache, --- removePathImpl, --- removeHieFromSourcePath, --- onNewSource, --- getHieTokenMap, --- getTokenMap, --- getHir, --- getHieView, --- getThSplice, --- getFileStateResult, --- ) - 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 @@ -62,8 +22,8 @@ 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 +import StaticLS.HieView.View qualified as HieView +import StaticLS.Hir.Types qualified as Hir import StaticLS.Logger import StaticLS.PositionDiff qualified as PositionDiff import StaticLS.Semantic @@ -72,19 +32,24 @@ import StaticLS.StaticEnv import System.Directory (doesFileExist) import UnliftIO (MonadUnliftIO) import UnliftIO.Exception qualified as Exception +import UnliftIO.MVar (MVar) +import UnliftIO.MVar qualified as MVar + +data CurrentFileCache = CurrentFileCache + { path :: AbsPath + , fileState :: MVar (Maybe FileState) + , hieCache :: MVar (Maybe CachedHieFile) + , diffCache :: MVar (Maybe DiffCache) + } data IdeEnv = IdeEnv - { fileStateCache :: ConcurrentCache AbsPath FileState - , hieCache :: ConcurrentCache AbsPath (Maybe CachedHieFile) - , diffCache :: ConcurrentCache AbsPath (Maybe DiffCache) + { currentFile :: MVar (Maybe CurrentFileCache) } newIdeEnv :: IO IdeEnv newIdeEnv = do - fileStateCache <- ConcurrentCache.new - hieCache <- ConcurrentCache.new - diffCache <- ConcurrentCache.new - pure $ IdeEnv {fileStateCache, hieCache, diffCache} + currentFile <- MVar.newMVar Nothing + pure $ IdeEnv {currentFile} class HasIdeEnv m where getIdeEnv :: m IdeEnv @@ -103,63 +68,82 @@ type MonadIde m = removePath :: (MonadIde m) => AbsPath -> m () removePath path = do env <- getIdeEnv - ConcurrentCache.remove path env.fileStateCache - --- setFileState :: (Monad m, HasSemantic m, SetSemantic m) => AbsPath -> FileState -> m () --- setFileState path fileState = do --- sema <- getSemantic --- setSemantic $ --- sema --- { fileStates = HashMap.insert path fileState sema.fileStates --- } --- pure () - --- updateSemantic :: (Monad m, HasSemantic m, SetSemantic m) => AbsPath -> Rope.Rope -> m () --- updateSemantic path contentsRope = do --- let contentsText = Rope.toText contentsRope --- let fileState = mkFileState contentsText contentsRope --- setFileState path fileState + maybeCache <- liftIO $ MVar.readMVar env.currentFile + case maybeCache of + Just cache | cache.path == path -> do + liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure Nothing) + _ -> pure () + +-- when switching to a new file, create a cache +switchToFile :: (MonadIde m) => AbsPath -> m () +switchToFile path = do + env <- getIdeEnv + fileStateMVar <- liftIO $ MVar.newMVar Nothing + hieCacheMVar <- liftIO $ MVar.newMVar Nothing + diffCacheMVar <- liftIO $ MVar.newMVar Nothing + + let newCache = CurrentFileCache + { path = path + , fileState = fileStateMVar + , hieCache = hieCacheMVar + , diffCache = diffCacheMVar + } + + liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure (Just newCache)) + +-- get the current file cache +getCurrentFileCache :: (MonadIde m) => AbsPath -> MaybeT m CurrentFileCache +getCurrentFileCache path = do + env <- getIdeEnv + maybeCache <- liftIO $ MVar.readMVar env.currentFile + case maybeCache of + Just cache | cache.path == path -> pure cache + _ -> MaybeT $ pure Nothing getFileState :: (MonadIde m) => AbsPath -> m FileState getFileState path = do - env <- getIdeEnv - ConcurrentCache.insert - path - ( do - res <- getFileStateResult path - case res of - Just fileState -> pure fileState - Nothing -> pure Semantic.emptyFileState - ) - env.fileStateCache - -getHaskell :: (MonadIde m, MonadIO m) => AbsPath -> m Haskell.Haskell + maybeCache <- runMaybeT $ getCurrentFileCache path + case maybeCache of + Nothing -> do + switchToFile path + getFileState path + Just cache -> do + maybeCached <- liftIO $ MVar.readMVar cache.fileState + case maybeCached of + Just fs -> pure fs + Nothing -> do + res <- getFileStateResult path + let fileState = fromMaybe Semantic.emptyFileState res + liftIO $ MVar.modifyMVar_ cache.fileState (\_ -> pure (Just fileState)) + pure fileState + +getHaskell :: (MonadIde m) => AbsPath -> m Haskell.Haskell getHaskell path = do fileState <- getFileState path pure fileState.tree -getHir :: (MonadIde m, MonadIO m) => AbsPath -> m Hir.Program -getHir hir = do - fileState <- getFileState hir +getHir :: (MonadIde m) => AbsPath -> m Hir.Program +getHir path = do + fileState <- getFileState path pure fileState.hir -getSourceRope :: (MonadIde m, MonadIO m) => AbsPath -> m Rope +getSourceRope :: (MonadIde m) => AbsPath -> m Rope getSourceRope path = do - mFileState <- getFileState path - pure mFileState.contentsRope + fileState <- getFileState path + pure fileState.contentsRope -getSource :: (MonadIde m, MonadIO m) => AbsPath -> m Text +getSource :: (MonadIde m) => AbsPath -> m Text getSource path = do - mFileState <- getFileState path - pure mFileState.contentsText + fileState <- getFileState path + pure fileState.contentsText -getHieToSrcDiffMap :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m PositionDiff.DiffMap +getHieToSrcDiffMap :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap getHieToSrcDiffMap path = do hieSource <- getHieSource path source <- lift $ getSource path pure $ PositionDiff.getDiffMap hieSource source -getSrcToHieDiffMap :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m PositionDiff.DiffMap +getSrcToHieDiffMap :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap getSrcToHieDiffMap path = do hieSource <- getHieSource path source <- lift $ getSource path @@ -167,8 +151,6 @@ getSrcToHieDiffMap path = do getFileStateResult :: (HasLogger m, MonadIO m) => AbsPath -> m (Maybe Semantic.FileState) getFileStateResult path = do - -- use the double liftIO here to avoid the MonadUnliftIO constraint - -- we really just want unliftio to handle not catching async exceptions doesExist <- liftIO $ doesFileExist (Path.toFilePath path) if doesExist then do @@ -190,7 +172,6 @@ getFileStateResult path = do type HieCacheMap = HashMap.HashMap AbsPath CachedHieFile --- keep these fields lazy data CachedHieFile = CachedHieFile { hieSource :: Text , hieSourceRope :: Rope @@ -200,7 +181,7 @@ data CachedHieFile = CachedHieFile , modifiedAt :: UTCTime } -getHieCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile +getHieCacheResult :: (MonadIde m) => AbsPath -> MaybeT m CachedHieFile getHieCacheResult path = do file <- HIE.File.getHieFileFromPath path modifiedAt <- getFileModifiedAt path @@ -218,70 +199,18 @@ getHieCacheResult path = do } 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 :: (MonadIde m) => AbsPath -> MaybeT m CachedHieFile getHieCache path = do - env <- getIdeEnv - _ <- lift $ invalidateStaleHieCacheFile path - MaybeT $ - ConcurrentCache.insert - path - (runMaybeT $ getHieCacheResult path) - env.hieCache - -forceCachedHieFile :: CachedHieFile -> CachedHieFile -forceCachedHieFile - CachedHieFile - { hieSource = !hieSource - , hieSourceRope = !hieSourceRope - , file = !file - , fileView = !fileView - , hieTokenMap = hieTokenMap - , modifiedAt = !modifiedAt - } = - CachedHieFile - { hieSource - , hieSourceRope - , file - , fileView - , hieTokenMap - , modifiedAt - } - -getHieCacheWithMap :: (MonadIO m, HasStaticEnv m, HasLogger m) => AbsPath -> HieCacheMap -> MaybeT m CachedHieFile -getHieCacheWithMap path hieCacheMap = - case HashMap.lookup path hieCacheMap of - Just hieFile -> do - MaybeT $ pure $ Just hieFile + cache <- getCurrentFileCache path + maybeCached <- liftIO $ MVar.readMVar cache.hieCache + case maybeCached of + Just hie -> pure hie 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 - let hieFile = - CachedHieFile - { hieSource - , hieSourceRope = Rope.fromText hieSource - , file = file - , fileView - , hieTokenMap = PositionDiff.tokensToRangeMap tokens - , modifiedAt = modifiedAt - } + hieFile <- getHieCacheResult path + liftIO $ MVar.modifyMVar_ cache.hieCache (\_ -> pure (Just hieFile)) pure hieFile -getTokenMap :: (MonadIde m, MonadIO m) => AbsPath -> m (RangeMap PositionDiff.Token) +getTokenMap :: (MonadIde m) => AbsPath -> m (RangeMap PositionDiff.Token) getTokenMap path = do fileState <- getFileState path pure fileState.tokenMap @@ -313,15 +242,15 @@ getHieSourceRope path = do getSourceToHie :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap getSourceToHie path = do - hieCache <- getDiffCache path - pure $ hieCache.sourceToHie + diffCache <- getDiffCache path + pure $ diffCache.sourceToHie getHieToSource :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap getHieToSource path = do - hieCache <- getDiffCache path - pure $ hieCache.hieToSource + diffCache <- getDiffCache path + pure $ diffCache.hieToSource -lineColToPos :: (MonadIde m, MonadIO m) => AbsPath -> LineCol -> m Pos +lineColToPos :: (MonadIde m) => AbsPath -> LineCol -> m Pos lineColToPos path lineCol = do sourceRope <- getSourceRope path pure $ Rope.lineColToPos sourceRope lineCol @@ -332,16 +261,18 @@ data DiffCache = DiffCache } deriving (Show, Eq) -getDiffCache :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m DiffCache +getDiffCache :: (MonadIde m) => AbsPath -> MaybeT m DiffCache getDiffCache path = do - env <- getIdeEnv - MaybeT $ - ConcurrentCache.insert - path - (runMaybeT $ getDiffCacheResult path) - env.diffCache + cache <- getCurrentFileCache path + maybeCached <- liftIO $ MVar.readMVar cache.diffCache + case maybeCached of + Just diff -> pure diff + Nothing -> do + diffCache <- getDiffCacheResult path + liftIO $ MVar.modifyMVar_ cache.diffCache (\_ -> pure (Just diffCache)) + pure diffCache -getDiffCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m DiffCache +getDiffCacheResult :: (MonadIde m) => AbsPath -> MaybeT m DiffCache getDiffCacheResult path = do hieToSource <- getHieToSrcDiffMap path sourceToHie <- getSrcToHieDiffMap path @@ -352,23 +283,36 @@ getDiffCacheResult path = do } pure diffCache --- this function is not thread safe onNewSource :: (MonadIde m) => AbsPath -> Rope.Rope -> m () onNewSource path source = do env <- getIdeEnv - ConcurrentCache.remove path env.fileStateCache - _ <- ConcurrentCache.insert path (pure (Semantic.mkFileState (Rope.toText source) source)) env.fileStateCache - ConcurrentCache.remove path env.diffCache + fileStateMVar <- liftIO $ MVar.newMVar Nothing + hieCacheMVar <- liftIO $ MVar.newMVar Nothing + diffCacheMVar <- liftIO $ MVar.newMVar Nothing + + let newCache = CurrentFileCache + { path = path + , fileState = fileStateMVar + , hieCache = hieCacheMVar + , diffCache = diffCacheMVar + } + + -- swap in the new cache + liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure (Just newCache)) + let fileState = Semantic.mkFileState (Rope.toText source) source + liftIO $ MVar.modifyMVar_ fileStateMVar (\_ -> pure (Just fileState)) pure () removeHieFromSourcePath :: (MonadIde m) => AbsPath -> m () removeHieFromSourcePath path = do - env <- getIdeEnv - ConcurrentCache.remove path env.hieCache - ConcurrentCache.remove path env.diffCache - pure () + maybeCache <- runMaybeT $ getCurrentFileCache path + case maybeCache of + Just cache -> do + liftIO $ MVar.modifyMVar_ cache.hieCache (\_ -> pure Nothing) + liftIO $ MVar.modifyMVar_ cache.diffCache (\_ -> pure Nothing) + Nothing -> pure () -throwIfInThSplice :: (HasCallStack, MonadIde m, MonadIO m) => String -> AbsPath -> Pos -> m () +throwIfInThSplice :: (HasCallStack, MonadIde m) => String -> AbsPath -> Pos -> m () throwIfInThSplice msg path pos = do haskell <- getHaskell path let range = (Range.point pos) @@ -376,4 +320,4 @@ throwIfInThSplice msg path pos = do case splice of Nothing -> pure () Just _ -> do - Exception.throwString $ "Cannot perform action in splice: " ++ msg + Exception.throwString $ "Cannot perform action in splice: " ++ msg \ No newline at end of file diff --git a/static-ls.cabal b/static-ls.cabal index 5d47cdd1..df130cc2 100644 --- a/static-ls.cabal +++ b/static-ls.cabal @@ -100,7 +100,6 @@ library ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables exposed-modules: Data.Change - Data.ConcurrentCache Data.Diff Data.Edit Data.ListUtils @@ -484,7 +483,6 @@ test-suite static-ls-test ghc-options: -fwrite-ide-info -hiedir .hiefiles -fdefer-type-errors -fno-defer-typed-holes -Werror=deferred-type-errors -Werror=deferred-out-of-scope-variables main-is: Main.hs other-modules: - Data.ConcurrentCacheSpec Data.RopeSpec Semantic.HirSpec Spec From a3b5357652736cd794a883cef022dcaaef9ff163 Mon Sep 17 00:00:00 2001 From: Shan Ali Date: Tue, 5 Aug 2025 14:08:05 -0500 Subject: [PATCH 3/5] fix: update to use LRU --- src/StaticLS/IDE/Monad.hs | 202 +++++++++++++++++++------------------- static-ls.cabal | 1 + 2 files changed, 100 insertions(+), 103 deletions(-) diff --git a/src/StaticLS/IDE/Monad.hs b/src/StaticLS/IDE/Monad.hs index c465c784..96bed9fb 100644 --- a/src/StaticLS/IDE/Monad.hs +++ b/src/StaticLS/IDE/Monad.hs @@ -3,9 +3,12 @@ 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.Cache.LRU.IO.Internal (AtomicLRU) +import Data.Cache.LRU.IO.Internal qualified as AtomicLRU import Data.HashMap.Strict qualified as HashMap import Data.LineCol (LineCol) import Data.Maybe @@ -22,8 +25,8 @@ import Data.Text.IO qualified as T import Data.Time import StaticLS.FilePath import StaticLS.HIE.File qualified as HIE.File -import StaticLS.HieView.View qualified as HieView -import StaticLS.Hir.Types qualified as Hir +import StaticLS.HieView qualified as HieView +import StaticLS.Hir qualified as Hir import StaticLS.Logger import StaticLS.PositionDiff qualified as PositionDiff import StaticLS.Semantic @@ -32,24 +35,25 @@ import StaticLS.StaticEnv import System.Directory (doesFileExist) import UnliftIO (MonadUnliftIO) import UnliftIO.Exception qualified as Exception -import UnliftIO.MVar (MVar) -import UnliftIO.MVar qualified as MVar - -data CurrentFileCache = CurrentFileCache - { path :: AbsPath - , fileState :: MVar (Maybe FileState) - , hieCache :: MVar (Maybe CachedHieFile) - , diffCache :: MVar (Maybe DiffCache) + +data FileCacheEntry = FileCacheEntry + { fileState :: Maybe FileState + , hieCache :: Maybe CachedHieFile + , diffCache :: Maybe DiffCache } +-- empty +emptyEntry :: FileCacheEntry +emptyEntry = FileCacheEntry Nothing Nothing Nothing + data IdeEnv = IdeEnv - { currentFile :: MVar (Maybe CurrentFileCache) + { cache :: AtomicLRU AbsPath FileCacheEntry } newIdeEnv :: IO IdeEnv newIdeEnv = do - currentFile <- MVar.newMVar Nothing - pure $ IdeEnv {currentFile} + cache <- AtomicLRU.newAtomicLRU (Just 10) + pure $ IdeEnv {cache} class HasIdeEnv m where getIdeEnv :: m IdeEnv @@ -68,82 +72,49 @@ type MonadIde m = removePath :: (MonadIde m) => AbsPath -> m () removePath path = do env <- getIdeEnv - maybeCache <- liftIO $ MVar.readMVar env.currentFile - case maybeCache of - Just cache | cache.path == path -> do - liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure Nothing) - _ -> pure () - --- when switching to a new file, create a cache -switchToFile :: (MonadIde m) => AbsPath -> m () -switchToFile path = do - env <- getIdeEnv - fileStateMVar <- liftIO $ MVar.newMVar Nothing - hieCacheMVar <- liftIO $ MVar.newMVar Nothing - diffCacheMVar <- liftIO $ MVar.newMVar Nothing - - let newCache = CurrentFileCache - { path = path - , fileState = fileStateMVar - , hieCache = hieCacheMVar - , diffCache = diffCacheMVar - } - - liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure (Just newCache)) - --- get the current file cache -getCurrentFileCache :: (MonadIde m) => AbsPath -> MaybeT m CurrentFileCache -getCurrentFileCache path = do - env <- getIdeEnv - maybeCache <- liftIO $ MVar.readMVar env.currentFile - case maybeCache of - Just cache | cache.path == path -> pure cache - _ -> MaybeT $ pure Nothing + _ <- liftIO $ AtomicLRU.delete path env.cache + pure () getFileState :: (MonadIde m) => AbsPath -> m FileState getFileState path = do - maybeCache <- runMaybeT $ getCurrentFileCache path - case maybeCache of + env <- getIdeEnv + entry <- liftIO $ AtomicLRU.lookup path env.cache + case entry >>= (.fileState) of + Just fs -> pure fs Nothing -> do - switchToFile path - getFileState path - Just cache -> do - maybeCached <- liftIO $ MVar.readMVar cache.fileState - case maybeCached of - Just fs -> pure fs - Nothing -> do - res <- getFileStateResult path - let fileState = fromMaybe Semantic.emptyFileState res - liftIO $ MVar.modifyMVar_ cache.fileState (\_ -> pure (Just fileState)) - pure fileState - -getHaskell :: (MonadIde m) => AbsPath -> m Haskell.Haskell + res <- getFileStateResult path + let fs = fromMaybe Semantic.emptyFileState res + let currentEntry = fromMaybe emptyEntry entry + liftIO $ AtomicLRU.insert path (currentEntry { fileState = Just fs }) env.cache + pure fs + +getHaskell :: (MonadIde m, MonadIO m) => AbsPath -> m Haskell.Haskell getHaskell path = do fileState <- getFileState path pure fileState.tree -getHir :: (MonadIde m) => AbsPath -> m Hir.Program +getHir :: (MonadIde m, MonadIO m) => AbsPath -> m Hir.Program getHir path = do fileState <- getFileState path pure fileState.hir -getSourceRope :: (MonadIde m) => AbsPath -> m Rope +getSourceRope :: (MonadIde m, MonadIO m) => AbsPath -> m Rope getSourceRope path = do fileState <- getFileState path pure fileState.contentsRope -getSource :: (MonadIde m) => AbsPath -> m Text +getSource :: (MonadIde m, MonadIO m) => AbsPath -> m Text getSource path = do fileState <- getFileState path pure fileState.contentsText -getHieToSrcDiffMap :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap +getHieToSrcDiffMap :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m PositionDiff.DiffMap getHieToSrcDiffMap path = do hieSource <- getHieSource path source <- lift $ getSource path pure $ PositionDiff.getDiffMap hieSource source -getSrcToHieDiffMap :: (MonadIde m) => AbsPath -> MaybeT m PositionDiff.DiffMap +getSrcToHieDiffMap :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m PositionDiff.DiffMap getSrcToHieDiffMap path = do hieSource <- getHieSource path source <- lift $ getSource path @@ -181,7 +152,7 @@ data CachedHieFile = CachedHieFile , modifiedAt :: UTCTime } -getHieCacheResult :: (MonadIde m) => AbsPath -> MaybeT m CachedHieFile +getHieCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile getHieCacheResult path = do file <- HIE.File.getHieFileFromPath path modifiedAt <- getFileModifiedAt path @@ -199,18 +170,32 @@ getHieCacheResult path = do } pure hieFile -getHieCache :: (MonadIde m) => AbsPath -> MaybeT m CachedHieFile +invalidateStaleHieCacheFile :: (MonadIde m, MonadIO m) => AbsPath -> m () +invalidateStaleHieCacheFile path = do + fmap (fromMaybe ()) $ runMaybeT $ do + env <- getIdeEnv + latestHieModifiedAt <- getFileModifiedAt path + entry <- MaybeT $ liftIO $ AtomicLRU.lookup path env.cache + case entry.hieCache of + Just hieFile -> do + when (hieFile.modifiedAt < latestHieModifiedAt) $ do + liftIO $ AtomicLRU.insert path (entry { hieCache = Nothing, diffCache = Nothing }) env.cache + Nothing -> pure () + +getHieCache :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile getHieCache path = do - cache <- getCurrentFileCache path - maybeCached <- liftIO $ MVar.readMVar cache.hieCache - case maybeCached of + env <- getIdeEnv + _ <- lift $ invalidateStaleHieCacheFile path + entry <- liftIO $ AtomicLRU.lookup path env.cache + case entry >>= (.hieCache) of Just hie -> pure hie Nothing -> do - hieFile <- getHieCacheResult path - liftIO $ MVar.modifyMVar_ cache.hieCache (\_ -> pure (Just hieFile)) - pure hieFile + hie <- getHieCacheResult path + let currentEntry = fromMaybe emptyEntry entry + liftIO $ AtomicLRU.insert path (currentEntry { hieCache = Just hie }) env.cache + pure hie -getTokenMap :: (MonadIde m) => AbsPath -> m (RangeMap PositionDiff.Token) +getTokenMap :: (MonadIde m, MonadIO m) => AbsPath -> m (RangeMap PositionDiff.Token) getTokenMap path = do fileState <- getFileState path pure fileState.tokenMap @@ -250,7 +235,7 @@ getHieToSource path = do diffCache <- getDiffCache path pure $ diffCache.hieToSource -lineColToPos :: (MonadIde m) => AbsPath -> LineCol -> m Pos +lineColToPos :: (MonadIde m, MonadIO m) => AbsPath -> LineCol -> m Pos lineColToPos path lineCol = do sourceRope <- getSourceRope path pure $ Rope.lineColToPos sourceRope lineCol @@ -261,18 +246,19 @@ data DiffCache = DiffCache } deriving (Show, Eq) -getDiffCache :: (MonadIde m) => AbsPath -> MaybeT m DiffCache +getDiffCache :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m DiffCache getDiffCache path = do - cache <- getCurrentFileCache path - maybeCached <- liftIO $ MVar.readMVar cache.diffCache - case maybeCached of + env <- getIdeEnv + entry <- liftIO $ AtomicLRU.lookup path env.cache + case entry >>= (.diffCache) of Just diff -> pure diff Nothing -> do - diffCache <- getDiffCacheResult path - liftIO $ MVar.modifyMVar_ cache.diffCache (\_ -> pure (Just diffCache)) - pure diffCache + diff <- getDiffCacheResult path + let currentEntry = fromMaybe emptyEntry entry + liftIO $ AtomicLRU.insert path (currentEntry { diffCache = Just diff }) env.cache + pure diff -getDiffCacheResult :: (MonadIde m) => AbsPath -> MaybeT m DiffCache +getDiffCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m DiffCache getDiffCacheResult path = do hieToSource <- getHieToSrcDiffMap path sourceToHie <- getSrcToHieDiffMap path @@ -286,33 +272,43 @@ getDiffCacheResult path = do onNewSource :: (MonadIde m) => AbsPath -> Rope.Rope -> m () onNewSource path source = do env <- getIdeEnv - fileStateMVar <- liftIO $ MVar.newMVar Nothing - hieCacheMVar <- liftIO $ MVar.newMVar Nothing - diffCacheMVar <- liftIO $ MVar.newMVar Nothing - - let newCache = CurrentFileCache - { path = path - , fileState = fileStateMVar - , hieCache = hieCacheMVar - , diffCache = diffCacheMVar - } - - -- swap in the new cache - liftIO $ MVar.modifyMVar_ env.currentFile (\_ -> pure (Just newCache)) let fileState = Semantic.mkFileState (Rope.toText source) source - liftIO $ MVar.modifyMVar_ fileStateMVar (\_ -> pure (Just fileState)) - pure () + liftIO $ AtomicLRU.insert path (FileCacheEntry (Just fileState) Nothing Nothing) env.cache removeHieFromSourcePath :: (MonadIde m) => AbsPath -> m () removeHieFromSourcePath path = do - maybeCache <- runMaybeT $ getCurrentFileCache path - case maybeCache of - Just cache -> do - liftIO $ MVar.modifyMVar_ cache.hieCache (\_ -> pure Nothing) - liftIO $ MVar.modifyMVar_ cache.diffCache (\_ -> pure Nothing) + env <- getIdeEnv + entry <- liftIO $ AtomicLRU.lookup path env.cache + case entry of + Just e -> liftIO $ AtomicLRU.insert path (e { hieCache = Nothing, diffCache = Nothing }) env.cache Nothing -> pure () -throwIfInThSplice :: (HasCallStack, MonadIde m) => String -> AbsPath -> Pos -> m () +forceCachedHieFile :: CachedHieFile -> CachedHieFile +forceCachedHieFile hie = hie + +getHieCacheWithMap :: (MonadIO m, HasStaticEnv m, HasLogger m) => AbsPath -> HieCacheMap -> MaybeT m CachedHieFile +getHieCacheWithMap path hieCacheMap = + case HashMap.lookup path hieCacheMap of + Just hieFile -> do + 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 + let hieFile = + CachedHieFile + { hieSource + , hieSourceRope = Rope.fromText hieSource + , file = file + , fileView + , hieTokenMap = PositionDiff.tokensToRangeMap tokens + , modifiedAt = modifiedAt + } + pure hieFile + +throwIfInThSplice :: (HasCallStack, MonadIde m, MonadIO m) => String -> AbsPath -> Pos -> m () throwIfInThSplice msg path pos = do haskell <- getHaskell path let range = (Range.point pos) diff --git a/static-ls.cabal b/static-ls.cabal index df130cc2..3fa3ea7e 100644 --- a/static-ls.cabal +++ b/static-ls.cabal @@ -50,6 +50,7 @@ library build-depends: Diff , aeson >=2 && <2.3 + , lrucache >= 1.2.0.1 , array >=0.5.4 && <0.6 , async , base >=4.17.0 && <4.21 From 1a30a5139aa8b9943eb377fd82a0dc466ec9a353 Mon Sep 17 00:00:00 2001 From: Shan Ali Date: Tue, 5 Aug 2025 15:02:51 -0500 Subject: [PATCH 4/5] fix: fmt + lint --- src/StaticLS/IDE/Monad.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/StaticLS/IDE/Monad.hs b/src/StaticLS/IDE/Monad.hs index 96bed9fb..e12ebb13 100644 --- a/src/StaticLS/IDE/Monad.hs +++ b/src/StaticLS/IDE/Monad.hs @@ -42,7 +42,7 @@ data FileCacheEntry = FileCacheEntry , diffCache :: Maybe DiffCache } --- empty +-- empty emptyEntry :: FileCacheEntry emptyEntry = FileCacheEntry Nothing Nothing Nothing @@ -85,7 +85,7 @@ getFileState path = do res <- getFileStateResult path let fs = fromMaybe Semantic.emptyFileState res let currentEntry = fromMaybe emptyEntry entry - liftIO $ AtomicLRU.insert path (currentEntry { fileState = Just fs }) env.cache + liftIO $ AtomicLRU.insert path (currentEntry {fileState = Just fs}) env.cache pure fs getHaskell :: (MonadIde m, MonadIO m) => AbsPath -> m Haskell.Haskell @@ -179,7 +179,7 @@ invalidateStaleHieCacheFile path = do case entry.hieCache of Just hieFile -> do when (hieFile.modifiedAt < latestHieModifiedAt) $ do - liftIO $ AtomicLRU.insert path (entry { hieCache = Nothing, diffCache = Nothing }) env.cache + liftIO $ AtomicLRU.insert path (entry {hieCache = Nothing, diffCache = Nothing}) env.cache Nothing -> pure () getHieCache :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m CachedHieFile @@ -192,7 +192,7 @@ getHieCache path = do Nothing -> do hie <- getHieCacheResult path let currentEntry = fromMaybe emptyEntry entry - liftIO $ AtomicLRU.insert path (currentEntry { hieCache = Just hie }) env.cache + liftIO $ AtomicLRU.insert path (currentEntry {hieCache = Just hie}) env.cache pure hie getTokenMap :: (MonadIde m, MonadIO m) => AbsPath -> m (RangeMap PositionDiff.Token) @@ -255,7 +255,7 @@ getDiffCache path = do Nothing -> do diff <- getDiffCacheResult path let currentEntry = fromMaybe emptyEntry entry - liftIO $ AtomicLRU.insert path (currentEntry { diffCache = Just diff }) env.cache + liftIO $ AtomicLRU.insert path (currentEntry {diffCache = Just diff}) env.cache pure diff getDiffCacheResult :: (MonadIde m, MonadIO m) => AbsPath -> MaybeT m DiffCache @@ -280,7 +280,7 @@ removeHieFromSourcePath path = do env <- getIdeEnv entry <- liftIO $ AtomicLRU.lookup path env.cache case entry of - Just e -> liftIO $ AtomicLRU.insert path (e { hieCache = Nothing, diffCache = Nothing }) env.cache + Just e -> liftIO $ AtomicLRU.insert path (e {hieCache = Nothing, diffCache = Nothing}) env.cache Nothing -> pure () forceCachedHieFile :: CachedHieFile -> CachedHieFile @@ -316,4 +316,4 @@ throwIfInThSplice msg path pos = do case splice of Nothing -> pure () Just _ -> do - Exception.throwString $ "Cannot perform action in splice: " ++ msg \ No newline at end of file + Exception.throwString $ "Cannot perform action in splice: " ++ msg From c6adf6a462c079ef843a6794b9c982da41d37c49 Mon Sep 17 00:00:00 2001 From: Shan Ali Date: Thu, 7 Aug 2025 15:30:05 -0400 Subject: [PATCH 5/5] deubg: log when file not in cache --- src/StaticLS/IDE/Monad.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/StaticLS/IDE/Monad.hs b/src/StaticLS/IDE/Monad.hs index e12ebb13..688b469b 100644 --- a/src/StaticLS/IDE/Monad.hs +++ b/src/StaticLS/IDE/Monad.hs @@ -23,6 +23,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time +import Debug.Trace import StaticLS.FilePath import StaticLS.HIE.File qualified as HIE.File import StaticLS.HieView qualified as HieView @@ -126,9 +127,9 @@ getFileStateResult path = do if doesExist then do contents <- - liftIO $ - Exception.tryAny - (liftIO $ T.readFile $ toFilePath path) + trace ("Reading from disk (not in cache): " ++ show path) $ + liftIO $ + Exception.tryAny (liftIO $ T.readFile $ toFilePath path) case contents of Left e -> do logError $ "Failed to read file: " <> T.pack (show e)