mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Introduce KeyMap and KeySet
This commit is contained in:
Zubin Duggal
wz1000
parent
ada1b3dc13
commit
3b64a3b1c5
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty
|
||||
|
||||
@ -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 :: (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@(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
|
||||
|
||||
15
hls-graph/src/Development/IDE/Graph/KeyMap.hs
Normal file
15
hls-graph/src/Development/IDE/Graph/KeyMap.hs
Normal file
@ -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
|
||||
16
hls-graph/src/Development/IDE/Graph/KeySet.hs
Normal file
16
hls-graph/src/Development/IDE/Graph/KeySet.hs
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user