Lock-less hls-graph (#2411)

* Fix incomplete pattern match warning in 8.8 * lock-less hls-graph
haskell · Nov 30, 2021 · 18633c7 · 18633c7
1 parent 083f542
commit 18633c7
Show file tree

Hide file tree

Showing 16 changed files with 224 additions and 384 deletions.
diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml
@@ -77,7 +77,6 @@
   - {name: GeneralizedNewtypeDeriving, within: []}
   - {name: LambdaCase, within: []}
   - {name: NamedFieldPuns, within: []}
-  - {name: PackageImports, within: []}
   - {name: RecordWildCards, within: []}
   - {name: ScopedTypeVariables, within: []}
   - {name: StandaloneDeriving, within: []}

diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -681,6 +681,9 @@ uniqueCompl candidate unique =
       importedFrom (provenance -> ImportedFrom m) = m
       importedFrom (provenance -> DefinedIn m)    = m
       importedFrom (provenance -> Local _)        = "local"
+#if __GLASGOW_HASKELL__ < 810
+      importedFrom _                              = ""
+#endif
 
 -- ---------------------------------------------------------------------
 -- helper functions for infix backticks

diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal
@@ -45,8 +45,6 @@ library
     Development.IDE.Graph.Internal.Options
     Development.IDE.Graph.Internal.Rules
     Development.IDE.Graph.Internal.Database
-    Development.IDE.Graph.Internal.Ids
-    Development.IDE.Graph.Internal.Intern
     Development.IDE.Graph.Internal.Paths
     Development.IDE.Graph.Internal.Profile
     Development.IDE.Graph.Internal.Types
@@ -66,11 +64,15 @@ library
     , exceptions
     , extra
     , filepath
+    , focus
     , hashable
     , js-dgtable
     , js-flot
     , js-jquery
+    , list-t
     , primitive
+    , stm
+    , stm-containers
     , time
     , transformers
     , unordered-containers

diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -12,13 +12,13 @@ module Development.IDE.Graph.Database(
     shakeGetDirtySet,
     shakeGetCleanKeys
     ,shakeGetBuildEdges) where
+import           Control.Concurrent.STM                  (atomically,
+                                                          readTVarIO)
 import           Data.Dynamic
-import           Data.IORef                              (readIORef)
 import           Data.Maybe
 import           Development.IDE.Graph.Classes           ()
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Database
-import qualified Development.IDE.Graph.Internal.Ids      as Ids
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Profile  (writeProfile)
 import           Development.IDE.Graph.Internal.Rules
@@ -45,12 +45,12 @@ shakeRunDatabase = shakeRunDatabaseForKeys Nothing
 -- | Returns the set of dirty keys annotated with their age (in # of builds)
 shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
 shakeGetDirtySet (ShakeDatabase _ _ db) =
-    fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db
+    Development.IDE.Graph.Internal.Database.getDirtySet db
 
 -- | Returns the build number
 shakeGetBuildStep :: ShakeDatabase -> IO Int
 shakeGetBuildStep (ShakeDatabase _ _ db) = do
-    Step s <- readIORef $ databaseStep db
+    Step s <- readTVarIO $ databaseStep db
     return s
 
 -- Only valid if we never pull on the results, which we don't
@@ -64,7 +64,7 @@ shakeRunDatabaseForKeys
     -> [Action a]
     -> IO ([a], [IO ()])
 shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
-    incDatabase db keysChanged
+    atomically $ incDatabase db keysChanged
     as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
     return (as, [])
 
@@ -75,12 +75,12 @@ shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
 -- | Returns the clean keys in the database
 shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]
 shakeGetCleanKeys (ShakeDatabase _ _ db) = do
-    keys <- Ids.elems $ databaseValues db
+    keys <- getDatabaseValues db
     return [ (k,res) | (k, Clean res) <- keys]
 
 -- | Returns the total count of edges in the build graph
 shakeGetBuildEdges :: ShakeDatabase -> IO Int
 shakeGetBuildEdges (ShakeDatabase _ _ db) = do
-    keys <- Ids.elems $ databaseValues db
+    keys <- getDatabaseValues db
     let ress = mapMaybe (getResult . snd) keys
     return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
@@ -130,7 +130,7 @@ runActions db xs = do
 getDirtySet  :: Action [(Key, Int)]
 getDirtySet = do
     db <- getDatabase
-    liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db
+    liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db
 
 getKeysAndVisitedAge :: Action [(Key, Int)]
 getKeysAndVisitedAge = do