diff --git a/hls-graph.cabal b/hls-graph.cabal --- a/hls-graph.cabal +++ b/hls-graph.cabal @@ -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 @@ -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 diff --git a/html/shake.js b/html/shake.js --- a/html/shake.js +++ b/html/shake.js @@ -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}] diff --git a/src/Control/Concurrent/STM/Stats.hs b/src/Control/Concurrent/STM/Stats.hs --- a/src/Control/Concurrent/STM/Stats.hs +++ b/src/Control/Concurrent/STM/Stats.hs @@ -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' diff --git a/src/Development/IDE/Graph.hs b/src/Development/IDE/Graph.hs --- a/src/Development/IDE/Graph.hs +++ b/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 @@ -- * 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/src/Development/IDE/Graph/Database.hs b/src/Development/IDE/Graph/Database.hs --- a/src/Development/IDE/Graph/Database.hs +++ b/src/Development/IDE/Graph/Database.hs @@ -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 diff --git a/src/Development/IDE/Graph/Internal/Action.hs b/src/Development/IDE/Graph/Internal/Action.hs --- a/src/Development/IDE/Graph/Internal/Action.hs +++ b/src/Development/IDE/Graph/Internal/Action.hs @@ -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. diff --git a/src/Development/IDE/Graph/Internal/Database.hs b/src/Development/IDE/Graph/Internal/Database.hs --- a/src/Development/IDE/Graph/Internal/Database.hs +++ b/src/Development/IDE/Graph/Internal/Database.hs @@ -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 diff --git a/src/Development/IDE/Graph/Internal/Profile.hs b/src/Development/IDE/Graph/Internal/Profile.hs --- a/src/Development/IDE/Graph/Internal/Profile.hs +++ b/src/Development/IDE/Graph/Internal/Profile.hs @@ -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 "") (Step 0) (Step 0) current (ResultDeps []) 0 mempty +alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString generateHTML dirtyKeys xs = do diff --git a/src/Development/IDE/Graph/Internal/Types.hs b/src/Development/IDE/Graph/Internal/Types.hs --- a/src/Development/IDE/Graph/Internal/Types.hs +++ b/src/Development/IDE/Graph/Internal/Types.hs @@ -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 diff --git a/src/Development/IDE/Graph/KeyMap.hs b/src/Development/IDE/Graph/KeyMap.hs new file mode 100644 --- /dev/null +++ b/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/src/Development/IDE/Graph/KeySet.hs b/src/Development/IDE/Graph/KeySet.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/test/ActionSpec.hs b/test/ActionSpec.hs --- a/test/ActionSpec.hs +++ b/test/ActionSpec.hs @@ -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