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