From ae221bdd08df0c0e507809815a178c47855eac49 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 07:28:13 +0000 Subject: [PATCH 1/8] hls-graph test suite scaffolding --- hls-graph/hls-graph.cabal | 27 +++++++++++++++++++++++++++ hls-graph/test/ActionSpec.hs | 8 ++++++++ hls-graph/test/DatabaseSpec.hs | 8 ++++++++ hls-graph/test/Main.hs | 7 +++++++ hls-graph/test/RulesSpec.hs | 8 ++++++++ hls-graph/test/Spec.hs | 1 + 6 files changed, 59 insertions(+) create mode 100644 hls-graph/test/ActionSpec.hs create mode 100644 hls-graph/test/DatabaseSpec.hs create mode 100644 hls-graph/test/Main.hs create mode 100644 hls-graph/test/RulesSpec.hs create mode 100644 hls-graph/test/Spec.hs diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index c31c3dd755..9c734fa005 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -104,3 +104,30 @@ library DataKinds KindSignatures TypeOperators + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: + DatabaseSpec + RulesSpec + ActionSpec + Spec + + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts + build-depends: + , base + , containers + , directory + , extra + , filepath + , hls-graph + , hspec + , tasty + , tasty-hspec + , tasty-hunit + , tasty-rerun + , text + build-tool-depends: hspec-discover:hspec-discover -any diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs new file mode 100644 index 0000000000..409da5918b --- /dev/null +++ b/hls-graph/test/ActionSpec.hs @@ -0,0 +1,8 @@ +module ActionSpec where + +import Test.Hspec + +spec :: Spec +spec = do + describe "" $ do + pure () diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs new file mode 100644 index 0000000000..028cb023b2 --- /dev/null +++ b/hls-graph/test/DatabaseSpec.hs @@ -0,0 +1,8 @@ +module DatabaseSpec where + +import Test.Hspec + +spec :: Spec +spec = do + describe "" $ do + pure () diff --git a/hls-graph/test/Main.hs b/hls-graph/test/Main.hs new file mode 100644 index 0000000000..452f6208ae --- /dev/null +++ b/hls-graph/test/Main.hs @@ -0,0 +1,7 @@ +import qualified Spec +import Test.Tasty +import Test.Tasty.Hspec +import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun) + +main :: IO () +main = testSpecs Spec.spec >>= defaultMainWithRerun . testGroup "tactics" diff --git a/hls-graph/test/RulesSpec.hs b/hls-graph/test/RulesSpec.hs new file mode 100644 index 0000000000..cdea145aa5 --- /dev/null +++ b/hls-graph/test/RulesSpec.hs @@ -0,0 +1,8 @@ +module RulesSpec where + +import Test.Hspec + +spec :: Spec +spec = do + describe "" $ do + pure () diff --git a/hls-graph/test/Spec.hs b/hls-graph/test/Spec.hs new file mode 100644 index 0000000000..5416ef6a86 --- /dev/null +++ b/hls-graph/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} From d606084a3aea609431b4235d8a7ba4d7880b0552 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 07:52:01 +0000 Subject: [PATCH 2/8] clean ups --- ghcide/exe/Main.hs | 2 -- ghcide/src/Development/IDE/Core/Rules.hs | 10 +--------- ghcide/src/Development/IDE/Core/Shake.hs | 9 +++------ ghcide/src/Development/IDE/Types/Options.hs | 12 +----------- hls-graph/src/Development/IDE/Graph.hs | 2 +- hls-graph/src/Development/IDE/Graph/Database.hs | 12 ++++-------- .../src/Development/IDE/Graph/Internal/Options.hs | 5 +---- .../src/Development/IDE/Graph/Internal/Rules.hs | 1 - src/Ide/Main.hs | 3 --- 9 files changed, 11 insertions(+), 45 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index d3bfc648a5..de5f5f22b8 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -17,7 +17,6 @@ import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Tracing (withTelemetryLogger) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Logger (Logger (Logger), @@ -128,7 +127,6 @@ main = withTelemetryLogger $ \telemetryLogger -> do in defOptions { optShakeProfiling = argsShakeProfiling , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e3aebd218d..74cd92f8bf 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -717,15 +717,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do use_ GetModificationTime nfp mapM_ addDependency deps - opts <- getIdeOptions - let cutoffHash = - case optShakeFiles opts of - -- optShakeFiles is only set in the DAML case. - -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915 - Just {} -> "" - -- Hash the HscEnvEq returned so cutoff if it didn't change - -- from last time - Nothing -> LBS.toStrict $ B.encode (hash (snd val)) + let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9f1796201e..546d61c55f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -135,7 +135,7 @@ import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, - shakeOpenDatabase, + shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule @@ -456,7 +456,6 @@ newtype ShakeSession = ShakeSession data IdeState = IdeState {shakeDb :: ShakeDatabase ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) } @@ -599,11 +598,10 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer -- Take one VFS snapshot at the start vfs <- atomically . newTVar =<< vfsSnapshot lspEnv pure ShakeExtras{..} - (shakeDbM, shakeClose) <- - shakeOpenDatabase + shakeDb <- + shakeNewDatabase opts { shakeExtra = newShakeExtra shakeExtras } rules - shakeDb <- shakeDbM shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} @@ -651,7 +649,6 @@ shakeShut IdeState{..} = do -- request so we first abort that. for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb - shakeClose progressStop $ progress shakeExtras diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index bfd11413fc..2c536026cd 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -17,7 +17,7 @@ module Development.IDE.Types.Options , IdeGhcSession(..) , OptHaddockParse(..) , ProgressReportingStyle(..) - ,optShakeFiles) where + ) where import qualified Data.Text as T import Data.Typeable @@ -85,13 +85,6 @@ data IdeOptions = IdeOptions -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed } -optShakeFiles :: IdeOptions -> Maybe FilePath -optShakeFiles opts - | value == defValue = Nothing - | otherwise = Just value - where - value = shakeFiles (optShakeOptions opts) - defValue = shakeFiles (optShakeOptions $ defaultIdeOptions undefined) data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) @@ -127,9 +120,6 @@ defaultIdeOptions session = IdeOptions ,optExtensions = ["hs", "lhs"] ,optPkgLocationOpts = defaultIdePkgLocationOptions ,optShakeOptions = shakeOptions - {shakeThreads = 0 - ,shakeFiles = "/dev/null" - } ,optShakeProfiling = Nothing ,optOTMemoryProfiling = IdeOTMemoryProfiling False ,optReportProgress = IdeReportProgress False diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 9f70b9f61b..ce0711abaa 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -5,7 +5,7 @@ module Development.IDE.Graph( Key(..), actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration - ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra), + ShakeOptions(shakeAllowRedefineRules, shakeExtra), getShakeExtra, getShakeExtraRules, newShakeExtra, -- * Explicit parallelism parallel, diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 99f1879289..e53cb0fef6 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -4,7 +4,7 @@ module Development.IDE.Graph.Database( ShakeDatabase, ShakeValue, - shakeOpenDatabase, + shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, @@ -28,9 +28,6 @@ data ShakeDatabase = ShakeDatabase !Int [Action ()] Database -- Placeholder to be the 'extra' if the user doesn't set it data NonExportedType = NonExportedType -shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ()) -shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ()) - shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase shakeNewDatabase opts rules = do let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts @@ -38,7 +35,7 @@ shakeNewDatabase opts rules = do db <- newDatabase extra theRules pure $ ShakeDatabase (length actions) actions db -shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) +shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a] shakeRunDatabase = shakeRunDatabaseForKeys Nothing -- | Returns the set of dirty keys annotated with their age (in # of builds) @@ -62,11 +59,10 @@ shakeRunDatabaseForKeys -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] - -> IO ([a], [IO ()]) + -> IO [a] shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged - as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 - return (as, []) + fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs index df6b8b1711..db8bd4e161 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs @@ -5,16 +5,13 @@ import Data.Dynamic import Development.IDE.Graph.Internal.Types data ShakeOptions = ShakeOptions { - -- | Has no effect, kept only for api compatibility with Shake - shakeThreads :: Int, - shakeFiles :: FilePath, shakeExtra :: Maybe Dynamic, shakeAllowRedefineRules :: Bool, shakeTimings :: Bool } shakeOptions :: ShakeOptions -shakeOptions = ShakeOptions 0 ".shake" Nothing False False +shakeOptions = ShakeOptions Nothing False False getShakeExtra :: Typeable a => Action (Maybe a) getShakeExtra = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index a22f0c61ef..7470c0e33e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -21,7 +21,6 @@ import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@. --- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. type family RuleResult key -- = value action :: Action a -> Rules () diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index b50d4f0ce0..ff7752a4d8 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -20,7 +20,6 @@ import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Rules hiding (Log, logToPriority) import Development.IDE.Core.Tracing (withTelemetryLogger) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session @@ -139,7 +138,5 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling , Ghcide.optTesting = Ghcide.IdeTesting argsTesting - , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions) - {shakeThreads = argsThreads} } } From 034b4c0de2eb38aabdb848ff3bceea9a892fe3a2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 08:58:17 +0000 Subject: [PATCH 3/8] apply1 tests --- hls-graph/hls-graph.cabal | 5 +- .../src/Development/IDE/Graph/Database.hs | 1 - .../IDE/Graph/Internal/Database.hs | 2 +- .../Development/IDE/Graph/Internal/Types.hs | 3 ++ hls-graph/test/ActionSpec.hs | 51 ++++++++++++++++++- hls-graph/test/Example.hs | 31 +++++++++++ 6 files changed, 88 insertions(+), 5 deletions(-) create mode 100644 hls-graph/test/Example.hs diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 9c734fa005..0d813a4306 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -111,9 +111,10 @@ test-suite tests hs-source-dirs: test main-is: Main.hs other-modules: + ActionSpec DatabaseSpec + Example RulesSpec - ActionSpec Spec ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts @@ -125,6 +126,8 @@ test-suite tests , filepath , hls-graph , hspec + , stm + , stm-containers , tasty , tasty-hspec , tasty-hunit diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index e53cb0fef6..53406bc3dd 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -23,7 +23,6 @@ import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types -data ShakeDatabase = ShakeDatabase !Int [Action ()] Database -- Placeholder to be the 'extra' if the user doesn't set it data NonExportedType = NonExportedType diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index e83690e1c8..477f2b3621 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -165,7 +165,7 @@ compute db@Database{..} key mode result = do deps | not(null deps) && runChanged /= ChangedNothing -> do - void $ forkIO $ + void $ updateReverseDeps key db (getResultDepsDefault [] previousDeps) (HSet.fromList deps) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 0a1278f5d3..67d1b7ca0d 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -75,6 +75,8 @@ getDatabase = Action $ asks actionDatabase --------------------------------------------------------------------- -- DATABASE +data ShakeDatabase = ShakeDatabase !Int [Action ()] Database + newtype Step = Step Int deriving newtype (Eq,Ord,Hashable) @@ -144,6 +146,7 @@ data Result = Result { } data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key] + deriving (Eq, Show) getResultDepsDefault :: [Key] -> ResultDeps -> [Key] getResultDepsDefault _ (ResultDeps ids) = ids diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 409da5918b..ab613af74b 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -1,8 +1,55 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + module ActionSpec where +import Control.Concurrent.STM +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Rule +import Example +import qualified StmContainers.Map as STM import Test.Hspec spec :: Spec spec = do - describe "" $ do - pure () + describe "apply1" $ do + it "computes a rule with no dependencies" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleUnit + res <- shakeRunDatabase db $ + pure $ do + apply1 (Rule @()) + res `shouldBe` [()] + it "computes a rule with one dependency" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + res <- shakeRunDatabase db $ pure $ apply1 Rule + res `shouldBe` [True] + it "tracks direct dependencies" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + apply1 theKey + res `shouldBe` [True] + Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` ResultDeps [Key (Rule @())] + it "tracks reverse dependencies" $ do + db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + apply1 theKey + res `shouldBe` [True] + Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues + keyReverseDeps `shouldBe` [Key theKey] diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs new file mode 100644 index 0000000000..3903cbe32c --- /dev/null +++ b/hls-graph/test/Example.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Example where + +import Development.IDE.Graph +import Development.IDE.Graph.Rule +import Development.IDE.Graph.Classes +import GHC.Generics +import Type.Reflection (typeRep) + +data Rule a = Rule + deriving (Eq, Generic, Hashable, NFData) + +instance Typeable a => Show (Rule a) where + show Rule = show $ typeRep @a + +type instance RuleResult (Rule a) = a + +ruleUnit :: Rules () +ruleUnit = addRule $ \(Rule :: Rule ()) old mode -> do + return $ RunResult ChangedRecomputeDiff "" () + +-- | Depends on Rule @() +ruleBool :: Rules () +ruleBool = addRule $ \Rule old mode -> do + () <- apply1 Rule + return $ RunResult ChangedRecomputeDiff "" True From b121980909e7414c13d25f151ead9c28417acacb Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 14:40:10 +0000 Subject: [PATCH 4/8] cycle detection --- .../Development/IDE/Graph/Internal/Action.hs | 8 ++- .../IDE/Graph/Internal/Database.hs | 61 ++++++++++--------- .../Development/IDE/Graph/Internal/Types.hs | 55 ++++++++++++++++- hls-graph/test/ActionSpec.hs | 15 +++++ hls-graph/test/DatabaseSpec.hs | 25 +++++++- 5 files changed, 129 insertions(+), 35 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 891e3d0adf..b9e9a1b08f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -116,7 +116,8 @@ apply1 k = head <$> apply [k] apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] apply ks = do db <- Action $ asks actionDatabase - (is, vs) <- liftIO $ build db ks + stack <- Action $ asks actionStack + (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps liftIO $ modifyIORef ref (ResultDeps is <>) pure vs @@ -125,13 +126,14 @@ apply ks = do applyWithoutDependency :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] applyWithoutDependency ks = do db <- Action $ asks actionDatabase - (_, vs) <- liftIO $ build db ks + stack <- Action $ asks actionStack + (_, vs) <- liftIO $ build db stack ks pure vs runActions :: Database -> [Action a] -> IO [a] runActions db xs = do deps <- newIORef mempty - runReaderT (fromAction $ parallel xs) $ SAction db deps + runReaderT (fromAction $ parallel xs) $ SAction db deps emptyStack -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Action [(Key, Int)] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 477f2b3621..824abd14c4 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -77,10 +77,11 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> -- | Unwrap and build a list of keys in parallel build :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) - => Database -> [key] -> IO ([Key], [value]) -build db keys = do + => Database -> Stack -> [key] -> IO ([Key], [value]) +-- build _ st k | traceShow ("build", st, k) False = undefined +build db stack keys = do (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< - builder db (map Key keys) + builder db stack (map Key keys) pure (ids, map (asV . resultValue) vs) where asV :: Value -> value @@ -90,8 +91,9 @@ build db keys = do -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. builder - :: Database -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)])) -builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do + :: Database -> Stack -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)])) +-- builder _ st kk | traceShow ("builder", st,kk) False = undefined +builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do -- Things that I need to force before my results are ready toForce <- liftIO $ newTVarIO [] current <- liftIO $ readTVarIO databaseStep @@ -103,11 +105,13 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do status <- SMap.lookup id databaseValues val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of Clean r -> pure r - Running _ force val _ -> do + Running _ force val _ + | memberStack id stack -> throw $ StackException stack + | otherwise -> do modifyTVar' toForce (Wait force :) pure val Dirty s -> do - let act = run (refresh db id s) + let act = run (refresh db stack id s) (force, val) = splitIO (join act) SMap.focus (updateStatus $ Running current force val s) id databaseValues modifyTVar' toForce (Spawn force:) @@ -127,32 +131,33 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do -- * 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 -> Key -> Maybe Result -> AIO (IO Result) -refresh db key result@(Just me@Result{resultDeps = ResultDeps deps}) = do - res <- builder db deps - case res of - Left res -> - if isDirty res - then asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result - else pure $ compute db key RunDependenciesSame result - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores - let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame - compute db key mode result - where - isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) - -refresh db key result = - asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result - +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}) -> 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, _) -> + asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result -- | Compute a key. -compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result -compute db@Database{..} key mode result = do +compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result +-- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined +compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode deps <- newIORef UnknownDeps (execution, RunResult{..}) <- - duration $ runReaderT (fromAction act) $ SAction db deps + duration $ runReaderT (fromAction act) $ SAction db deps stack built <- readTVarIO databaseStep deps <- readIORef deps let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 67d1b7ca0d..5a37ade6a9 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -26,7 +26,7 @@ import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Dynamic import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet) +import Data.HashSet (HashSet, member) import Data.IORef import Data.Maybe import Data.Typeable @@ -36,6 +36,8 @@ import qualified ListT import StmContainers.Map (Map) import qualified StmContainers.Map as SMap import System.Time.Extra (Seconds) +import qualified Data.HashSet as Set +import Data.List (intercalate) unwrapDynamic :: forall a . Typeable a => Dynamic -> a @@ -66,7 +68,8 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a} data SAction = SAction { actionDatabase :: !Database, - actionDeps :: !(IORef ResultDeps) + actionDeps :: !(IORef ResultDeps), + actionStack :: !Stack } getDatabase :: Action Database @@ -203,6 +206,54 @@ data RunResult value = RunResult instance NFData value => NFData (RunResult value) where rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 +--------------------------------------------------------------------- +-- EXCEPTIONS + +data GraphException = forall e. Exception e => GraphException { + target :: String, -- ^ The key that was being built + stack :: [String], -- ^ The stack of keys that led to this exception + inner :: e -- ^ The underlying exception +} + deriving (Typeable, Exception) + +instance Show GraphException where + show GraphException{..} = unlines $ + ["GraphException: " ++ target] ++ + stack ++ + ["Inner exception: " ++ show inner] + +fromGraphException :: Typeable b => SomeException -> Maybe b +fromGraphException x = do + GraphException _ _ e <- fromException x + cast e + +--------------------------------------------------------------------- +-- CALL STACK + +data Stack = Stack [Key] !(HashSet Key) + +instance Show Stack where + show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk) + +newtype StackException = StackException Stack + deriving (Typeable, Show) + +instance Exception StackException where + fromException = fromGraphException + toException this@(StackException (Stack stack _)) = toException $ + GraphException (show$ last stack) (map show stack) this + +addStack :: Key -> Stack -> Either StackException Stack +addStack k (Stack ks is) + | k `member` is = Left $ StackException stack2 + | otherwise = Right stack2 + where stack2 = Stack (k:ks) (Set.insert k is) + +memberStack :: Key -> Stack -> Bool +memberStack k (Stack _ ks) = k `member` ks + +emptyStack :: Stack +emptyStack = Stack [] mempty --------------------------------------------------------------------- -- INSTANCES diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index ab613af74b..61fb2b5ea6 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module ActionSpec where @@ -14,6 +15,7 @@ import Development.IDE.Graph.Rule import Example import qualified StmContainers.Map as STM import Test.Hspec +import System.Time.Extra (timeout) spec :: Spec spec = do @@ -53,3 +55,16 @@ spec = do res `shouldBe` [True] Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues keyReverseDeps `shouldBe` [Key theKey] + it "rethrows exceptions" $ do + db <- shakeNewDatabase shakeOptions $ do + addRule $ \(Rule :: Rule ()) old mode -> error "boom" + let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + res `shouldThrow` anyErrorCall + it "detects cycles" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleBool + addRule $ \Rule old mode -> do + True <- apply1 (Rule @Bool) + return $ RunResult ChangedRecomputeDiff "" () + let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 028cb023b2..7ab812e612 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -1,8 +1,29 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module DatabaseSpec where +import Control.Concurrent.STM +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Rule +import Example +import qualified StmContainers.Map as STM import Test.Hspec +import System.Time.Extra (timeout) spec :: Spec spec = do - describe "" $ do - pure () + describe "Evaluation" $ do + it "detects cycles" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleBool + addRule $ \Rule old mode -> do + True <- apply1 (Rule @Bool) + return $ RunResult ChangedRecomputeDiff "" () + let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + timeout 1 res `shouldThrow` \StackException{} -> True From 539354faed3b137acb8825fe6a3d048955f4d396 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 15:10:26 +0000 Subject: [PATCH 5/8] fixup tests --- hls-graph/test/ActionSpec.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 61fb2b5ea6..57c1dcfae2 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -60,11 +60,15 @@ spec = do addRule $ \(Rule :: Rule ()) old mode -> error "boom" let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) res `shouldThrow` anyErrorCall - it "detects cycles" $ do - db <- shakeNewDatabase shakeOptions $ do + describe "applyWithoutDependency" $ do + it "does not track dependencies" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit ruleBool - addRule $ \Rule old mode -> do - True <- apply1 (Rule @Bool) - return $ RunResult ChangedRecomputeDiff "" () - let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) - timeout 1 res `shouldThrow` \StackException{} -> True + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + applyWithoutDependency [theKey] + res `shouldBe` [[True]] + Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` ResultDeps [] From d6be6ebb8f27ee49a89505d3459e42b32b70f8a9 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 15:40:57 +0000 Subject: [PATCH 6/8] fixup --- hls-test-utils/src/Test/Hls.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 02ece9efb4..e3459e0560 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -52,7 +52,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Main as IDEMain @@ -208,11 +207,10 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre ++ [Test.blockCommandDescriptor "block-command", Test.plugin] ++ plugins ideOptions = \config ghcSession -> - let defIdeOptions@IdeOptions{ optShakeOptions } = argsIdeOptions config ghcSession + let defIdeOptions = argsIdeOptions config ghcSession in defIdeOptions { optTesting = IdeTesting True , optCheckProject = pure False - , optShakeOptions = optShakeOptions{ shakeThreads = 2 } } server <- From e916423b8686765d7f9b26620f821463d99e20d0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 21:37:40 +0000 Subject: [PATCH 7/8] add to CI --- .github/workflows/test.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index a8e108b80e..ef4b57b3da 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -133,6 +133,10 @@ jobs: path: "**/.tasty-rerun-log*" key: v1-${{ runner.os }}-${{ matrix.ghc }}-test-log-${{ github.sha }} + - if: matrix.test + name: Test hls-graph + run: cabal test hls-graph --test-options="$TEST_OPTS" + - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory From fee0282ae9458995b421367617b4aad20e1391cd Mon Sep 17 00:00:00 2001 From: Pepe Iborra <pepeiborra@gmail.com> Date: Sun, 6 Mar 2022 21:50:21 +0000 Subject: [PATCH 8/8] fix applyWithoutDependencyTest --- hls-graph/test/ActionSpec.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 57c1dcfae2..952b6df241 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -64,11 +64,14 @@ spec = do it "does not track dependencies" $ do db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do ruleUnit - ruleBool + addRule $ \Rule old mode -> do + [()] <- applyWithoutDependency [Rule] + return $ RunResult ChangedRecomputeDiff "" True + let theKey = Rule @Bool res <- shakeRunDatabase db $ pure $ do applyWithoutDependency [theKey] res `shouldBe` [[True]] Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb - resultDeps res `shouldBe` ResultDeps [] + resultDeps res `shouldBe` UnknownDeps