Implement sharing for hls-graph Keys

.hlint.yaml

@@ -59,6 +59,7 @@
     - Development.IDE.Graph.Internal.Database
     - Development.IDE.Graph.Internal.Paths
     - Development.IDE.Graph.Internal.Profile
+    - Development.IDE.Graph.Internal.Types
     - Ide.Types
     - Test.Hls
     - Test.Hls.Command

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -55,7 +55,6 @@ import qualified Development.IDE.Types.Logger                 as L
 
 import qualified Data.Binary                                  as B
 import qualified Data.ByteString.Lazy                         as LBS
-import qualified Data.HashSet                                 as HSet
 import           Data.List                                    (foldl')
 import qualified Data.Text                                    as Text
 import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile)
@@ -256,7 +255,7 @@ setSomethingModified vfs state keys reason = do
     atomically $ do
         writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
         modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->
-            foldl' (flip HSet.insert) x keys
+            foldl' (flip insertKeySet) x keys
     void $ restartShakeSession (shakeExtras state) vfs reason []
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

ghcide/src/Development/IDE/Core/Shake.hs

@@ -178,7 +178,7 @@ import           System.Time.Extra
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath)
+  | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath)
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !(Maybe SomeException)
@@ -197,7 +197,7 @@ instance Pretty Log where
       vcat
         [ "Restarting build session due to" <+> pretty reason
         , "Action Queue:" <+> pretty (map actionName actionQueue)
-        , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog)
+        , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
         "Build restart is taking too long (" <> pretty seconds <> " seconds)"
@@ -279,7 +279,7 @@ data ShakeExtras = ShakeExtras
     ,clientCapabilities :: ClientCapabilities
     , withHieDb :: WithHieDb -- ^ Use only to read.
     , hiedbWriter :: HieDbWriter -- ^ use to write
-    , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)
+    , persistentKeys :: TVar (KeyMap GetStalePersistent)
       -- ^ Registery for functions that compute/get "stale" results for the rule
       -- (possibly from disk)
     , vfsVar :: TVar VFS
@@ -290,7 +290,7 @@ data ShakeExtras = ShakeExtras
     -- We don't need a STM.Map because we never update individual keys ourselves.
     , defaultConfig :: Config
       -- ^ Default HLS config, only relevant if the client does not provide any Config
-    , dirtyKeys :: TVar (HashSet Key)
+    , dirtyKeys :: TVar KeySet
       -- ^ Set of dirty rule keys since the last Shake run
     }
 
@@ -324,7 +324,7 @@ getPluginConfig plugin = do
 addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
 addPersistentRule k getVal = do
   ShakeExtras{persistentKeys} <- getShakeExtrasRules
-  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
+  void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal)
 
 class Typeable a => IsIdeGlobal a where
 
@@ -399,7 +399,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           pmap <- readTVarIO persistentKeys
           mv <- runMaybeT $ do
             liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
-            f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
+            f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap
             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
           case mv of
@@ -509,7 +509,7 @@ deleteValue
   -> STM ()
 deleteValue ShakeExtras{dirtyKeys, state} key file = do
     STM.delete (toKey key file) state
-    modifyTVar' dirtyKeys $ HSet.insert (toKey key file)
+    modifyTVar' dirtyKeys $ insertKeySet (toKey key file)
 
 recordDirtyKeys
   :: Shake.ShakeValue k
@@ -518,7 +518,7 @@ recordDirtyKeys
   -> [NormalizedFilePath]
   -> STM (IO ())
 recordDirtyKeys ShakeExtras{dirtyKeys} key file = do
-    modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)
+    modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file)
     return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do
         addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file)
 
@@ -594,7 +594,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
         positionMapping <- STM.newIO
         knownTargetsVar <- newTVarIO $ hashed HMap.empty
         let restartShakeSession = shakeRestart recorder ideState
-        persistentKeys <- newTVarIO HMap.empty
+        persistentKeys <- newTVarIO mempty
         indexPending <- newTVarIO HMap.empty
         indexCompleted <- newTVarIO 0
         indexProgressToken <- newVar Nothing
@@ -637,7 +637,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
 
     -- monitoring
     let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
-        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras)
+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
         readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
         readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras)
         readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
@@ -797,10 +797,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
         workRun restore = withSpan "Shake session" $ \otSpan -> do
           setTag otSpan "reason" (fromString reason)
           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)
-          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk)
+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)
           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException $
-            restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs
+            restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs
           return $ do
               let exception =
                     case res of
@@ -890,7 +890,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do
             = atomicallyNamed "GC" $ do
                 gotIt <- STM.focus (Focus.member <* Focus.delete) k values
                 when gotIt $
-                   modifyTVar' dk (HSet.insert k)
+                   modifyTVar' dk (insertKeySet k)
                 return $ if gotIt then (counter+1, k:keys) else st
             | otherwise = pure st
 
@@ -1068,7 +1068,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
 defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
     let diagnostics _ver diags = do
@@ -1087,7 +1087,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o
     extras <- getShakeExtras
     let diagnostics ver diags = do
             traceDiagnostics diags
-            updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
+            updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
     defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
 
 defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()
@@ -1160,7 +1160,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs) $
                     A res
-        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file)
+        liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)
         return res
   where
     -- Highly unsafe helper to compute the version of a file
@@ -1207,7 +1207,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
-        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store
+        update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always

ghcide/src/Development/IDE/Types/Shake.hs

@@ -26,7 +26,7 @@ import           Data.Typeable                        (cast)
 import           Data.Vector                          (Vector)
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.RuleTypes       (FileVersion)
-import           Development.IDE.Graph                (Key (..), RuleResult)
+import           Development.IDE.Graph                (Key (..), RuleResult, newKey)
 import qualified Development.IDE.Graph                as Shake
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
@@ -75,7 +75,7 @@ isBadDependency x
     | otherwise = False
 
 toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key
-toKey = (Key.) . curry Q
+toKey = (newKey.) . curry Q
 
 fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath)
 fromKey (Key k)
@@ -91,7 +91,7 @@ fromKeyType (Key k) = case typeOf k of
     _ -> Nothing
 
 toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key
-toNoFileKey k = Key $ Q (k, emptyFilePath)
+toNoFileKey k = newKey $ Q (k, emptyFilePath)
 
 newtype Q k = Q (k, NormalizedFilePath)
     deriving newtype (Eq, Hashable, NFData)

hls-graph/hls-graph.cabal

@@ -47,6 +47,8 @@ library
     Development.IDE.Graph.Classes
     Development.IDE.Graph.Database
     Development.IDE.Graph.Rule
+    Development.IDE.Graph.KeyMap
+    Development.IDE.Graph.KeySet
     Development.IDE.Graph.Internal.Action
     Development.IDE.Graph.Internal.Options
     Development.IDE.Graph.Internal.Rules
@@ -82,6 +84,7 @@ library
     , transformers
     , unliftio
     , unordered-containers
+    , text
 
   if flag(embed-files)
         cpp-options: -DFILE_EMBED

hls-graph/src/Development/IDE/Graph.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
 module Development.IDE.Graph(
-    shakeOptions,
+      shakeOptions,
     Rules,
     Action, action,
-    Key(..),
+    Key(.., Key),
+    newKey, renderKey,
     actionFinally, actionBracket, actionCatch, actionFork,
     -- * Configuration
     ShakeOptions(shakeAllowRedefineRules, shakeExtra),
@@ -18,9 +20,13 @@ module Development.IDE.Graph(
     -- * Actions for inspecting the keys in the database
     getDirtySet,
     getKeysAndVisitedAge,
+    module Development.IDE.Graph.KeyMap,
+    module Development.IDE.Graph.KeySet,
     ) where
 
 import           Development.IDE.Graph.Database
+import           Development.IDE.Graph.KeyMap
+import           Development.IDE.Graph.KeySet
 import           Development.IDE.Graph.Internal.Action
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Rules

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -79,7 +79,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int
 shakeGetBuildEdges (ShakeDatabase _ _ db) = do
     keys <- getDatabaseValues db
     let ress = mapMaybe (getResult . snd) keys
-    return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
+    return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress
 
 -- | Returns an approximation of the database keys,
 --   annotated with how long ago (in # builds) they were visited

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -39,7 +39,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
+    liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
 
 -- No-op for now
 reschedule :: Double -> Action ()
@@ -121,7 +121,7 @@ apply ks = do
     stack <- Action $ asks actionStack
     (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef ref (ResultDeps (toList is) <>)
+    liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)
     pure vs
 
 -- | Evaluate a list of keys without recording any dependencies.

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE ViewPatterns               #-}
 
 module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
 
@@ -29,8 +30,6 @@ import qualified Control.Monad.Trans.State.Strict     as State
 import           Data.Dynamic
 import           Data.Either
 import           Data.Foldable                        (for_, traverse_)
-import           Data.HashSet                         (HashSet)
-import qualified Data.HashSet                         as HSet
 import           Data.IORef.Extra
 import           Data.List.NonEmpty                   (unzip)
 import           Data.Maybe
@@ -60,7 +59,7 @@ incDatabase :: Database -> Maybe [Key] -> IO ()
 incDatabase db (Just kk) = do
     atomicallyNamed "incDatabase" $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
     transitiveDirtyKeys <- transitiveDirtySet db kk
-    for_ transitiveDirtyKeys $ \k ->
+    for_ (toListKeySet transitiveDirtyKeys) $ \k ->
         -- Updating all the keys atomically is not necessary
         -- since we assume that no build is mutating the db.
         -- Therefore run one transaction per key to minimise contention.
@@ -87,7 +86,7 @@ build
 -- build _ st k | traceShow ("build", st, k) False = undefined
 build db stack keys = do
     built <- runAIO $ do
-        built <- builder db stack (fmap Key keys)
+        built <- builder db stack (fmap newKey keys)
         case built of
           Left clean  -> return clean
           Right dirty -> liftIO dirty
@@ -145,7 +144,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
 -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
 refresh db stack key result = case (addStack key stack, result) of
     (Left e, _) -> throw e
-    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> do
+    (Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do
         res <- builder db stack deps
         let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
         case res of
@@ -176,8 +175,8 @@ compute db@Database{..} stack key mode result = do
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
-    case getResultDepsDefault [] actualDeps of
-        deps | not(null deps)
+    case getResultDepsDefault mempty actualDeps of
+        deps | not(nullKeySet deps)
             && runChanged /= ChangedNothing
                     -> do
             -- IMPORTANT: record the reverse deps **before** marking the key Clean.
@@ -186,8 +185,8 @@ compute db@Database{..} stack key mode result = do
             -- on the next build.
             void $
                 updateReverseDeps key db
-                    (getResultDepsDefault [] previousDeps)
-                    (HSet.fromList deps)
+                    (getResultDepsDefault mempty previousDeps)
+                    deps
         _ -> pure ()
     atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues
     pure res
@@ -235,16 +234,15 @@ splitIO act = do
 updateReverseDeps
     :: Key        -- ^ Id
     -> Database
-    -> [Key] -- ^ Previous direct dependencies of Id
-    -> HashSet Key -- ^ Current direct dependencies of Id
+    -> KeySet -- ^ Previous direct dependencies of Id
+    -> KeySet -- ^ Current direct dependencies of Id
     -> IO ()
 -- mask to ensure that all the reverse dependencies are updated
 updateReverseDeps myId db prev new = do
-    forM_ prev $ \d ->
-        unless (d `HSet.member` new) $
-            doOne (HSet.delete myId) d
-    forM_ (HSet.toList new) $
-        doOne (HSet.insert myId)
+    forM_ (toListKeySet $ prev `differenceKeySet` new) $ \d ->
+         doOne (deleteKeySet myId) d
+    forM_ (toListKeySet new) $
+        doOne (insertKeySet myId)
     where
         alterRDeps f =
             Focus.adjust (onKeyReverseDeps f)
@@ -254,18 +252,18 @@ updateReverseDeps myId db prev new = do
         doOne f id = atomicallyNamed "updateReverseDeps" $
             SMap.focus (alterRDeps f) id (databaseValues db)
 
-getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key))
+getReverseDependencies :: Database -> Key -> STM (Maybe KeySet)
 getReverseDependencies db = (fmap.fmap) keyReverseDeps  . flip SMap.lookup (databaseValues db)
 
-transitiveDirtySet :: Foldable t => Database -> t Key -> IO (HashSet Key)
-transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop
+transitiveDirtySet :: Foldable t => Database -> t Key -> IO KeySet
+transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop
   where
     loop x = do
         seen <- State.get
-        if x `HSet.member` seen then pure () else do
-            State.put (HSet.insert x seen)
+        if x `memberKeySet` seen then pure () else do
+            State.put (insertKeySet x seen)
             next <- lift $ atomically $ getReverseDependencies database x
-            traverse_ loop (maybe mempty HSet.toList next)
+            traverse_ loop (maybe mempty toListKeySet next)
 
 --------------------------------------------------------------------------------
 -- Asynchronous computations with cancellation