diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs
index da104afc1a45487f21498f2befb20d57dc682509..3aeed09e6625c226f4b8eaed42264ccffda8cdec 100644
--- a/ghcide/bench/lib/Experiments.hs
+++ b/ghcide/bench/lib/Experiments.hs
@@ -26,11 +26,17 @@ import Control.Exception.Safe (IOException, handleAny, try)
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Aeson (Value (Null), toJSON)
+import Data.Either (fromRight)
import Data.List
import Data.Maybe
import qualified Data.Text as T
import Data.Version
import Development.IDE.Plugin.Test
+import Development.IDE.Test (getBuildEdgesCount,
+ getBuildKeysBuilt,
+ getBuildKeysChanged,
+ getBuildKeysVisited,
+ getStoredKeys)
import Development.IDE.Test.Diagnostic
import Development.Shake (CmdOption (Cwd, FileStdout),
cmd_)
@@ -323,6 +329,11 @@ runBenchmarksFun dir allBenchmarks = do
, "userTime"
, "delayedTime"
, "totalTime"
+ , "buildRulesBuilt"
+ , "buildRulesChanged"
+ , "buildRulesVisited"
+ , "buildRulesTotal"
+ , "buildEdges"
]
rows =
[ [ name,
@@ -332,7 +343,12 @@ runBenchmarksFun dir allBenchmarks = do
show runSetup',
show userWaits,
show delayedWork,
- show runExperiment
+ show runExperiment,
+ show rulesBuilt,
+ show rulesChanged,
+ show rulesVisited,
+ show rulesTotal,
+ show edgesTotal
]
| (Bench {name, samples}, BenchRun {..}) <- results,
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -352,7 +368,12 @@ runBenchmarksFun dir allBenchmarks = do
showDuration runSetup',
showDuration userWaits,
showDuration delayedWork,
- showDuration runExperiment
+ showDuration runExperiment,
+ show rulesBuilt,
+ show rulesChanged,
+ show rulesVisited,
+ show rulesTotal,
+ show edgesTotal
]
| (Bench {name, samples}, BenchRun {..}) <- results,
let runSetup' = if runSetup < 0.01 then 0 else runSetup
@@ -398,11 +419,16 @@ data BenchRun = BenchRun
runExperiment :: !Seconds,
userWaits :: !Seconds,
delayedWork :: !Seconds,
+ rulesBuilt :: !Int,
+ rulesChanged :: !Int,
+ rulesVisited :: !Int,
+ rulesTotal :: !Int,
+ edgesTotal :: !Int,
success :: !Bool
}
badRun :: BenchRun
-badRun = BenchRun 0 0 0 0 0 False
+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False
waitForProgressStart :: Session ()
waitForProgressStart = void $ do
@@ -470,6 +496,12 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
let success = isJust result
(userWaits, delayedWork) = fromMaybe (0,0) result
+ rulesTotal <- length <$> getStoredKeys
+ rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt
+ rulesChanged <- either (const 0) length <$> getBuildKeysChanged
+ rulesVisited <- either (const 0) length <$> getBuildKeysVisited
+ edgesTotal <- fromRight 0 <$> getBuildEdgesCount
+
return BenchRun {..}
data SetupResult = SetupResult {
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index ccd1b0aa7d4e6e92f8c6e7516751985f53dd7110..a6da170c1413b9894bcf1d75f64bc7a15b49dec8 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -446,6 +446,7 @@ executable ghcide-bench
extra,
filepath,
ghcide,
+ hls-plugin-api,
lens,
lsp-test,
lsp-types,
@@ -454,11 +455,13 @@ executable ghcide-bench
safe-exceptions,
hls-graph,
shake,
+ tasty-hunit,
text
hs-source-dirs: bench/lib bench/exe test/src
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
main-is: Main.hs
other-modules:
+ Development.IDE.Test
Development.IDE.Test.Diagnostic
Experiments
Experiments.Types
diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs
index b611b049a9d5189d772276bdc20690572896b7da..881aed4406c6afd2900defbba40936e05bfe5600 100644
--- a/ghcide/src/Development/IDE/Plugin/Test.hs
+++ b/ghcide/src/Development/IDE/Plugin/Test.hs
@@ -11,33 +11,40 @@ module Development.IDE.Plugin.Test
, blockCommandId
) where
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Extra (readVar)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Extra (readVar)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.STM
import Data.Aeson
import Data.Aeson.Types
import Data.Bifunctor
-import Data.CaseInsensitive (CI, original)
-import qualified Data.HashMap.Strict as HM
-import Data.Maybe (isJust)
+import Data.CaseInsensitive (CI, original)
+import qualified Data.HashMap.Strict as HM
+import Data.Maybe (isJust)
import Data.String
-import Data.Text (Text, pack)
-import Development.IDE.Core.OfInterest (getFilesOfInterest)
+import Data.Text (Text, pack)
+import Development.IDE.Core.OfInterest (getFilesOfInterest)
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.IDE.GHC.Compat
-import Development.IDE.Graph (Action)
-import Development.IDE.Graph.Database (shakeLastBuildKeys)
+import Development.IDE.Graph (Action)
+import qualified Development.IDE.Graph as Graph
+import Development.IDE.Graph.Database (ShakeDatabase,
+ shakeGetBuildEdges,
+ shakeGetBuildStep,
+ shakeGetCleanKeys)
+import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
+ Step (Step))
+import qualified Development.IDE.Graph.Internal.Types as Graph
import Development.IDE.Types.Action
-import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
-import Development.IDE.Types.Location (fromUri)
-import GHC.Generics (Generic)
-import Ide.Plugin.Config (CheckParents)
+import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
+import Development.IDE.Types.Location (fromUri)
+import GHC.Generics (Generic)
+import Ide.Plugin.Config (CheckParents)
import Ide.Types
-import qualified Language.LSP.Server as LSP
+import qualified Language.LSP.Server as LSP
import Language.LSP.Types
import System.Time.Extra
@@ -48,7 +55,10 @@ data TestRequest
| GetShakeSessionQueueCount -- ^ :: Number
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
- | GetLastBuildKeys -- ^ :: [String]
+ | GetBuildKeysVisited -- ^ :: [(String]
+ | GetBuildKeysBuilt -- ^ :: [(String]
+ | GetBuildKeysChanged -- ^ :: [(String]
+ | GetBuildEdgesCount -- ^ :: Int
| GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected)
| GetStoredKeys -- ^ :: [String] (list of keys in store)
| GetFilesOfInterest -- ^ :: [FilePath]
@@ -98,9 +108,18 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
let res = WaitForIdeRuleResult <$> success
return $ bimap mkResponseError toJSON res
-testRequestHandler s GetLastBuildKeys = liftIO $ do
- keys <- shakeLastBuildKeys $ shakeDb s
+testRequestHandler s GetBuildKeysBuilt = liftIO $ do
+ keys <- getDatabaseKeys resultBuilt $ shakeDb s
return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildKeysChanged = liftIO $ do
+ keys <- getDatabaseKeys resultChanged $ shakeDb s
+ return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildKeysVisited = liftIO $ do
+ keys <- getDatabaseKeys resultVisited $ shakeDb s
+ return $ Right $ toJSON $ map show keys
+testRequestHandler s GetBuildEdgesCount = liftIO $ do
+ count <- shakeGetBuildEdges $ shakeDb s
+ return $ Right $ toJSON count
testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
return $ Right $ toJSON $ map show res
@@ -111,6 +130,14 @@ testRequestHandler s GetFilesOfInterest = do
ff <- liftIO $ getFilesOfInterest s
return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff
+getDatabaseKeys :: (Graph.Result -> Step)
+ -> ShakeDatabase
+ -> IO [Graph.Key]
+getDatabaseKeys field db = do
+ keys <- shakeGetCleanKeys db
+ step <- shakeGetBuildStep db
+ return [ k | (k, res) <- keys, field res == Step step]
+
mkResponseError :: Text -> ResponseError
mkResponseError msg = ResponseError InvalidRequest msg Nothing
diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs
index 48fd9fa5bc57724837d8b38537c9501e0e2e6532..cdabcdcd220520ce05ef3c2f68161b1debe2f1ac 100644
--- a/ghcide/test/src/Development/IDE/Test.hs
+++ b/ghcide/test/src/Development/IDE/Test.hs
@@ -21,7 +21,6 @@ module Development.IDE.Test
, standardizeQuotes
, flushMessages
, waitForAction
- , getLastBuildKeys
, getInterfaceFilesDir
, garbageCollectDirtyKeys
, getFilesOfInterest
@@ -30,7 +29,7 @@ module Development.IDE.Test
, getStoredKeys
, waitForCustomMessage
, waitForGC
- ) where
+ ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where
import Control.Applicative.Combinators
import Control.Lens hiding (List)
@@ -182,23 +181,40 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat
diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
diagnostic = LspTest.message STextDocumentPublishDiagnostics
-callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
-callTestPlugin cmd = do
+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
+tryCallTestPlugin cmd = do
let cm = SCustomMethod "test"
waitId <- sendRequest cm (A.toJSON cmd)
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
return $ case _result of
- Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+ Left e -> Left e
Right json -> case A.fromJSON json of
- A.Success a -> a
+ A.Success a -> Right a
A.Error e -> error e
+callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
+callTestPlugin cmd = do
+ res <- tryCallTestPlugin cmd
+ case res of
+ Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err
+ Right a -> pure a
+
+
waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
waitForAction key TextDocumentIdentifier{_uri} =
callTestPlugin (WaitForIdeRule key _uri)
-getLastBuildKeys :: Session [T.Text]
-getLastBuildKeys = callTestPlugin GetLastBuildKeys
+getBuildKeysBuilt :: Session (Either ResponseError [T.Text])
+getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt
+
+getBuildKeysVisited :: Session (Either ResponseError [T.Text])
+getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited
+
+getBuildKeysChanged :: Session (Either ResponseError [T.Text])
+getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged
+
+getBuildEdgesCount :: Session (Either ResponseError Int)
+getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount
getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)
diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal
index b0f296a37a445b1e8b3b4800aab89274a0143b7d..e44d4f75d5a0eb2e5ff285f2df666a6f797bd2b5 100644
--- a/hls-graph/hls-graph.cabal
+++ b/hls-graph/hls-graph.cabal
@@ -38,8 +38,6 @@ library
Development.IDE.Graph.Classes
Development.IDE.Graph.Database
Development.IDE.Graph.Rule
-
- other-modules:
Development.IDE.Graph.Internal.Action
Development.IDE.Graph.Internal.Options
Development.IDE.Graph.Internal.Rules
@@ -55,6 +53,7 @@ library
hs-source-dirs: src
build-depends:
+ , aeson
, async
, base >=4.12 && <5
, bytestring
diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
index 96481a6f315b13f32fc6239c1f2ea1d48c90f8da..c3467ae90545cff1777de89bb1beb0ad088985c4 100644
--- a/hls-graph/src/Development/IDE/Graph/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -9,10 +9,9 @@ module Development.IDE.Graph.Database(
shakeRunDatabaseForKeys,
shakeProfileDatabase,
shakeGetBuildStep,
- shakeGetDatabaseKeys,
shakeGetDirtySet,
- shakeLastBuildKeys
- ) where
+ shakeGetCleanKeys
+ ,shakeGetBuildEdges) where
import Data.Dynamic
import Data.IORef (readIORef)
import Data.Maybe
@@ -48,11 +47,6 @@ shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)]
shakeGetDirtySet (ShakeDatabase _ _ db) =
fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db
--- | Returns ann approximation of the database keys,
--- annotated with how long ago (in # builds) they were visited
-shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)]
-shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db
-
-- | Returns the build number
shakeGetBuildStep :: ShakeDatabase -> IO Int
shakeGetBuildStep (ShakeDatabase _ _ db) = do
@@ -78,9 +72,15 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s
--- | Returns the set of keys built in the most recent step
-shakeLastBuildKeys :: ShakeDatabase -> IO [Key]
-shakeLastBuildKeys (ShakeDatabase _ _ db) = do
+-- | Returns the clean keys in the database
+shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )]
+shakeGetCleanKeys (ShakeDatabase _ _ db) = do
+ keys <- Ids.elems $ databaseValues db
+ return [ (k,res) | (k, Clean res) <- keys]
+
+-- | Returns the total count of edges in the build graph
+shakeGetBuildEdges :: ShakeDatabase -> IO Int
+shakeGetBuildEdges (ShakeDatabase _ _ db) = do
keys <- Ids.elems $ databaseValues db
- step <- readIORef $ databaseStep db
- return [ k | (k, Clean res) <- keys, resultBuilt res == step ]
+ let ress = mapMaybe (getResult . snd) keys
+ return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
index 1bc0ced3a212649ee3448a4b9d8e708fab7a9c7f..bd86d6ee7012c478b001ef9d020c4d70f676f45d 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -14,6 +17,7 @@ import Control.Monad.Catch
import Control.Monad.Fail
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
+import Data.Aeson (FromJSON, ToJSON)
import qualified Data.ByteString as BS
import Data.Dynamic
import qualified Data.HashMap.Strict as Map
@@ -24,6 +28,7 @@ import Data.Typeable
import Development.IDE.Graph.Classes
import Development.IDE.Graph.Internal.Ids
import Development.IDE.Graph.Internal.Intern
+import GHC.Generics (Generic)
import System.Time.Extra (Seconds)
@@ -38,7 +43,7 @@ unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x
type TheRules = Map.HashMap TypeRep Dynamic
newtype Rules a = Rules (ReaderT SRules IO a)
- deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
+ deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail)
data SRules = SRules {
rulesExtra :: !Dynamic,
@@ -51,7 +56,7 @@ data SRules = SRules {
-- ACTIONS
newtype Action a = Action {fromAction :: ReaderT SAction IO a}
- deriving (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
+ deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
data SAction = SAction {
actionDatabase :: !Database,
@@ -65,7 +70,7 @@ getDatabase = Action $ asks actionDatabase
-- DATABASE
newtype Step = Step Int
- deriving (Eq,Ord,Hashable)
+ deriving newtype (Eq,Ord,Hashable)
data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a
@@ -151,7 +156,8 @@ data RunChanged
| ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely).
| ChangedRecomputeSame -- ^ I recomputed the value and it was the same.
| ChangedRecomputeDiff -- ^ I recomputed the value and it was different.
- deriving (Eq,Show)
+ deriving (Eq,Show,Generic)
+ deriving anyclass (FromJSON, ToJSON)
instance NFData RunChanged where rnf x = x `seq` ()
diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs
index 3081457cc296aa9878bec3f8051e487568d6b586..1b1fdc1c6bf2fa2fc9318565ab2f18917e383c72 100644
--- a/hls-test-utils/src/Test/Hls.hs
+++ b/hls-test-utils/src/Test/Hls.hs
@@ -49,7 +49,7 @@ import Development.IDE (IdeState, noLogging)
import Development.IDE.Graph (ShakeOptions (shakeThreads))
import Development.IDE.Main
import qualified Development.IDE.Main as Ghcide
-import Development.IDE.Plugin.Test (TestRequest (GetLastBuildKeys, WaitForIdeRule, WaitForShakeQueue),
+import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
WaitForIdeRuleResult (ideResultSuccess))
import Development.IDE.Types.Options
import GHC.IO.Handle
@@ -242,7 +242,7 @@ waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool
waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid
getLastBuildKeys :: Session (Either ResponseError [T.Text])
-getLastBuildKeys = callTestPlugin GetLastBuildKeys
+getLastBuildKeys = callTestPlugin GetBuildKeysBuilt
sendConfigurationChanged :: Value -> Session ()
sendConfigurationChanged config =