hls-graph 1.8.0.0 → 1.9.0.0

raw patch · 12 files changed

+249/−93 lines, 12 filesdep −primitivePVP ok

version bump matches the API change (PVP)

Dependencies removed: primitive

API changes (from Hackage documentation)

Files

• hls-graph.cabal +8/−3
• html/shake.js +1/−1
• src/Control/Concurrent/STM/Stats.hs +4/−4
• src/Development/IDE/Graph.hs +8/−2
• src/Development/IDE/Graph/Database.hs +1/−1
• src/Development/IDE/Graph/Internal/Action.hs +2/−2
• src/Development/IDE/Graph/Internal/Database.hs +21/−23
• src/Development/IDE/Graph/Internal/Profile.hs +24/−26
• src/Development/IDE/Graph/Internal/Types.hs +144/−26
• src/Development/IDE/Graph/KeyMap.hs +15/−0
• src/Development/IDE/Graph/KeySet.hs +16/−0
• test/ActionSpec.hs +5/−5

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-graph-version:       1.8.0.0+version:       1.9.0.0 synopsis:      Haskell Language Server internal graph API description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/hls-graph#readme>@@ -47,6 +47,8 @@     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@@ -76,13 +78,13 @@     , js-flot     , js-jquery     , list-t-    , primitive     , stm     , stm-containers     , time     , transformers     , unliftio     , unordered-containers+    , text    if flag(embed-files)         cpp-options: -DFILE_EMBED@@ -91,7 +93,8 @@             template-haskell   if flag(stm-stats)         cpp-options: -DSTM_STATS-+  if impl(ghc >= 9)+        ghc-options: -Wunused-packages    ghc-options:     -Wall -Wredundant-constraints -Wno-name-shadowing@@ -136,3 +139,5 @@     , text     , unordered-containers   build-tool-depends: hspec-discover:hspec-discover -any+  if impl(ghc >= 9)+        ghc-options: -Wunused-packages

@@ -981,7 +981,7 @@     return maxCriticalPath; } /*-Calculating a precise critical path, taking into account the deep dependeny structure, is non-obvious.+Calculating a precise critical path, taking into account the deep dependency structure, is non-obvious. Dependencies have the type [{X}], e.g:      X = [{a,b},{c,d}]

@@ -58,7 +58,7 @@     { tryThreshold      :: Maybe Int         -- ^ If the number of retries of one transaction run reaches this         -- count, a warning is issued at runtime. If set to @Nothing@, disables the warnings completely.-    , globalTheshold    :: Maybe Int+    , globalThreshold   :: Maybe Int         -- ^ If the total number of retries of one named transaction reaches         -- this count, a warning is issued. If set to @Nothing@, disables the         -- warnings completely.@@ -79,7 +79,7 @@ -- -- > defaultTrackSTMConf = TrackSTMConf -- >    { tryThreshold =      Just 10--- >    , globalTheshold =    Just 3000+-- >    , globalThreshold =   Just 3000 -- >    , exception =         True -- >    , warnFunction =      hPutStrLn stderr -- >    , warnInSTMFunction = \_ -> return ()@@ -87,7 +87,7 @@ defaultTrackSTMConf :: TrackSTMConf defaultTrackSTMConf = TrackSTMConf     { tryThreshold = Just 10-    , globalTheshold = Just 3000+    , globalThreshold = Just 3000     , extendException = True     , warnFunction = hPutStrLn stderr     , warnInSTMFunction = \_ -> return ()@@ -143,7 +143,7 @@                                     (1,i)                                     m                 in (m', let j = maybe 0 snd oldVal in (j,j+i))-        doMB globalTheshold $ \globalRetryThreshold ->+        doMB globalThreshold $ \globalRetryThreshold ->             when (k `div` globalRetryThreshold /= k' `div` globalRetryThreshold) $                 warnFunction $ msgPrefix ++ " reached global retry count of " ++ show k' 

@@ -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 @@     -- * 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

@@ -79,7 +79,7 @@ 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

@@ -39,7 +39,7 @@ 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 @@     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.

@@ -1,7 +1,7 @@ -- We deliberately want to ensure the function we add to the rule database -- has the constraints we need on it when we get it out. {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE DeriveFunctor              #-}+ {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes                 #-}@@ -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           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 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 _ 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 _ 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 @@         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 @@             -- 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 @@ 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 @@         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

@@ -12,9 +12,7 @@ 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 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 @@  -- | 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 (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 @@ --    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 @@                     "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 (Key "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 (getResultDepsDefault [Key "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,14 +122,14 @@             ,prfBuilt = fromStep resultBuilt             ,prfVisited = fromStep resultVisited             ,prfChanged = fromStep resultChanged-            ,prfDepends = map pure $ mapMaybe (`Map.lookup` ids) $ getResultDepsDefault [Key "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 "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty+alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty  generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString generateHTML dirtyKeys xs = do

@@ -7,37 +7,40 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ViewPatterns               #-}  module Development.IDE.Graph.Internal.Types where  import           Control.Applicative import           Control.Monad.Catch-#if __GLASGOW_HASKELL__ < 808--- Needed in GHC 8.6.5-import           Control.Concurrent.STM.Stats  (TVar, atomically)-import           Control.Monad.Fail-#else-import           GHC.Conc                      (TVar, atomically)-#endif import           Control.Monad.IO.Class 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.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 import           Data.List                     (intercalate) import           Data.Maybe import           Data.Typeable import           Development.IDE.Graph.Classes+import           GHC.Conc                      (TVar, atomically) import           GHC.Generics                  (Generic) import qualified ListT import qualified StmContainers.Map             as SMap import           StmContainers.Map             (Map) import           System.Time.Extra             (Seconds)+import           System.IO.Unsafe import           UnliftIO                      (MonadUnliftIO)  @@ -84,25 +87,140 @@ newtype Step = Step Int     deriving newtype (Eq,Ord,Hashable) -data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a+---------------------------------------------------------------------+-- Keys -instance Eq Key where-    Key a == Key b = Just a == cast b+data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text -instance Hashable Key where-    hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x)+newtype Key = UnsafeMkKey Int +pattern Key a <- (lookupKeyValue -> KeyValue a _)++data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int++keyMap :: IORef GlobalKeyValueMap+keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0)++{-# NOINLINE keyMap #-}++newKey :: (Eq a, Typeable a, Hashable a, Show a) => a -> Key+newKey k = unsafePerformIO $ do+  let !newKey = KeyValue k (T.pack (show k))+  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 (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+  GlobalKeyValueMap _ im _ <- readIORef keyMap+  pure $! im IM.! x++{-# NOINLINE lookupKeyValue #-}++instance Eq Key where+  UnsafeMkKey a == UnsafeMkKey b = a == b+instance Hashable Key where+  hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x instance Show Key where-    show (Key x) = show x+  show (Key x) = show x +instance Eq KeyValue where+    KeyValue a _ == KeyValue b _ = Just a == cast b+instance Hashable KeyValue where+    hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x)+instance Show KeyValue where+    show (KeyValue x t) = T.unpack t++renderKey :: Key -> Text+renderKey (lookupKeyValue -> KeyValue _ t) = t++newtype KeySet = KeySet IntSet+  deriving newtype (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 newtype (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} @@ -149,15 +267,15 @@     resultData      :: !BS.ByteString     } -data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key]+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet   deriving (Eq, Show) -getResultDepsDefault :: [Key] -> ResultDeps -> [Key]+getResultDepsDefault :: KeySet -> ResultDeps -> KeySet getResultDepsDefault _ (ResultDeps ids)      = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps         = def -mapResultDeps :: ([Key] -> [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@@ -165,8 +283,8 @@ instance Semigroup ResultDeps where     UnknownDeps <> x = x     x <> UnknownDeps = x-    AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)-    x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)+    AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault mempty x)+    x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault mempty x <> ids)     ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')  instance Monoid ResultDeps where@@ -231,7 +349,7 @@ --------------------------------------------------------------------- -- 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)@@ -246,12 +364,12 @@  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

@@ -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

@@ -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

@@ -43,8 +43,8 @@         pure $ do           apply1 theKey       res `shouldBe` [True]-      Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb-      resultDeps res `shouldBe` ResultDeps [Key (Rule @())]+      Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb+      resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @()))     it "tracks reverse dependencies" $ do       db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do         ruleUnit@@ -54,8 +54,8 @@         pure $ do           apply1 theKey       res `shouldBe` [True]-      Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues-      keyReverseDeps `shouldBe` HashSet.fromList [Key theKey]+      Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues+      keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey)     it "rethrows exceptions" $ do       db <- shakeNewDatabase shakeOptions $ do         addRule $ \(Rule :: Rule ()) old mode -> error "boom"@@ -74,5 +74,5 @@         pure $ do           applyWithoutDependency [theKey]       res `shouldBe` [[True]]-      Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb+      Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb       resultDeps res `shouldBe` UnknownDeps