Add ResultDepsTree to ResultDeps

soulomoon · soulomoon · commit 8a088638a8be · 2024-02-21T03:58:11.000+08:00
This introduce branching semantic to dependencies.
Then we are not running the wrong rules and can have early stop if
the branching rule failed
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -168,6 +168,9 @@ import GHC (mgModSummaries)
 
 #if MIN_VERSION_ghc(9,3,0)
 import qualified Data.IntMap as IM
+import Development.IDE.Graph.Internal.Action (insertDepsTree)
+import Development.IDE.Graph.Internal.Types (DepsTree(..), Value(..), unwrapDynamic)
+import Development.IDE.Types.Shake (toKey)
 #endif
 
 
@@ -973,8 +976,23 @@ generateCoreRule :: Recorder (WithPriority Log) -> Rules ()
 generateCoreRule recorder =
     define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True)
 
+
 getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
 getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do
+  let
+    tok :: forall k . ShakeValue k => k -> Key
+    tok k = toKey k f
+  insertDepsTree (DepsTree {
+        -- depsTreeNodeDeps = fromListKeySet [toKey GetModSummary f]
+        depsTreeNodeDeps = fromListKeySet []
+    -- -- condition to continue the tree
+        , depsTreeNodeCond = Q (IsFileOfInterest, f)
+    -- -- the continuation of the tree
+        , depsTreeContinuation = \case
+                (Shake.A (Shake.currentValue -> Just (IsFOI status))) -> DeptLeaf $ fromListKeySet [tok TypeCheck, tok GhcSessionDeps, tok GenerateCore, tok NeedsCompilation]
+                (Shake.A (Shake.currentValue -> Just NotFOI)) -> DeptLeaf $ fromListKeySet [tok GetModIfaceFromDiskAndIndex]
+                _ -> DeptLeaf mempty
+  })
   fileOfInterest <- use_ IsFileOfInterest f
   res <- case fileOfInterest of
     IsFOI status -> do
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
@@ -7,6 +7,7 @@ module Development.IDE.Graph.Internal.Action
 , actionCatch
 , actionFinally
 , alwaysRerun
+, insertDepsTree
 , apply1
 , apply
 , applyWithoutDependency
@@ -22,13 +23,16 @@ import           Control.Exception
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Reader
+import qualified Data.ByteString                         as BS
 import           Data.Foldable                           (toList)
 import           Data.Functor.Identity
+import qualified Data.HashMap.Strict                     as Map
 import           Data.IORef
+import           Data.Proxy
+import           Data.Typeable
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Database
 import           Development.IDE.Graph.Internal.Key
-import           Development.IDE.Graph.Internal.Rules    (RuleResult)
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
 
@@ -40,6 +44,11 @@ alwaysRerun = do
     ref <- Action $ asks actionDeps
     liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
 
+insertDepsTree :: DepsTree -> Action ()
+insertDepsTree v = do
+    ref <- Action $ asks actionDeps
+    liftIO $ modifyIORef ref (ResultDepsTree mempty v <>)
+
 -- No-op for now
 reschedule :: Double -> Action ()
 reschedule _ = pure ()
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -31,7 +31,7 @@ import           Data.List.NonEmpty                   (unzip)
 import           Data.Maybe
 import           Data.Traversable                     (for)
 import           Data.Tuple.Extra
-import           Debug.Trace                          (traceM)
+import           Debug.Trace                          (traceM, traceShow)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Rules
@@ -133,6 +133,35 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
                 waitAll
                 pure results
 
+isDirty :: Foldable t => Result -> t (a, Result) -> Bool
+isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
+
+refreshTree :: Bool -> Database -> Key -> Stack -> Result -> DepsTree -> AIO Result
+refreshTree dirty db key stack result (DeptLeaf deps) = do
+    -- insertDepsTree
+    res <- builder db stack (toListKeySet deps)
+    liftIO $ case res of
+        Left res -> do
+                if dirty || isDirty result res
+                    then compute db stack key RunDependenciesChanged (Just result)
+                    else compute db stack key RunDependenciesSame (Just result)
+        Right iores -> do
+            res <- iores
+            let mode = if isDirty result res then RunDependenciesChanged else RunDependenciesSame
+            compute db stack key mode (Just result)
+refreshTree dirty db key stack result (DepsTree deps cond depsTree) = do
+    res <- builder db stack (newKey cond:toListKeySet deps)
+    case res of
+        Left res@((resultValue . snd -> val):_) -> do
+                let newDirty = dirty || isDirty result res
+                refreshTree newDirty db key stack result (depsTree $ unwrapValue val)
+        Right iores -> liftIO $ do
+            res@((resultValue . snd -> val):_) <- iores
+            let newDirty = dirty || isDirty result res
+            runAIO $ refreshTree newDirty db key stack result (depsTree $ unwrapValue val)
+        _ -> error "refreshTree: impossible"
+
+
 -- | Refresh a key:
 --     * 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
@@ -141,17 +170,18 @@ 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 = ResultDepsTree _ depsTree}) ->
+        asyncWithCleanUp $ refreshTree False db key stack me depsTree
     (Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do
         res <- builder db stack deps
-        let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
         case res of
             Left res ->
-                if isDirty res
+                if isDirty me 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
+                let mode = if isDirty me res then RunDependenciesChanged else RunDependenciesSame
                 compute db stack key mode result
     (Right stack, _) ->
         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
@@ -173,7 +203,7 @@ compute db@Database{..} stack key mode result = do
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
     case getResultDepsDefault mempty actualDeps of
-        deps | not(nullKeySet deps)
+        deps | not (nullKeySet deps)
             && runChanged /= ChangedNothing
                     -> do
             -- IMPORTANT: record the reverse deps **before** marking the key Clean.
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
@@ -2,7 +2,6 @@
 -- has the constraints we need on it when we get it out.
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies    #-}
 
 module Development.IDE.Graph.Internal.Rules where
 
@@ -20,8 +19,6 @@ import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
 
--- | The type mapping between the @key@ or a rule and the resulting @value@.
-type family RuleResult key -- = value
 
 action :: Action a -> Rules ()
 action x = do
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeFamilies       #-}
 
 module Development.IDE.Graph.Internal.Types where
 
@@ -31,6 +32,9 @@ import           UnliftIO                           (MonadUnliftIO)
 import           Control.Applicative                (liftA2)
 #endif
 
+-- | The type mapping between the @key@ or a rule and the resulting @value@.
+type family RuleResult key -- = value
+
 unwrapDynamic :: forall a . Typeable a => Dynamic -> a
 unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x
     where msg = "unwrapDynamic failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++
@@ -92,6 +96,11 @@ newtype Step = Step Int
 
 newtype Value = Value Dynamic
 
+unwrapValue :: forall a . Typeable a => Value -> a
+unwrapValue (Value x) = fromMaybe (error msg) $ fromDynamic x
+    where msg = "unwrapValue failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++
+                ", but got " ++ show (dynTypeRep x)
+
 data KeyDetails = KeyDetails {
     keyStatus      :: !Status,
     keyReverseDeps :: !KeySet
@@ -144,25 +153,63 @@ data Result = Result {
     resultData      :: !BS.ByteString
     }
 
-data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet
-  deriving (Eq, Show)
+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet | ResultDepsTree !KeySet !DepsTree
+--   deriving (Eq, Show)
+
+data DepsTrees = DepsTrees {
+    depsTrees :: [DepsTree]
+    }
+
+instance Eq ResultDeps where
+    UnknownDeps == UnknownDeps                  = True
+    AlwaysRerunDeps ids == AlwaysRerunDeps ids' = ids == ids'
+    ResultDeps ids == ResultDeps ids'           = ids == ids'
+    ResultDepsTree ids _ == ResultDeps ids'     = ids == ids'
+    ResultDeps ids == ResultDepsTree ids' _     = ids == ids'
+    _ == _                                      = False
+
+instance Show ResultDeps where
+    show (ResultDeps ids) = "ResultDeps " ++ show ids
+    show (ResultDepsTree ids _) = "ResultDepsTree " ++ show ids ++ " " ++ "result"
+    show (AlwaysRerunDeps ids) = "AlwaysRerunDeps " ++ show ids
+    show UnknownDeps = "UnknownDeps"
+
+
+data DepsTree = forall key value .(RuleResult key ~ value, Typeable key, Hashable key, Show key, Typeable value) => DepsTree {
+    depsTreeNodeDeps     :: !KeySet,
+    -- condition to continue the tree
+    depsTreeNodeCond     :: !key,
+    -- the continuation of the tree
+    depsTreeContinuation :: !(value -> DepsTree)
+    } | DeptLeaf { depsTreeNodeDeps :: !KeySet}
+
+
+instance Semigroup DepsTrees where
+    DepsTrees a <> DepsTrees b = DepsTrees $ a <> b
 
 getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
-getResultDepsDefault _ (ResultDeps ids)      = ids
-getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
-getResultDepsDefault def UnknownDeps         = def
+getResultDepsDefault _ (ResultDeps ids)       = ids
+getResultDepsDefault _ (ResultDepsTree ids _)=ids
+getResultDepsDefault _ (AlwaysRerunDeps ids)  = ids
+getResultDepsDefault def UnknownDeps          = def
 
 mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
-mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids
-mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
-mapResultDeps _ UnknownDeps           = UnknownDeps
+mapResultDeps f (ResultDeps ids)       = ResultDeps $ f ids
+mapResultDeps f (ResultDepsTree ids _)=ResultDeps $ f ids
+mapResultDeps f (AlwaysRerunDeps ids)  = AlwaysRerunDeps $ f ids
+mapResultDeps _ UnknownDeps            = UnknownDeps
+
 
 instance Semigroup ResultDeps where
     UnknownDeps <> x = x
     x <> UnknownDeps = x
     AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault mempty x)
     x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault mempty x <> ids)
     ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')
+    ResultDeps ids <> ResultDepsTree ids' tree = ResultDepsTree (ids <> ids') tree
+    ResultDepsTree ids tree <> ResultDeps ids' = ResultDepsTree (ids <> ids') tree
+    ResultDepsTree ids tree <> ResultDepsTree ids' tree' = error "Semigroup ResultDepsTree: not implemented"
+
 
 instance Monoid ResultDeps where
     mempty = UnknownDeps
diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs
@@ -4,14 +4,15 @@
 module ActionSpec where
 
 import           Control.Concurrent.STM
-import           Development.IDE.Graph                (shakeOptions)
-import           Development.IDE.Graph.Database       (shakeNewDatabase,
-                                                       shakeRunDatabase)
+import           Development.IDE.Graph                   (shakeOptions)
+import           Development.IDE.Graph.Database
+import           Development.IDE.Graph.Internal.Database (build, incDatabase)
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
 import           Development.IDE.Graph.Rule
 import           Example
-import qualified StmContainers.Map                    as STM
+import           Extra                                   (sleep)
+import qualified StmContainers.Map                       as STM
 import           Test.Hspec
 
 spec :: Spec
@@ -57,6 +58,23 @@ spec = do
         addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
       let res = shakeRunDatabase db $ pure $ apply1 (Rule @())
       res `shouldThrow` anyErrorCall
+
+    it "computes a rule with dependency tree" $ do
+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
+        ruleUnit
+        ruleBool
+        ruleInt
+      res <- shakeRunDatabase db [apply1 Rule]
+      res `shouldBe` [True]
+      res0 <- build theDb emptyStack [Rule :: Rule Int]
+      print ()
+      print res0
+      snd res0 `shouldBe` [1 :: Int]
+      incDatabase theDb (Just [newKey (Rule :: Rule Bool)])
+      res1 <- build theDb emptyStack [Rule :: Rule Int]
+      print res1
+      snd res1 `shouldBe` [1 :: Int]
+
   describe "applyWithoutDependency" $ do
     it "does not track dependencies" $ do
       db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
@@ -66,9 +84,7 @@ spec = do
             return $ RunResult ChangedRecomputeDiff "" True
 
       let theKey = Rule @Bool
-      res <- shakeRunDatabase db $
-        pure $ do
-          applyWithoutDependency [theKey]
+      res <- shakeRunDatabase db $ pure $ do applyWithoutDependency [theKey]
       res `shouldBe` [[True]]
       Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
       resultDeps res `shouldBe` UnknownDeps
diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs
@@ -1,14 +1,22 @@
 {-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NoPolyKinds       #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies      #-}
 module Example where
 
+import           Control.Monad.IO.Class                (liftIO)
+import           Data.Time
 import           Development.IDE.Graph
 import           Development.IDE.Graph.Classes
+import           Development.IDE.Graph.Internal.Action (insertDepsTree)
+import           Development.IDE.Graph.Internal.Types  (DepsTree (..))
 import           Development.IDE.Graph.Rule
 import           GHC.Generics
-import           Type.Reflection               (typeRep)
+import           Type.Reflection                       (typeRep)
+
+
+
 
 data Rule a = Rule
     deriving (Eq, Generic, Hashable, NFData)
@@ -26,4 +34,29 @@ ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do
 ruleBool :: Rules ()
 ruleBool = addRule $ \Rule _old _mode -> do
     () <- apply1 Rule
-    return $ RunResult ChangedRecomputeDiff "" True
+    crt <- liftIO $ getCurrentTime
+    let currentTimeAsInt = round (utctDayTime crt) :: Int
+    -- return $ RunResult ChangedRecomputeDiff "" $ even currentTimeAsInt
+    return $ RunResult ChangedRecomputeDiff "" $ True
+
+
+depTree = DepsTree {
+         -- depsTreeNodeDeps = fromListKeySet [toKey GetModSummary f]
+         depsTreeNodeDeps = fromListKeySet [newKey (Rule :: Rule ())]
+     -- -- condition to continue the tree
+         , depsTreeNodeCond = Rule :: Rule Bool
+     -- -- the continuation of the tree
+         , depsTreeContinuation = \case
+                 True -> DeptLeaf $ fromListKeySet []
+                 False -> DeptLeaf $ fromListKeySet [newKey (Rule :: Rule ())]
+     }
+
+-- | Depends on Rule @()
+ruleInt :: Rules ()
+ruleInt = addRule $ \Rule _old _mode -> do
+    insertDepsTree depTree
+    () <- apply1 Rule
+    b <- apply1 Rule
+    return $ if b
+        then RunResult ChangedRecomputeDiff "" (1 :: Int)
+        else RunResult ChangedRecomputeDiff "" 2
