hls-graph 2.7.0.0 → 2.8.0.0

raw patch · 8 files changed

+110/−36 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hls-graph.cabal +1/−1
• src/Development/IDE/Graph.hs +0/−2
• src/Development/IDE/Graph/Internal/Action.hs +4/−7
• src/Development/IDE/Graph/Internal/Database.hs +32/−17
• src/Development/IDE/Graph/Internal/Key.hs +1/−1
• src/Development/IDE/Graph/Internal/Types.hs +8/−3
• test/ActionSpec.hs +29/−5
• test/Example.hs +35/−0

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               hls-graph-version:            2.7.0.0+version:            2.8.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>

@@ -15,8 +15,6 @@     ShakeValue, RuleResult,     -- * Special rules     alwaysRerun,-    -- * Batching-    reschedule,     -- * Actions for inspecting the keys in the database     getDirtySet,     getKeysAndVisitedAge,

@@ -11,13 +11,13 @@ , apply , applyWithoutDependency , parallel-, reschedule , runActions , Development.IDE.Graph.Internal.Action.getDirtySet , getKeysAndVisitedAge ) where  import           Control.Concurrent.Async+import           Control.DeepSeq                         (force) import           Control.Exception import           Control.Monad.IO.Class import           Control.Monad.Trans.Class@@ -38,11 +38,7 @@ alwaysRerun :: Action () alwaysRerun = do     ref <- Action $ asks actionDeps-    liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)---- No-op for now-reschedule :: Double -> Action ()-reschedule _ = pure ()+    liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>)  parallel :: [Action a] -> Action [a] parallel [] = pure []@@ -120,7 +116,8 @@     stack <- Action $ asks actionStack     (is, vs) <- liftIO $ build db stack ks     ref <- Action $ asks actionDeps-    liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)+    let !ks = force $ fromListKeySet $ toList is+    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)     pure vs  -- | Evaluate a list of keys without recording any dependencies.

@@ -3,9 +3,9 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}  {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase         #-} {-# LANGUAGE RecordWildCards    #-} {-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE ViewPatterns       #-}  module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -133,26 +133,41 @@                 waitAll                 pure results +isDirty :: Foldable t => Result -> t (a, Result) -> Bool+isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)++-- | Refresh dependencies for a key and compute the key:+-- The refresh the deps linearly(last computed order of the deps for the key).+-- If any of the deps is dirty in the process, we jump to the actual computation of the key+-- and shortcut the refreshing of the rest of the deps.+-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.+--   This assumes that the implementation will be a lookup+-- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself+refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result)+refreshDeps visited db stack key result = \case+    -- no more deps to refresh+    [] -> pure $ compute db stack key RunDependenciesSame (Just result)+    (dep:deps) -> do+        let newVisited = dep <> visited+        res <- builder db stack (toListKeySet (dep `differenceKeySet` visited))+        case res of+            Left res ->  if isDirty result res+                -- restart the computation if any of the deps are dirty+                then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result)+                -- else kick the rest of the deps+                else refreshDeps newVisited db stack key result deps+            Right iores -> asyncWithCleanUp $ liftIO $ do+                res <- iores+                if isDirty result res+                    then compute db stack key RunDependenciesChanged (Just result)+                    else join $ runAIO $ refreshDeps newVisited db stack key result deps+ -- | Refresh a key:---     * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.---       This assumes that the implementation will be a lookup---     * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself 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 (toListKeySet -> deps)}) -> do-        res <- builder db stack deps-        let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)-        case res of-            Left res ->-                if isDirty res-                    then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result-                    else pure $ compute db stack key RunDependenciesSame result-            Right iores -> asyncWithCleanUp $ liftIO $ do-                res <- iores-                let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame-                compute db stack key mode result+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps)     (Right stack, _) ->         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result @@ -173,7 +188,7 @@         previousDeps= maybe UnknownDeps resultDeps result     let res = Result runValue built' changed built actualDeps execution runStore     case getResultDepsDefault mempty actualDeps of-        deps | not(nullKeySet deps)+        deps | not (nullKeySet deps)             && runChanged /= ChangedNothing                     -> do             -- IMPORTANT: record the reverse deps **before** marking the key Clean.

@@ -101,7 +101,7 @@ renderKey (lookupKeyValue -> KeyValue _ t) = t  newtype KeySet = KeySet IntSet-  deriving newtype (Eq, Ord, Semigroup, Monoid)+  deriving newtype (Eq, Ord, Semigroup, Monoid, NFData)  instance Show KeySet where   showsPrec p (KeySet is)= showParen (p > 10) $

@@ -12,6 +12,7 @@ import           Data.Bifunctor                     (second) import qualified Data.ByteString                    as BS import           Data.Dynamic+import           Data.Foldable                      (fold) import qualified Data.HashMap.Strict                as Map import           Data.IORef import           Data.List                          (intercalate)@@ -144,16 +145,20 @@     resultData      :: !BS.ByteString     } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet+-- Notice, invariant to maintain:+-- the ![KeySet] in ResultDeps need to be stored in reverse order,+-- so that we can append to it efficiently, and we need the ordering+-- so we can do a linear dependency refreshing in refreshDeps.+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet]   deriving (Eq, Show)  getResultDepsDefault :: KeySet -> ResultDeps -> KeySet-getResultDepsDefault _ (ResultDeps ids)      = ids+getResultDepsDefault _ (ResultDeps ids)      = fold ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps         = def  mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps-mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids+mapResultDeps f (ResultDeps ids)      = ResultDeps $ fmap f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps           = UnknownDeps 

@@ -3,15 +3,17 @@  module ActionSpec where +import qualified Control.Concurrent                      as C import           Control.Concurrent.STM-import           Development.IDE.Graph                (shakeOptions)-import           Development.IDE.Graph.Database       (shakeNewDatabase,-                                                       shakeRunDatabase)+import           Development.IDE.Graph                   (shakeOptions)+import           Development.IDE.Graph.Database          (shakeNewDatabase,+                                                          shakeRunDatabase)+import           Development.IDE.Graph.Internal.Database (build, incDatabase) import           Development.IDE.Graph.Internal.Key import           Development.IDE.Graph.Internal.Types import           Development.IDE.Graph.Rule import           Example-import qualified StmContainers.Map                    as STM+import qualified StmContainers.Map                       as STM import           Test.Hspec  spec :: Spec@@ -40,7 +42,7 @@           apply1 theKey       res `shouldBe` [True]       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb-      resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @()))+      resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())]     it "tracks reverse dependencies" $ do       db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do         ruleUnit@@ -57,6 +59,28 @@         addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"       let res = shakeRunDatabase db $ pure $ apply1 (Rule @())       res `shouldThrow` anyErrorCall+    it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do+      cond <- C.newMVar True+      count <- C.newMVar 0+      (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+        ruleUnit+        ruleCond cond+        ruleSubBranch count+        ruleWithCond+      -- build the one with the condition True+      -- This should call the SubBranchRule once+      -- cond rule would return different results each time+      res0 <- build theDb emptyStack [BranchedRule]+      snd res0 `shouldBe` [1 :: Int]+      incDatabase theDb Nothing+      -- build the one with the condition False+      -- This should not call the SubBranchRule+      res1 <- build theDb emptyStack [BranchedRule]+      snd res1 `shouldBe` [2 :: Int]+     -- SubBranchRule should be recomputed once before this (when the condition was True)+      countRes <- build theDb emptyStack [SubBranchRule]+      snd countRes `shouldBe` [1 :: Int]+   describe "applyWithoutDependency" $ do     it "does not track dependencies" $ do       db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do

@@ -4,6 +4,8 @@ {-# LANGUAGE TypeFamilies      #-} module Example where +import qualified Control.Concurrent            as C+import           Control.Monad.IO.Class        (liftIO) import           Development.IDE.Graph import           Development.IDE.Graph.Classes import           Development.IDE.Graph.Rule@@ -27,3 +29,36 @@ ruleBool = addRule $ \Rule _old _mode -> do     () <- apply1 Rule     return $ RunResult ChangedRecomputeDiff "" True+++data CondRule = CondRule+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)+type instance RuleResult CondRule = Bool+++ruleCond :: C.MVar Bool -> Rules ()+ruleCond mv = addRule $ \CondRule _old _mode -> do+    r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x)+    return $ RunResult ChangedRecomputeDiff "" r++data BranchedRule = BranchedRule+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)+type instance RuleResult BranchedRule = Int++ruleWithCond :: Rules ()+ruleWithCond = addRule $ \BranchedRule _old _mode -> do+    r <- apply1 CondRule+    if r then do+            _ <- apply1 SubBranchRule+            return $ RunResult ChangedRecomputeDiff "" (1 :: Int)+         else+            return $ RunResult ChangedRecomputeDiff "" (2 :: Int)++data SubBranchRule = SubBranchRule+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)+type instance RuleResult SubBranchRule = Int++ruleSubBranch :: C.MVar Int -> Rules ()+ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do+    r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x)+    return $ RunResult ChangedRecomputeDiff "" r