diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index da104afc1a4..3aeed09e662 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 ccd1b0aa7d4..a6da170c141 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 b611b049a9d..881aed4406c 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 48fd9fa5bc5..cdabcdcd220 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 b0f296a37a4..e44d4f75d5a 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 96481a6f315..c3467ae9054 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 1bc0ced3a21..bd86d6ee701 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 3081457cc29..1b1fdc1c6bf 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 =