hls-graph 2.8.0.0 → 2.9.0.0

raw patch · 7 files changed

+165/−63 lines, 7 filesdep ~tasty-hspecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: tasty-hspec

API changes (from Hackage documentation)

Files

• hls-graph.cabal +2/−2
• src/Development/IDE/Graph/Internal/Database.hs +35/−16
• src/Development/IDE/Graph/Internal/Profile.hs +5/−1
• src/Development/IDE/Graph/Internal/Types.hs +17/−5
• test/ActionSpec.hs +59/−26
• test/DatabaseSpec.hs +31/−7
• test/Example.hs +16/−6

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               hls-graph-version:            2.8.0.0+version:            2.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>@@ -136,7 +136,7 @@     , stm     , stm-containers     , tasty-    , tasty-hspec+    , tasty-hspec >= 1.2     , tasty-rerun    build-tool-depends: hspec-discover:hspec-discover

@@ -2,12 +2,13 @@ -- has the constraints we need on it when we get it out. {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE CPP                #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE RecordWildCards    #-} {-# LANGUAGE TypeFamilies       #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where+module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where  import           Prelude                              hiding (unzip) @@ -27,7 +28,6 @@ import           Data.Either import           Data.Foldable                        (for_, traverse_) import           Data.IORef.Extra-import           Data.List.NonEmpty                   (unzip) import           Data.Maybe import           Data.Traversable                     (for) import           Data.Tuple.Extra@@ -42,7 +42,13 @@ import           System.IO.Unsafe import           System.Time.Extra                    (duration, sleep) +#if MIN_VERSION_base(4,19,0)+import           Data.Functor                         (unzip)+#else+import           Data.List.NonEmpty                   (unzip)+#endif + newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do     databaseStep <- newTVarIO $ Step 0@@ -133,6 +139,9 @@                 waitAll                 pure results ++-- | isDirty+-- only dirty when it's build time is older than the changed time of one of its dependencies isDirty :: Foldable t => Result -> t (a, Result) -> Bool isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) @@ -143,31 +152,31 @@ -- * 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 :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result refreshDeps visited db stack key result = \case     -- no more deps to refresh-    [] -> pure $ compute db stack key RunDependenciesSame (Just result)+    [] -> liftIO $ 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)+                then 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+            Right iores -> do+                res <- liftIO iores                 if isDirty result res-                    then compute db stack key RunDependenciesChanged (Just result)-                    else join $ runAIO $ refreshDeps newVisited db stack key result deps+                    then liftIO $ compute db stack key RunDependenciesChanged (Just result)+                    else refreshDeps newVisited db stack key result deps  -- | Refresh a key: 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 deps}) -> refreshDeps mempty db stack key me (reverse deps)+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps)     (Right stack, _) ->         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result @@ -179,14 +188,22 @@     deps <- newIORef UnknownDeps     (execution, RunResult{..}) <-         duration $ runReaderT (fromAction act) $ SAction db deps stack-    built <- readTVarIO databaseStep+    curStep <- readTVarIO databaseStep     deps <- readIORef deps-    let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result-        built' = if runChanged /= ChangedNothing then built else changed-        -- only update the deps when the rule ran with changes+    let lastChanged = maybe curStep resultChanged result+    let lastBuild = maybe curStep resultBuilt result+    -- changed time is always older than or equal to build time+    let (changed, built) =  case runChanged of+            -- some thing changed+            ChangedRecomputeDiff -> (curStep, curStep)+            -- recomputed is the same+            ChangedRecomputeSame -> (lastChanged, curStep)+            -- nothing changed+            ChangedNothing       -> (lastChanged, lastBuild)+    let -- only update the deps when the rule ran with changes         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps         previousDeps= maybe UnknownDeps resultDeps result-    let res = Result runValue built' changed built actualDeps execution runStore+    let res = Result runValue built changed curStep actualDeps execution runStore     case getResultDepsDefault mempty actualDeps of         deps | not (nullKeySet deps)             && runChanged /= ChangedNothing@@ -200,7 +217,9 @@                     (getResultDepsDefault mempty previousDeps)                     deps         _ -> pure ()-    atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues+    atomicallyNamed "compute and run hook" $ do+        runHook+        SMap.focus (updateStatus $ Clean res) key databaseValues     pure res  updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()

@@ -13,7 +13,7 @@ import           Data.Char import           Data.Dynamic                            (toDyn) import qualified Data.HashMap.Strict                     as Map-import           Data.List                               (dropWhileEnd, foldl',+import           Data.List                               (dropWhileEnd,                                                           intercalate,                                                           partition, sort,                                                           sortBy)@@ -32,6 +32,10 @@ import           System.FilePath import           System.IO.Unsafe                        (unsafePerformIO) import           System.Time.Extra                       (Seconds)++#if !MIN_VERSION_base(4,20,0)+import           Data.List                               (foldl')+#endif  #ifdef FILE_EMBED import           Data.FileEmbed

@@ -5,6 +5,8 @@  module Development.IDE.Graph.Internal.Types where +import           Control.Concurrent.STM             (STM)+import           Control.Monad                      ((>=>)) import           Control.Monad.Catch import           Control.Monad.IO.Class import           Control.Monad.Trans.Reader@@ -77,13 +79,17 @@ getDatabase :: Action Database getDatabase = Action $ asks actionDatabase +-- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running.+waitForDatabaseRunningKeysAction :: Action ()+waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys+ --------------------------------------------------------------------- -- DATABASE  data ShakeDatabase = ShakeDatabase !Int [Action ()] Database  newtype Step = Step Int-    deriving newtype (Eq,Ord,Hashable)+    deriving newtype (Eq,Ord,Hashable,Show)  --------------------------------------------------------------------- -- Keys@@ -109,6 +115,9 @@     databaseValues :: !(Map Key KeyDetails)     } +waitForDatabaseRunningKeys :: Database -> IO ()+waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd)+ getDatabaseValues :: Database -> IO [(Key, Status)] getDatabaseValues = atomically                   . (fmap.fmap) (second keyStatus)@@ -135,6 +144,10 @@ getResult (Dirty m_re)         = m_re getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result +waitRunning :: Status -> IO ()+waitRunning Running{..} = runningWait+waitRunning _           = return ()+ data Result = Result {     resultValue     :: !Value,     resultBuilt     :: !Step, -- ^ the step when it was last recomputed@@ -186,7 +199,6 @@ -- | How the output of a rule has changed. data RunChanged     = ChangedNothing -- ^ Nothing has changed.-    | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).     | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.     | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.       deriving (Eq,Show,Generic)@@ -202,10 +214,10 @@         -- ^ The value to store in the Shake database.     ,runValue   :: value         -- ^ The value to return from 'Development.Shake.Rule.apply'.+    ,runHook    :: STM ()+        -- ^ The hook to run at the end of the build in the same transaction+        -- when the key is marked as clean.     } deriving Functor--instance NFData value => NFData (RunResult value) where-    rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3  --------------------------------------------------------------------- -- EXCEPTIONS

@@ -3,11 +3,14 @@  module ActionSpec where +import           Control.Concurrent                      (MVar, readMVar) import qualified Control.Concurrent                      as C import           Control.Concurrent.STM+import           Control.Monad.IO.Class                  (MonadIO (..)) import           Development.IDE.Graph                   (shakeOptions) import           Development.IDE.Graph.Database          (shakeNewDatabase,-                                                          shakeRunDatabase)+                                                          shakeRunDatabase,+                                                          shakeRunDatabaseForKeys) import           Development.IDE.Graph.Internal.Database (build, incDatabase) import           Development.IDE.Graph.Internal.Key import           Development.IDE.Graph.Internal.Types@@ -16,15 +19,50 @@ import qualified StmContainers.Map                       as STM import           Test.Hspec ++ spec :: Spec spec = do+  describe "apply1" $ it "Test build update, Buggy dirty mechanism in hls-graph #4237" $ do+    let ruleStep1 :: MVar Int -> Rules ()+        ruleStep1 m = addRule $ \CountRule _old mode -> do+            -- depends on ruleSubBranch, it always changed if dirty+            _ :: Int <- apply1 SubBranchRule+            let r = 1+            case mode of+                -- it update the built step+                RunDependenciesChanged -> do+                    _ <- liftIO $ C.modifyMVar m $ \x -> return (x+1, x)+                    return $ RunResult ChangedRecomputeSame "" r (return ())+                -- this won't update the built step+                RunDependenciesSame ->+                    return $ RunResult ChangedNothing "" r (return ())+    count <- C.newMVar 0+    count1 <- C.newMVar 0+    db <- shakeNewDatabase shakeOptions $ do+      ruleSubBranch count+      ruleStep1 count1+    -- bootstrapping the database+    _ <- shakeRunDatabase db $ pure $ apply1 CountRule -- count = 1+    let child = newKey SubBranchRule+    let parent = newKey CountRule+    -- instruct to RunDependenciesChanged then CountRule should be recomputed+    -- result should be changed 0, build 1+    _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2+    -- since child changed = parent build+    -- instruct to RunDependenciesSame then CountRule should not be recomputed+    -- result should be changed 0, build 1+    _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2+    -- invariant child changed = parent build should remains after RunDependenciesSame+    -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238+    _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2+    c1 <- readMVar count1+    c1 `shouldBe` 2   describe "apply1" $ do     it "computes a rule with no dependencies" $ do-      db <- shakeNewDatabase shakeOptions $ do-        ruleUnit+      db <- shakeNewDatabase shakeOptions ruleUnit       res <- shakeRunDatabase db $-        pure $ do-          apply1 (Rule @())+        pure $ apply1 (Rule @())       res `shouldBe` [()]     it "computes a rule with one dependency" $ do       db <- shakeNewDatabase shakeOptions $ do@@ -38,8 +76,7 @@         ruleBool       let theKey = Rule @Bool       res <- shakeRunDatabase db $-        pure $ do-          apply1 theKey+        pure $ apply1 theKey       res `shouldBe` [True]       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb       resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (Rule @())]@@ -49,14 +86,12 @@         ruleBool       let theKey = Rule @Bool       res <- shakeRunDatabase db $-        pure $ do-          apply1 theKey+        pure $ apply1 theKey       res `shouldBe` [True]       Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues-      keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey)+      keyReverseDeps `shouldBe` singletonKeySet (newKey theKey)     it "rethrows exceptions" $ do-      db <- shakeNewDatabase shakeOptions $ do-        addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"+      db <- shakeNewDatabase shakeOptions $ 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@@ -81,18 +116,16 @@       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-        ruleUnit-        addRule $ \Rule _old _mode -> do-            [()] <- applyWithoutDependency [Rule]-            return $ RunResult ChangedRecomputeDiff "" True+  describe "applyWithoutDependency" $ it "does not track dependencies" $ do+    db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+      ruleUnit+      addRule $ \Rule _old _mode -> do+          [()] <- applyWithoutDependency [Rule]+          return $ RunResult ChangedRecomputeDiff "" True $ return () -      let theKey = Rule @Bool-      res <- shakeRunDatabase db $-        pure $ do-          applyWithoutDependency [theKey]-      res `shouldBe` [[True]]-      Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb-      resultDeps res `shouldBe` UnknownDeps+    let theKey = Rule @Bool+    res <- shakeRunDatabase db $+      pure $ applyWithoutDependency [theKey]+    res `shouldBe` [[True]]+    Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb+    resultDeps res `shouldBe` UnknownDeps

@@ -2,16 +2,18 @@  module DatabaseSpec where -import           Development.IDE.Graph                 (shakeOptions)-import           Development.IDE.Graph.Database        (shakeNewDatabase,-                                                        shakeRunDatabase)-import           Development.IDE.Graph.Internal.Action (apply1)-import           Development.IDE.Graph.Internal.Rules  (addRule)+import           Development.IDE.Graph                   (newKey, shakeOptions)+import           Development.IDE.Graph.Database          (shakeNewDatabase,+                                                          shakeRunDatabase)+import           Development.IDE.Graph.Internal.Action   (apply1)+import           Development.IDE.Graph.Internal.Database (compute, incDatabase)+import           Development.IDE.Graph.Internal.Rules    (addRule) import           Development.IDE.Graph.Internal.Types import           Example-import           System.Time.Extra                     (timeout)+import           System.Time.Extra                       (timeout) import           Test.Hspec + spec :: Spec spec = do     describe "Evaluation" $ do@@ -20,6 +22,28 @@                 ruleBool                 addRule $ \Rule _old _mode -> do                     True <- apply1 (Rule @Bool)-                    return $ RunResult ChangedRecomputeDiff "" ()+                    return $ RunResult ChangedRecomputeDiff "" () (return ())             let res = shakeRunDatabase db $ pure $ apply1 (Rule @())             timeout 1 res `shouldThrow` \StackException{} -> True++    describe "compute" $ do+      it "build step and changed step updated correctly" $ do+        (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+          ruleStep++        let k = newKey $ Rule @()+        -- ChangedRecomputeSame+        r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing+        incDatabase theDb Nothing+        -- ChangedRecomputeSame+        r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1)+        incDatabase theDb Nothing+        -- changed Nothing+        Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2)+        rc1 `shouldBe` Step 0+        rc2 `shouldBe` Step 0+        rc3 `shouldBe` Step 0++        rb1 `shouldBe` Step 0+        rb2 `shouldBe` Step 1+        rb3 `shouldBe` Step 1

@@ -20,15 +20,21 @@  type instance RuleResult (Rule a) = a +ruleStep :: Rules ()+ruleStep = addRule $ \(Rule :: Rule ()) _old mode -> do+    case mode of+        RunDependenciesChanged -> return $ RunResult ChangedRecomputeSame "" () (return ())+        RunDependenciesSame -> return $ RunResult ChangedNothing "" () (return ())+ ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do-    return $ RunResult ChangedRecomputeDiff "" ()+    return $ RunResult ChangedRecomputeDiff "" () (return ())  -- | Depends on Rule @() ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do     () <- apply1 Rule-    return $ RunResult ChangedRecomputeDiff "" True+    return $ RunResult ChangedRecomputeDiff "" True (return ())   data CondRule = CondRule@@ -39,7 +45,7 @@ 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+    return $ RunResult ChangedRecomputeDiff "" r (return ())  data BranchedRule = BranchedRule     deriving (Eq, Generic, Hashable, NFData, Show, Typeable)@@ -50,9 +56,9 @@     r <- apply1 CondRule     if r then do             _ <- apply1 SubBranchRule-            return $ RunResult ChangedRecomputeDiff "" (1 :: Int)+            return $ RunResult ChangedRecomputeDiff "" (1 :: Int) (return ())          else-            return $ RunResult ChangedRecomputeDiff "" (2 :: Int)+            return $ RunResult ChangedRecomputeDiff "" (2 :: Int) (return ())  data SubBranchRule = SubBranchRule     deriving (Eq, Generic, Hashable, NFData, Show, Typeable)@@ -61,4 +67,8 @@ 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+    return $ RunResult ChangedRecomputeDiff "" r (return ())++data CountRule = CountRule+    deriving (Eq, Generic, Hashable, NFData, Show, Typeable)+type instance RuleResult CountRule = Int