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: 2.8.0.0 +version: 2.9.0.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at @@ -136,7 +136,7 @@ , stm , stm-containers , tasty - , tasty-hspec + , tasty-hspec >= 1.2 , tasty-rerun build-tool-depends: hspec-discover:hspec-discover 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 @@ -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 () 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 @@ -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 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 @@ -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 diff --git a/test/ActionSpec.hs b/test/ActionSpec.hs --- a/test/ActionSpec.hs +++ b/test/ActionSpec.hs @@ -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 diff --git a/test/DatabaseSpec.hs b/test/DatabaseSpec.hs --- a/test/DatabaseSpec.hs +++ b/test/DatabaseSpec.hs @@ -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 diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -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