diff --git a/.hlint.yaml b/.hlint.yaml index 369bb797f24..a04776b87f2 100644 --- a/.hlint.yaml +++ b/.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 diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 93a9c0a90ff..860ad11939c 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b4c3c535729..5e51fd0fbaf 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 (newKey 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 (newKey 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 @@ -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 diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 77fe7dbb593..4897ae77b40 100644 --- a/hls-graph/hls-graph.cabal +++ b/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 diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 88167f898d3..98111080a25 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -20,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 diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index b84c39fe2fc..2bed4a23605 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/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 mempty . 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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index d711834102b..9602f3a10c4 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -26,7 +26,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Foldable (toList) import Data.Functor.Identity -import qualified Data.HashSet as HSet import Data.IORef import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database @@ -122,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 (HSet.fromList $ toList is) <>) + liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index af8b6ea1d5d..2ee82125200 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -30,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 @@ -61,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. @@ -146,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 (HSet.toList -> 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 @@ -178,7 +176,7 @@ compute db@Database{..} stack key mode result = do previousDeps= maybe UnknownDeps resultDeps result let res = Result runValue built' changed built actualDeps execution runStore case getResultDepsDefault mempty actualDeps of - deps | not(null deps) + deps | not(nullKeySet deps) && runChanged /= ChangedNothing -> do -- IMPORTANT: record the reverse deps **before** marking the key Clean. @@ -236,15 +234,15 @@ splitIO act = do updateReverseDeps :: Key -- ^ Id -> Database - -> HashSet 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_ (HSet.toList $ prev `HSet.difference` new) $ \d -> - 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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 4f2a3d4118f..d89b8b7a74c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -12,9 +12,7 @@ import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Dynamic (toDyn) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set import Data.List (dropWhileEnd, foldl', intercalate, partition, sort, @@ -47,8 +45,8 @@ writeProfile :: FilePath -> Database -> IO () writeProfile out db = do (report, mapping) <- toReport db dirtyKeysMapped <- do - dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db - let dirtyKeysMapped = mapMaybe (`Map.lookup` mapping) . Set.toList $ dirtyIds + dirtyIds <- fromListKeySet . fmap fst <$> getDirtySet db + let dirtyKeysMapped = mapMaybe (`lookupKeyMap` mapping) . toListKeySet $ dirtyIds return $ Just $ sort dirtyKeysMapped rpt <- generateHTML dirtyKeysMapped report LBS.writeFile out rpt @@ -58,17 +56,17 @@ data ProfileEntry = ProfileEntry -- | Eliminate all errors from the database, pretending they don't exist -- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value)) -resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result -resultsOnly mp = Map.map (\r -> - r{resultDeps = mapResultDeps (Set.filter (isJust . flip Map.lookup keep)) $ resultDeps r} +resultsOnly :: [(Key, Status)] -> KeyMap Result +resultsOnly mp = mapKeyMap (\r -> + r{resultDeps = mapResultDeps (filterKeySet (isJust . flip lookupKeyMap keep)) $ resultDeps r} ) keep where - keep = Map.fromList $ mapMaybe (traverse getResult) mp + keep = fromListKeyMap $ mapMaybe (traverse getResult) mp -- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such -- that no item points to an item before itself. -- Raise an error if you end up with a cycle. -dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] +-- dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] -- Algorithm: -- Divide everyone up into those who have no dependencies [Id] -- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])] @@ -78,8 +76,8 @@ dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] -- k :-> Nothing means the key has already been freed dependencyOrder shw status = f (map fst noDeps) $ - Map.map Just $ - Map.fromListWith (++) + mapKeyMap Just $ + fromListWithKeyMap (++) [(d, [(k,ds)]) | (k,d:ds) <- hasDeps] where (noDeps, hasDeps) = partition (null . snd) status @@ -89,33 +87,33 @@ dependencyOrder shw status = "Internal invariant broken, database seems to be cyclic" : map (" " ++) bad ++ ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow] - where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp] + where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- toListKeyMap mp] f (x:xs) mp = x : f (now++xs) later - where Just free = Map.lookupDefault (Just []) x mp - (now,later) = foldl' g ([], Map.insert x Nothing mp) free + where Just free = lookupDefaultKeyMap (Just []) x mp + (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free g (free, mp) (k, []) = (k:free, mp) - g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of + g (free, mp) (k, d:ds) = case lookupDefaultKeyMap (Just []) d mp of Nothing -> g (free, mp) (k, ds) - Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp) + Just todo -> (free, insertKeyMap d (Just $ (k,ds) : todo) mp) -prepareForDependencyOrder :: Database -> IO (HashMap Key Result) +prepareForDependencyOrder :: Database -> IO (KeyMap Result) prepareForDependencyOrder db = do current <- readTVarIO $ databaseStep db - Map.insert (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly + insertKeyMap (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly <$> getDatabaseValues db -- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry -toReport :: Database -> IO ([ProfileEntry], HashMap Key Int) +toReport :: Database -> IO ([ProfileEntry], KeyMap Int) toReport db = do status <- prepareForDependencyOrder db let order = dependencyOrder show - $ map (second (Set.toList . getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") . resultDeps)) - $ Map.toList status - ids = Map.fromList $ zip order [0..] + $ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) + $ toListKeyMap status + ids = fromListKeyMap $ zip order [0..] - steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- Map.elems status] + steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- elemsKeyMap status] in Map.fromList $ zip (sortBy (flip compare) xs) [0..] @@ -124,11 +122,11 @@ toReport db = do ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ Map.elems $ Map.intersectionWith const ids $ Set.toMap $ getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") resultDeps + ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps - pure ([maybe (error "toReport") (f i) $ Map.lookup i status | i <- order], ids) + pure ([maybe (error "toReport") (f i) $ lookupKeyMap i status | i <- order], ids) alwaysRerunResult :: Step -> Result alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index a568281a329..a8cccc4de03 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -20,11 +20,13 @@ import Control.Monad.Trans.Reader import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (second) import qualified Data.ByteString as BS +import Data.Coerce import Data.Dynamic import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet, member) -import qualified Data.IntMap as IM -import qualified Data.HashSet as Set +import qualified Data.IntMap.Strict as IM +import Data.IntMap (IntMap) +import qualified Data.IntSet as IS +import Data.IntSet (IntSet) import qualified Data.Text as T import Data.Text (Text) import Data.IORef @@ -88,34 +90,34 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text +data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text newtype Key = UnsafeMkKey Int pattern Key a <- (lookupKeyValue -> KeyValue a _) -data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int +data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int -keyMap :: IORef KeyMap -keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0) +keyMap :: IORef GlobalKeyValueMap +keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0) {-# NOINLINE keyMap #-} newKey :: (Typeable a, Hashable a, Show a) => a -> Key newKey k = unsafePerformIO $ do let !newKey = KeyValue k (T.pack (show k)) - atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) -> + atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) -> let new_key = Map.lookup newKey hm in case new_key of Just v -> (km, v) Nothing -> let !new_index = UnsafeMkKey n - in (KeyMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) + in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) {-# NOINLINE newKey #-} lookupKeyValue :: Key -> KeyValue lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do - KeyMap _ im _ <- readIORef keyMap + GlobalKeyValueMap _ im _ <- readIORef keyMap pure $! im IM.! x {-# NOINLINE lookupKeyValue #-} @@ -137,14 +139,88 @@ instance Show KeyValue where renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t +newtype KeySet = KeySet IntSet + deriving (Eq, Ord, Semigroup, Monoid) + +instance Show KeySet where + showsPrec p (KeySet is)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IS.toList is) :: [Key] + +insertKeySet :: Key -> KeySet -> KeySet +insertKeySet = coerce IS.insert + +memberKeySet :: Key -> KeySet -> Bool +memberKeySet = coerce IS.member + +toListKeySet :: KeySet -> [Key] +toListKeySet = coerce IS.toList + +nullKeySet :: KeySet -> Bool +nullKeySet = coerce IS.null + +differenceKeySet :: KeySet -> KeySet -> KeySet +differenceKeySet = coerce IS.difference + +deleteKeySet :: Key -> KeySet -> KeySet +deleteKeySet = coerce IS.delete + +fromListKeySet :: [Key] -> KeySet +fromListKeySet = coerce IS.fromList + +singletonKeySet :: Key -> KeySet +singletonKeySet = coerce IS.singleton + +filterKeySet :: (Key -> Bool) -> KeySet -> KeySet +filterKeySet = coerce IS.filter + +lengthKeySet :: KeySet -> Int +lengthKeySet = coerce IS.size + +newtype KeyMap a = KeyMap (IntMap a) + deriving (Eq, Ord, Semigroup, Monoid) + +instance Show a => Show (KeyMap a) where + showsPrec p (KeyMap im)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IM.toList im) :: [(Key,a)] + +mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b +mapKeyMap f (KeyMap m) = KeyMap (IM.map f m) + +insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a +insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m) + +lookupKeyMap :: Key -> KeyMap a -> Maybe a +lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m + +lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a +lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m + +fromListKeyMap :: [(Key,a)] -> KeyMap a +fromListKeyMap xs = KeyMap (IM.fromList (coerce xs)) + +fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a +fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs)) + +toListKeyMap :: KeyMap a -> [(Key,a)] +toListKeyMap (KeyMap m) = coerce (IM.toList m) + +elemsKeyMap :: KeyMap a -> [a] +elemsKeyMap (KeyMap m) = IM.elems m + +restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a +restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) + + newtype Value = Value Dynamic data KeyDetails = KeyDetails { keyStatus :: !Status, - keyReverseDeps :: !(HashSet Key) + keyReverseDeps :: !KeySet } -onKeyReverseDeps :: (HashSet Key -> HashSet Key) -> KeyDetails -> KeyDetails +onKeyReverseDeps :: (KeySet -> KeySet) -> KeyDetails -> KeyDetails onKeyReverseDeps f it@KeyDetails{..} = it{keyReverseDeps = f keyReverseDeps} @@ -191,15 +267,15 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !(HashSet Key) | ResultDeps !(HashSet Key) +data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet deriving (Eq, Show) -getResultDepsDefault :: (HashSet Key) -> ResultDeps -> (HashSet Key) +getResultDepsDefault :: KeySet -> ResultDeps -> KeySet getResultDepsDefault _ (ResultDeps ids) = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def -mapResultDeps :: (HashSet Key -> HashSet Key) -> ResultDeps -> ResultDeps +mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps @@ -273,7 +349,7 @@ fromGraphException x = do --------------------------------------------------------------------- -- CALL STACK -data Stack = Stack [Key] !(HashSet Key) +data Stack = Stack [Key] !KeySet instance Show Stack where show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk) @@ -288,12 +364,12 @@ instance Exception StackException where addStack :: Key -> Stack -> Either StackException Stack addStack k (Stack ks is) - | k `member` is = Left $ StackException stack2 + | k `memberKeySet` is = Left $ StackException stack2 | otherwise = Right stack2 - where stack2 = Stack (k:ks) (Set.insert k is) + where stack2 = Stack (k:ks) (insertKeySet k is) memberStack :: Key -> Stack -> Bool -memberStack k (Stack _ ks) = k `member` ks +memberStack k (Stack _ ks) = k `memberKeySet` ks emptyStack :: Stack emptyStack = Stack [] mempty diff --git a/hls-graph/src/Development/IDE/Graph/KeyMap.hs b/hls-graph/src/Development/IDE/Graph/KeyMap.hs new file mode 100644 index 00000000000..daa1ae8642a --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/KeyMap.hs @@ -0,0 +1,15 @@ +module Development.IDE.Graph.KeyMap( + Key, + KeyMap, + mapKeyMap, + insertKeyMap, + lookupKeyMap, + lookupDefaultKeyMap, + fromListKeyMap, + fromListWithKeyMap, + toListKeyMap, + elemsKeyMap, + restrictKeysKeyMap, + ) where + +import Development.IDE.Graph.Internal.Types diff --git a/hls-graph/src/Development/IDE/Graph/KeySet.hs b/hls-graph/src/Development/IDE/Graph/KeySet.hs new file mode 100644 index 00000000000..ef8c46e6b5f --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/KeySet.hs @@ -0,0 +1,16 @@ +module Development.IDE.Graph.KeySet( + Key, + KeySet, + insertKeySet, + memberKeySet, + toListKeySet, + nullKeySet, + differenceKeySet, + deleteKeySet, + fromListKeySet, + singletonKeySet, + filterKeySet, + lengthKeySet, + ) where + +import Development.IDE.Graph.Internal.Types