Implement cycle detection in hls-graph

.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

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

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

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
 
 

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

hls-graph/hls-graph.cabal

@@ -104,3 +104,33 @@ 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:
+    ActionSpec
+    DatabaseSpec
+    Example
+    RulesSpec
+    Spec
+
+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts
+  build-depends:
+    , base
+    , containers
+    , directory
+    , extra
+    , filepath
+    , hls-graph
+    , hspec
+    , stm
+    , stm-containers
+    , tasty
+    , tasty-hspec
+    , tasty-hunit
+    , tasty-rerun
+    , text
+  build-tool-depends: hspec-discover:hspec-discover -any

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,

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -4,7 +4,7 @@
 module Development.IDE.Graph.Database(
     ShakeDatabase,
     ShakeValue,
-    shakeOpenDatabase,
+    shakeNewDatabase,
     shakeRunDatabase,
     shakeRunDatabaseForKeys,
     shakeProfileDatabase,
@@ -23,22 +23,18 @@ 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
 
-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
     (theRules, actions) <- runRules extra rules
     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 +58,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 ()

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)]

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
@@ -165,7 +170,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)

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

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 ()