Skip to content

Commit 8a08863

Browse files
soulomoonsoulomoon
committed
Add ResultDepsTree to ResultDeps
This introduce branching semantic to dependencies. Then we are not running the wrong rules and can have early stop if the branching rule failed
1 parent c8b286a commit 8a08863

File tree

7 files changed

+176
-26
lines changed

7 files changed

+176
-26
lines changed

‎ghcide/src/Development/IDE/Core/Rules.hs‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -168,6 +168,9 @@ import GHC (mgModSummaries)
168168

169169
#if MIN_VERSION_ghc(9,3,0)
170170
import qualified Data.IntMap as IM
171+
import Development.IDE.Graph.Internal.Action (insertDepsTree)
172+
import Development.IDE.Graph.Internal.Types (DepsTree(..), Value(..), unwrapDynamic)
173+
import Development.IDE.Types.Shake (toKey)
171174
#endif
172175

173176

@@ -973,8 +976,23 @@ generateCoreRule :: Recorder (WithPriority Log) -> Rules ()
973976
generateCoreRule recorder =
974977
define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True)
975978

979+
976980
getModIfaceRule :: Recorder (WithPriority Log) -> Rules ()
977981
getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do
982+
let
983+
tok :: forall k . ShakeValue k => k -> Key
984+
tok k = toKey k f
985+
insertDepsTree (DepsTree {
986+
-- depsTreeNodeDeps = fromListKeySet [toKey GetModSummary f]
987+
depsTreeNodeDeps = fromListKeySet []
988+
-- -- condition to continue the tree
989+
, depsTreeNodeCond = Q (IsFileOfInterest, f)
990+
-- -- the continuation of the tree
991+
, depsTreeContinuation = \case
992+
(Shake.A (Shake.currentValue -> Just (IsFOI status))) -> DeptLeaf $ fromListKeySet [tok TypeCheck, tok GhcSessionDeps, tok GenerateCore, tok NeedsCompilation]
993+
(Shake.A (Shake.currentValue -> Just NotFOI)) -> DeptLeaf $ fromListKeySet [tok GetModIfaceFromDiskAndIndex]
994+
_ -> DeptLeaf mempty
995+
})
978996
fileOfInterest <- use_ IsFileOfInterest f
979997
res <- case fileOfInterest of
980998
IsFOI status -> do

‎hls-graph/src/Development/IDE/Graph/Internal/Action.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Development.IDE.Graph.Internal.Action
77
, actionCatch
88
, actionFinally
99
, alwaysRerun
10+
, insertDepsTree
1011
, apply1
1112
, apply
1213
, applyWithoutDependency
@@ -22,13 +23,16 @@ import Control.Exception
2223
import Control.Monad.IO.Class
2324
import Control.Monad.Trans.Class
2425
import Control.Monad.Trans.Reader
26+
import qualified Data.ByteString as BS
2527
import Data.Foldable (toList)
2628
import Data.Functor.Identity
29+
import qualified Data.HashMap.Strict as Map
2730
import Data.IORef
31+
import Data.Proxy
32+
import Data.Typeable
2833
import Development.IDE.Graph.Classes
2934
import Development.IDE.Graph.Internal.Database
3035
import Development.IDE.Graph.Internal.Key
31-
import Development.IDE.Graph.Internal.Rules (RuleResult)
3236
import Development.IDE.Graph.Internal.Types
3337
import System.Exit
3438

@@ -40,6 +44,11 @@ alwaysRerun = do
4044
ref <- Action $ asks actionDeps
4145
liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
4246

47+
insertDepsTree :: DepsTree -> Action ()
48+
insertDepsTree v = do
49+
ref <- Action $ asks actionDeps
50+
liftIO $ modifyIORef ref (ResultDepsTree mempty v <>)
51+
4352
-- No-op for now
4453
reschedule :: Double -> Action ()
4554
reschedule _ = pure ()

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

Lines changed: 35 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,7 @@ import Data.List.NonEmpty (unzip)
3131
import Data.Maybe
3232
import Data.Traversable (for)
3333
import Data.Tuple.Extra
34-
import Debug.Trace (traceM)
34+
import Debug.Trace (traceM, traceShow)
3535
import Development.IDE.Graph.Classes
3636
import Development.IDE.Graph.Internal.Key
3737
import Development.IDE.Graph.Internal.Rules
@@ -133,6 +133,35 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
133133
waitAll
134134
pure results
135135

136+
isDirty :: Foldable t => Result -> t (a, Result) -> Bool
137+
isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
138+
139+
refreshTree :: Bool -> Database -> Key -> Stack -> Result -> DepsTree -> AIO Result
140+
refreshTree dirty db key stack result (DeptLeaf deps) = do
141+
-- insertDepsTree
142+
res <- builder db stack (toListKeySet deps)
143+
liftIO $ case res of
144+
Left res -> do
145+
if dirty || isDirty result res
146+
then compute db stack key RunDependenciesChanged (Just result)
147+
else compute db stack key RunDependenciesSame (Just result)
148+
Right iores -> do
149+
res <- iores
150+
let mode = if isDirty result res then RunDependenciesChanged else RunDependenciesSame
151+
compute db stack key mode (Just result)
152+
refreshTree dirty db key stack result (DepsTree deps cond depsTree) = do
153+
res <- builder db stack (newKey cond:toListKeySet deps)
154+
case res of
155+
Left res@((resultValue . snd -> val):_) -> do
156+
let newDirty = dirty || isDirty result res
157+
refreshTree newDirty db key stack result (depsTree $ unwrapValue val)
158+
Right iores -> liftIO $ do
159+
res@((resultValue . snd -> val):_) <- iores
160+
let newDirty = dirty || isDirty result res
161+
runAIO $ refreshTree newDirty db key stack result (depsTree $ unwrapValue val)
162+
_ -> error "refreshTree: impossible"
163+
164+
136165
-- | Refresh a key:
137166
-- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
138167
-- This assumes that the implementation will be a lookup
@@ -141,17 +170,18 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
141170
-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
142171
refresh db stack key result = case (addStack key stack, result) of
143172
(Left e, _) -> throw e
173+
(Right stack, Just me@Result{resultDeps = ResultDepsTree _ depsTree}) ->
174+
asyncWithCleanUp $ refreshTree False db key stack me depsTree
144175
(Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do
145176
res <- builder db stack deps
146-
let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
147177
case res of
148178
Left res ->
149-
if isDirty res
179+
if isDirty me res
150180
then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
151181
else pure $ compute db stack key RunDependenciesSame result
152182
Right iores -> asyncWithCleanUp $ liftIO $ do
153183
res <- iores
154-
let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame
184+
let mode = if isDirty me res then RunDependenciesChanged else RunDependenciesSame
155185
compute db stack key mode result
156186
(Right stack, _) ->
157187
asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
@@ -173,7 +203,7 @@ compute db@Database{..} stack key mode result = do
173203
previousDeps= maybe UnknownDeps resultDeps result
174204
let res = Result runValue built' changed built actualDeps execution runStore
175205
case getResultDepsDefault mempty actualDeps of
176-
deps | not(nullKeySet deps)
206+
deps | not (nullKeySet deps)
177207
&& runChanged /= ChangedNothing
178208
-> do
179209
-- IMPORTANT: record the reverse deps **before** marking the key Clean.

‎hls-graph/src/Development/IDE/Graph/Internal/Rules.hs‎

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,6 @@
22
-- has the constraints we need on it when we get it out.
33
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
44
{-# LANGUAGE RecordWildCards #-}
5-
{-# LANGUAGE TypeFamilies #-}
65

76
module Development.IDE.Graph.Internal.Rules where
87

@@ -20,8 +19,6 @@ import Development.IDE.Graph.Classes
2019
import Development.IDE.Graph.Internal.Key
2120
import Development.IDE.Graph.Internal.Types
2221

23-
-- | The type mapping between the @key@ or a rule and the resulting @value@.
24-
type family RuleResult key -- = value
2522

2623
action :: Action a -> Rules ()
2724
action x = do

‎hls-graph/src/Development/IDE/Graph/Internal/Types.hs‎

Lines changed: 55 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveAnyClass #-}
33
{-# LANGUAGE DerivingStrategies #-}
44
{-# LANGUAGE RecordWildCards #-}
5+
{-# LANGUAGE TypeFamilies #-}
56

67
module Development.IDE.Graph.Internal.Types where
78

@@ -31,6 +32,9 @@ import UnliftIO (MonadUnliftIO)
3132
import Control.Applicative (liftA2)
3233
#endif
3334

35+
-- | The type mapping between the @key@ or a rule and the resulting @value@.
36+
type family RuleResult key -- = value
37+
3438
unwrapDynamic :: forall a . Typeable a => Dynamic -> a
3539
unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x
3640
where msg = "unwrapDynamic failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++
@@ -92,6 +96,11 @@ newtype Step = Step Int
9296

9397
newtype Value = Value Dynamic
9498

99+
unwrapValue :: forall a . Typeable a => Value -> a
100+
unwrapValue (Value x) = fromMaybe (error msg) $ fromDynamic x
101+
where msg = "unwrapValue failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++
102+
", but got " ++ show (dynTypeRep x)
103+
95104
data KeyDetails = KeyDetails {
96105
keyStatus :: !Status,
97106
keyReverseDeps :: !KeySet
@@ -144,25 +153,63 @@ data Result = Result {
144153
resultData :: !BS.ByteString
145154
}
146155

147-
data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet
148-
deriving (Eq, Show)
156+
data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet | ResultDepsTree !KeySet !DepsTree
157+
-- deriving (Eq, Show)
158+
159+
data DepsTrees = DepsTrees {
160+
depsTrees :: [DepsTree]
161+
}
162+
163+
instance Eq ResultDeps where
164+
UnknownDeps == UnknownDeps = True
165+
AlwaysRerunDeps ids == AlwaysRerunDeps ids' = ids == ids'
166+
ResultDeps ids == ResultDeps ids' = ids == ids'
167+
ResultDepsTree ids _ == ResultDeps ids' = ids == ids'
168+
ResultDeps ids == ResultDepsTree ids' _ = ids == ids'
169+
_ == _ = False
170+
171+
instance Show ResultDeps where
172+
show (ResultDeps ids) = "ResultDeps " ++ show ids
173+
show (ResultDepsTree ids _) = "ResultDepsTree " ++ show ids ++ " " ++ "result"
174+
show (AlwaysRerunDeps ids) = "AlwaysRerunDeps " ++ show ids
175+
show UnknownDeps = "UnknownDeps"
176+
177+
178+
data DepsTree = forall key value .(RuleResult key ~ value, Typeable key, Hashable key, Show key, Typeable value) => DepsTree {
179+
depsTreeNodeDeps :: !KeySet,
180+
-- condition to continue the tree
181+
depsTreeNodeCond :: !key,
182+
-- the continuation of the tree
183+
depsTreeContinuation :: !(value -> DepsTree)
184+
} | DeptLeaf { depsTreeNodeDeps :: !KeySet}
185+
186+
187+
instance Semigroup DepsTrees where
188+
DepsTrees a <> DepsTrees b = DepsTrees $ a <> b
149189

150190
getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
151-
getResultDepsDefault _ (ResultDeps ids) = ids
152-
getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
153-
getResultDepsDefault def UnknownDeps = def
191+
getResultDepsDefault _ (ResultDeps ids) = ids
192+
getResultDepsDefault _ (ResultDepsTree ids _)=ids
193+
getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
194+
getResultDepsDefault def UnknownDeps = def
154195

155196
mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
156-
mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids
157-
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
158-
mapResultDeps _ UnknownDeps = UnknownDeps
197+
mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids
198+
mapResultDeps f (ResultDepsTree ids _)=ResultDeps $ f ids
199+
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
200+
mapResultDeps _ UnknownDeps = UnknownDeps
201+
159202

160203
instance Semigroup ResultDeps where
161204
UnknownDeps <> x = x
162205
x <> UnknownDeps = x
163206
AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault mempty x)
164207
x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault mempty x <> ids)
165208
ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')
209+
ResultDeps ids <> ResultDepsTree ids' tree = ResultDepsTree (ids <> ids') tree
210+
ResultDepsTree ids tree <> ResultDeps ids' = ResultDepsTree (ids <> ids') tree
211+
ResultDepsTree ids tree <> ResultDepsTree ids' tree' = error "Semigroup ResultDepsTree: not implemented"
212+
166213

167214
instance Monoid ResultDeps where
168215
mempty = UnknownDeps

‎hls-graph/test/ActionSpec.hs‎

Lines changed: 23 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -4,14 +4,15 @@
44
module ActionSpec where
55

66
import Control.Concurrent.STM
7-
import Development.IDE.Graph (shakeOptions)
8-
import Development.IDE.Graph.Database (shakeNewDatabase,
9-
shakeRunDatabase)
7+
import Development.IDE.Graph (shakeOptions)
8+
import Development.IDE.Graph.Database
9+
import Development.IDE.Graph.Internal.Database (build, incDatabase)
1010
import Development.IDE.Graph.Internal.Key
1111
import Development.IDE.Graph.Internal.Types
1212
import Development.IDE.Graph.Rule
1313
import Example
14-
import qualified StmContainers.Map as STM
14+
import Extra (sleep)
15+
import qualified StmContainers.Map as STM
1516
import Test.Hspec
1617

1718
spec :: Spec
@@ -57,6 +58,23 @@ spec = do
5758
addRule $ \(Rule :: Rule ()) _old _mode -> error "boom"
5859
let res = shakeRunDatabase db $ pure $ apply1 (Rule @())
5960
res `shouldThrow` anyErrorCall
61+
62+
it "computes a rule with dependency tree" $ do
63+
db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
64+
ruleUnit
65+
ruleBool
66+
ruleInt
67+
res <- shakeRunDatabase db [apply1 Rule]
68+
res `shouldBe` [True]
69+
res0 <- build theDb emptyStack [Rule :: Rule Int]
70+
print ()
71+
print res0
72+
snd res0 `shouldBe` [1 :: Int]
73+
incDatabase theDb (Just [newKey (Rule :: Rule Bool)])
74+
res1 <- build theDb emptyStack [Rule :: Rule Int]
75+
print res1
76+
snd res1 `shouldBe` [1 :: Int]
77+
6078
describe "applyWithoutDependency" $ do
6179
it "does not track dependencies" $ do
6280
db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do
@@ -66,9 +84,7 @@ spec = do
6684
return $ RunResult ChangedRecomputeDiff "" True
6785

6886
let theKey = Rule @Bool
69-
res <- shakeRunDatabase db $
70-
pure $ do
71-
applyWithoutDependency [theKey]
87+
res <- shakeRunDatabase db $ pure $ do applyWithoutDependency [theKey]
7288
res `shouldBe` [[True]]
7389
Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb
7490
resultDeps res `shouldBe` UnknownDeps

‎hls-graph/test/Example.hs‎

Lines changed: 35 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,22 @@
11
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE NoPolyKinds #-}
34
{-# LANGUAGE OverloadedStrings #-}
45
{-# LANGUAGE TypeFamilies #-}
56
module Example where
67

8+
import Control.Monad.IO.Class (liftIO)
9+
import Data.Time
710
import Development.IDE.Graph
811
import Development.IDE.Graph.Classes
12+
import Development.IDE.Graph.Internal.Action (insertDepsTree)
13+
import Development.IDE.Graph.Internal.Types (DepsTree (..))
914
import Development.IDE.Graph.Rule
1015
import GHC.Generics
11-
import Type.Reflection (typeRep)
16+
import Type.Reflection (typeRep)
17+
18+
19+
1220

1321
data Rule a = Rule
1422
deriving (Eq, Generic, Hashable, NFData)
@@ -26,4 +34,29 @@ ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do
2634
ruleBool :: Rules ()
2735
ruleBool = addRule $ \Rule _old _mode -> do
2836
() <- apply1 Rule
29-
return $ RunResult ChangedRecomputeDiff "" True
37+
crt <- liftIO $ getCurrentTime
38+
let currentTimeAsInt = round (utctDayTime crt) :: Int
39+
-- return $ RunResult ChangedRecomputeDiff "" $ even currentTimeAsInt
40+
return $ RunResult ChangedRecomputeDiff "" $ True
41+
42+
43+
depTree = DepsTree {
44+
-- depsTreeNodeDeps = fromListKeySet [toKey GetModSummary f]
45+
depsTreeNodeDeps = fromListKeySet [newKey (Rule :: Rule ())]
46+
-- -- condition to continue the tree
47+
, depsTreeNodeCond = Rule :: Rule Bool
48+
-- -- the continuation of the tree
49+
, depsTreeContinuation = \case
50+
True -> DeptLeaf $ fromListKeySet []
51+
False -> DeptLeaf $ fromListKeySet [newKey (Rule :: Rule ())]
52+
}
53+
54+
-- | Depends on Rule @()
55+
ruleInt :: Rules ()
56+
ruleInt = addRule $ \Rule _old _mode -> do
57+
insertDepsTree depTree
58+
() <- apply1 Rule
59+
b <- apply1 Rule
60+
return $ if b
61+
then RunResult ChangedRecomputeDiff "" (1 :: Int)
62+
else RunResult ChangedRecomputeDiff "" 2

0 commit comments

Comments
 (0)