ghcide-bench-2.3.0.0: src/Experiments.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}
module Experiments
( Bench(..)
, BenchRun(..)
, Config(..)
, Verbosity(..)
, CabalStack(..)
, SetupResult(..)
, Example(..)
, experiments
, configP
, defConfig
, output
, setup
, runBench
, exampleToOptions
) where
import Control.Applicative.Combinators (skipManyTill)
import Control.Concurrent.Async (withAsync)
import Control.Exception.Safe (IOException, handleAny,
try)
import Control.Lens (_Just, (&), (.~), (^.))
import Control.Lens.Extras (is)
import Control.Monad.Extra (allM, forM, forM_, forever,
unless, void, when,
whenJust, (&&^))
import Control.Monad.Fail (MonadFail)
import Control.Monad.IO.Class
import Data.Aeson (Value (Null),
eitherDecodeStrict',
toJSON)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Either (fromRight)
import Data.List
import Data.Maybe
import Data.Proxy
import Data.Row hiding (switch)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version
import Development.IDE.Plugin.Test
import Development.IDE.Test.Diagnostic
import Development.Shake (CmdOption (Cwd, FileStdout),
cmd_)
import Experiments.Types
import Language.LSP.Protocol.Capabilities
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding (Null,
SemanticTokenAbsolute (..))
import qualified Language.LSP.Protocol.Types as LSP
import Language.LSP.Test
import Numeric.Natural
import Options.Applicative
import System.Directory
import System.Environment.Blank (getEnv)
import System.FilePath ((<.>), (</>))
import System.IO
import System.Process
import System.Time.Extra
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Printf
charEdit :: Position -> TextDocumentContentChangeEvent
charEdit p =
TextDocumentContentChangeEvent $ InL $ #range .== Range p p
.+ #rangeLength .== Nothing
.+ #text .== "a"
headerEdit :: TextDocumentContentChangeEvent
headerEdit =
TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 0)
.+ #rangeLength .== Nothing
.+ #text .== "-- header comment \n"
data DocumentPositions = DocumentPositions {
-- | A position that can be used to generate non null goto-def and completion responses
identifierP :: Maybe Position,
-- | A position that can be modified without generating a new diagnostic
stringLiteralP :: !Position,
-- | The document containing the above positions
doc :: !TextDocumentIdentifier
}
allWithIdentifierPos :: MonadFail m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos f docs = case applicableDocs of
-- fail if there are no documents to benchmark
[] -> fail "None of the example modules have identifier positions"
docs' -> allM f docs'
where
applicableDocs = filter (isJust . identifierP) docs
experiments :: HasConfig => [Bench]
experiments =
[ ---------------------------------------------------------------------------------------
bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->
isJust <$> getHover doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench "hover after edit" $ \docs -> do
forM_ docs $ \DocumentPositions{..} ->
changeDoc doc [charEdit stringLiteralP]
flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
isJust <$> getHover doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench
"hover after cradle edit"
(\docs -> do
hieYamlUri <- getDocUri "hie.yaml"
liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
[ FileEvent hieYamlUri FileChangeType_Changed ]
flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)
),
---------------------------------------------------------------------------------------
bench "edit" $ \docs -> do
forM_ docs $ \DocumentPositions{..} -> do
changeDoc doc [charEdit stringLiteralP]
-- wait for a fresh build start
waitForProgressStart
-- wait for the build to be finished
output "edit: waitForProgressDone"
waitForProgressDone
return True,
---------------------------------------------------------------------------------------
bench "edit-header" $ \docs -> do
forM_ docs $ \DocumentPositions{..} -> do
changeDoc doc [headerEdit]
-- wait for a fresh build start
waitForProgressStart
-- wait for the build to be finished
output "edit: waitForProgressDone"
waitForProgressDone
return True,
---------------------------------------------------------------------------------------
bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->
hasDefinitions <$> getDefinitions doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench "getDefinition after edit" $ \docs -> do
forM_ docs $ \DocumentPositions{..} ->
changeDoc doc [charEdit stringLiteralP]
flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
hasDefinitions <$> getDefinitions doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do
fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,
---------------------------------------------------------------------------------------
bench "documentSymbols after edit" $ \docs -> do
forM_ docs $ \DocumentPositions{..} ->
changeDoc doc [charEdit stringLiteralP]
flip allM docs $ \DocumentPositions{..} ->
either (not . null) (not . null) <$> getDocumentSymbols doc,
---------------------------------------------------------------------------------------
bench "completions" $ \docs -> do
flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
not . null <$> getCompletions doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench "completions after edit" $ \docs -> do
forM_ docs $ \DocumentPositions{..} ->
changeDoc doc [charEdit stringLiteralP]
flip allWithIdentifierPos docs $ \DocumentPositions{..} ->
not . null <$> getCompletions doc (fromJust identifierP),
---------------------------------------------------------------------------------------
bench
"code actions"
( \docs -> do
unless (any (isJust . identifierP) docs) $
error "None of the example modules is suitable for this experiment"
not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
forM identifierP $ \p ->
getCodeActions doc (Range p p))
),
---------------------------------------------------------------------------------------
bench
"code actions after edit"
( \docs -> do
unless (any (isJust . identifierP) docs) $
error "None of the example modules is suitable for this experiment"
forM_ docs $ \DocumentPositions{..} -> do
changeDoc doc [charEdit stringLiteralP]
waitForProgressStart
waitForProgressDone
not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
forM identifierP $ \p ->
getCodeActions doc (Range p p))
),
---------------------------------------------------------------------------------------
bench
"code actions after cradle edit"
( \docs -> do
hieYamlUri <- getDocUri "hie.yaml"
liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"
sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
[ FileEvent hieYamlUri FileChangeType_Changed ]
waitForProgressStart
waitForProgressStart
waitForProgressStart -- the Session logic restarts a second time
waitForProgressDone
not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
forM identifierP $ \p ->
getCodeActions doc (Range p p))
),
---------------------------------------------------------------------------------------
bench
"code lens"
( \docs -> not . null <$> forM docs (\DocumentPositions{..} ->
getCodeLenses doc)
),
---------------------------------------------------------------------------------------
bench
"code lens after edit"
( \docs -> do
forM_ docs $ \DocumentPositions{..} -> do
changeDoc doc [charEdit stringLiteralP]
waitForProgressStart
waitForProgressDone
not . null <$> forM docs (\DocumentPositions{..} -> do
getCodeLenses doc)
),
---------------------------------------------------------------------------------------
benchWithSetup
"hole fit suggestions"
( mapM_ $ \DocumentPositions{..} -> do
let edit =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
.+ #rangeLength .== Nothing
.+ #text .== t
bottom = Position maxBound 0
t = T.unlines
[""
,"holef :: [Int] -> [Int]"
,"holef = _"
,""
,"holeg :: [()] -> [()]"
,"holeg = _"
]
changeDoc doc [edit]
)
(\docs -> do
forM_ docs $ \DocumentPositions{..} ->
changeDoc doc [charEdit stringLiteralP]
void waitForDiagnostics
waitForProgressDone
flip allM docs $ \DocumentPositions{..} -> do
bottom <- pred . length . T.lines <$> documentContents doc
diags <- getCurrentDiagnostics doc
case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of
Nothing -> pure True
Just _err -> pure False
)
]
where hasDefinitions (InL (Definition (InL _))) = True
hasDefinitions (InL (Definition (InR ls))) = not $ null ls
hasDefinitions (InR (InL ds)) = not $ null ds
hasDefinitions (InR (InR LSP.Null)) = False
---------------------------------------------------------------------------------------------
examplesPath :: FilePath
examplesPath = "bench/example"
defConfig :: Config
Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []
quiet, verbose :: Config -> Bool
verbose = (== All) . verbosity
quiet = (== Quiet) . verbosity
type HasConfig = (?config :: Config)
configP :: Parser Config
configP =
Config
<$> (flag' All (short 'v' <> long "verbose")
<|> flag' Quiet (short 'q' <> long "quiet")
<|> pure Normal
)
<*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
<*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))
<*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)
<*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")
<*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))
<*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))
<*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
<*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
<*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")
<*> ( Example
<$> exampleName
<*> (ExampleHackage <$> packageP)
<*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])
<*> pure []
<|> Example
<$> exampleName
<*> pathOrScriptP
<*> some moduleOption
<*> pure [])
<*> switch (long "lsp-config" <> help "Read an LSP config payload from standard input")
where
moduleOption = strOption (long "example-module" <> metavar "PATH")
exampleName = strOption (long "example-name" <> metavar "NAME")
packageP = ExamplePackage
<$> strOption (long "example-package-name" <> value "Cabal")
<*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))
pathOrScriptP = ExamplePath <$> strOption (long "example-path")
<|> ExampleScript <$> strOption (long "example-script") <*> many (strOption (long "example-script-args" <> help "arguments for the example generation script"))
versionP :: ReadM Version
versionP = maybeReader $ extract . readP_to_S parseVersion
where
extract parses = listToMaybe [ res | (res,"") <- parses]
output :: (MonadIO m, HasConfig) => String -> m ()
output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn
---------------------------------------------------------------------------------------
type Experiment = [DocumentPositions] -> Session Bool
data Bench =
Bench
{ name :: !String,
enabled :: !Bool,
samples :: !Natural,
benchSetup :: [DocumentPositions] -> Session (),
experiment :: Experiment
}
select :: HasConfig => Bench -> Bool
select Bench {name, enabled} =
enabled && (null mm || name `elem` mm)
where
mm = matches ?config
benchWithSetup ::
String ->
([DocumentPositions] -> Session ()) ->
Experiment ->
Bench
benchWithSetup name benchSetup experiment = Bench {..}
where
enabled = True
samples = 100
bench :: String -> Experiment -> Bench
bench name = benchWithSetup name (const $ pure ())
runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()
runBenchmarksFun dir allBenchmarks = do
let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }
| b <- allBenchmarks
, select b ]
whenJust (otMemoryProfiling ?config) $ \eventlogDir ->
createDirectoryIfMissing True eventlogDir
lspConfig <- if Experiments.Types.lspConfig ?config
then either error id . eitherDecodeStrict' <$> BS.getContents
else return mempty
let conf = defaultConfig
{ logStdErr = verbose ?config,
logMessages = verbose ?config,
logColor = False,
Language.LSP.Test.lspConfig = lspConfig,
messageTimeout = timeoutLsp ?config
}
results <- forM benchmarks $ \b@Bench{name} -> do
let p = (proc (ghcide ?config) (allArgs name dir))
{ std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
run sess = withCreateProcess p $ \(Just inH) (Just outH) (Just errH) pH -> do
-- Need to continuously consume to stderr else it gets blocked
-- Can't pass NoStream either to std_err
hSetBuffering errH NoBuffering
hSetBinaryMode errH True
let errSinkThread =
forever $ hGetLine errH >>= when (verbose ?config). putStrLn
withAsync errSinkThread $ \_ -> do
runSessionWithHandles' (Just pH) inH outH conf lspTestCaps dir sess
(b,) <$> runBench run b
-- output raw data as CSV
let headers =
[ "name"
, "success"
, "samples"
, "startup"
, "setup"
, "userT"
, "delayedT"
, "1stBuildT"
, "avgPerRespT"
, "totalT"
, "rulesBuilt"
, "rulesChanged"
, "rulesVisited"
, "rulesTotal"
, "ruleEdges"
, "ghcRebuilds"
]
rows =
[ [ name,
show success,
show samples,
showMs startup,
showMs runSetup',
showMs userWaits,
showMs delayedWork,
showMs $ firstResponse+firstResponseDelayed,
-- Exclude first response as it has a lot of setup time included
-- Assume that number of requests = number of modules * number of samples
showMs ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),
showMs runExperiment,
show rulesBuilt,
show rulesChanged,
show rulesVisited,
show rulesTotal,
show edgesTotal,
show rebuildsTotal
]
| (Bench {name, samples}, BenchRun {..}) <- results,
let runSetup' = if runSetup < 0.01 then 0 else runSetup
modules = fromIntegral $ length $ exampleModules $ example ?config
]
csv = unlines $ map (intercalate ", ") (headers : rows)
writeFile (outputCSV ?config) csv
-- print a nice table
let pads = map (maximum . map length) (transpose (headers : rowsHuman))
paddedHeaders = zipWith pad pads headers
outputRow = putStrLn . intercalate " | "
rowsHuman =
[ [ name,
show success,
show samples,
showDuration startup,
showDuration runSetup',
showDuration userWaits,
showDuration delayedWork,
showDuration firstResponse,
showDuration runExperiment,
show rulesBuilt,
show rulesChanged,
show rulesVisited,
show rulesTotal,
show edgesTotal,
show rebuildsTotal
]
| (Bench {name, samples}, BenchRun {..}) <- results,
let runSetup' = if runSetup < 0.01 then 0 else runSetup
]
outputRow paddedHeaders
outputRow $ (map . map) (const '-') paddedHeaders
forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
where
ghcideArgs dir =
[ "--lsp",
"--test",
"--cwd",
dir
]
allArgs name dir =
ghcideArgs dir
++ concat
[ [ "+RTS"
, "-l"
, "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")
, "-RTS"
]
| Just dir <- [otMemoryProfiling ?config]
]
++ ghcideOptions ?config
++ concat
[ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
]
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
lspTestCaps =
fullCaps
& (L.window . _Just) .~ WindowClientCapabilities (Just True) Nothing Nothing
& (L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just) .~ (#properties .== ["edit"])
& (L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just) .~ True
showMs :: Seconds -> String
showMs = printf "%.2f"
data BenchRun = BenchRun
{ startup :: !Seconds,
runSetup :: !Seconds,
runExperiment :: !Seconds,
userWaits :: !Seconds,
delayedWork :: !Seconds,
firstResponse :: !Seconds,
firstResponseDelayed :: !Seconds,
rulesBuilt :: !Int,
rulesChanged :: !Int,
rulesVisited :: !Int,
rulesTotal :: !Int,
edgesTotal :: !Int,
rebuildsTotal :: !Int,
success :: !Bool
}
badRun :: BenchRun
badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False
waitForProgressStart :: Session ()
waitForProgressStart = void $ do
skipManyTill anyMessage $ satisfy $ \case
FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True
_ -> False
-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForProgressDone :: Session ()
waitForProgressDone = loop
where
loop = do
~() <- skipManyTill anyMessage $ satisfyMaybe $ \case
FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just ()
_ -> Nothing
done <- null <$> getIncompleteProgressSessions
unless done loop
-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
let m = SMethod_CustomMethod (Proxy @"test")
waitId <- sendRequest m (toJSON WaitForShakeQueue)
(td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
case resp of
TResponseMessage{_result=Right Null} -> return td
-- assume a ghcide binary lacking the WaitForShakeQueue method
_ -> return 0
runBench ::
HasConfig =>
(Session BenchRun -> IO BenchRun) ->
Bench ->
IO BenchRun
runBench runSess Bench{..} = handleAny (\e -> print e >> return badRun)
$ runSess
$ do
(startup, docs) <- duration $ do
(d, docs) <- duration $ setupDocumentContents ?config
output $ "Setting up document contents took " <> showDuration d
-- wait again, as the progress is restarted once while loading the cradle
-- make an edit, to ensure this doesn't block
let DocumentPositions{..} = head docs
changeDoc doc [charEdit stringLiteralP]
waitForProgressDone
return docs
liftIO $ output $ "Running " <> name <> " benchmark"
(runSetup, ()) <- duration $ benchSetup docs
let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)
loop' timeForFirstResponse !userWaits !delayedWork n = do
(t, res) <- duration $ experiment docs
if not res
then return Nothing
else do
output (showDuration t)
-- Wait for the delayed actions to finish
td <- waitForBuildQueue
loop' (timeForFirstResponse <|> Just (t,td)) (userWaits+t) (delayedWork+td) (n -1)
loop = loop' Nothing
(runExperiment, result) <- duration $ loop 0 0 samples
let success = isJust result
(userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(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
rebuildsTotal <- fromRight 0 <$> getRebuildsCount
return BenchRun {..}
data SetupResult = SetupResult {
runBenchmarks :: [Bench] -> IO (),
-- | Path to the setup benchmark example
benchDir :: FilePath,
cleanUp :: IO ()
}
callCommandLogging :: HasConfig => String -> IO ()
callCommandLogging cmd = do
output cmd
callCommand cmd
setup :: HasConfig => IO SetupResult
setup = do
-- when alreadyExists $ removeDirectoryRecursive examplesPath
benchDir <- case exampleDetails(example ?config) of
ExamplePath examplePath -> do
let hieYamlPath = examplePath </> "hie.yaml"
alreadyExists <- doesFileExist hieYamlPath
unless alreadyExists $
cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)
return examplePath
ExampleScript examplePath' scriptArgs -> do
let exampleDir = examplesPath </> exampleName (example ?config)
alreadySetup <- doesDirectoryExist exampleDir
unless alreadySetup $ do
createDirectoryIfMissing True exampleDir
examplePath <- makeAbsolute examplePath'
cmd_ (Cwd exampleDir) examplePath scriptArgs
let hieYamlPath = exampleDir </> "hie.yaml"
alreadyExists <- doesFileExist hieYamlPath
unless alreadyExists $
cmd_ (Cwd exampleDir) (FileStdout hieYamlPath) ("gen-hie"::String)
return exampleDir
ExampleHackage ExamplePackage{..} -> do
let path = examplesPath </> package
package = packageName <> "-" <> showVersion packageVersion
hieYamlPath = path </> "hie.yaml"
alreadySetup <- doesDirectoryExist path
unless alreadySetup $
case buildTool ?config of
Cabal -> do
let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))
callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath
let hieYamlPath = path </> "hie.yaml"
cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String)
-- Need this in case there is a parent cabal.project somewhere
writeFile
(path </> "cabal.project")
"packages: ."
writeFile
(path </> "cabal.project.local")
""
Stack -> do
let stackVerbosity = case verbosity ?config of
Quiet -> "--silent"
Normal -> ""
All -> "--verbose"
callCommandLogging $ "stack " <> stackVerbosity <> " unpack " <> package <> " --to " <> examplesPath
-- Generate the stack descriptor to match the one used to build ghcide
stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"
stack_yaml_lines <- lines <$> readFile stack_yaml
writeFile (path </> stack_yaml)
(unlines $
"packages: [.]" :
[ l
| l <- stack_yaml_lines
, any (`isPrefixOf` l)
["resolver"
,"allow-newer"
,"compiler"]
]
)
cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String]
return path
whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
let cleanUp = case exampleDetails(example ?config) of
ExampleHackage _ -> removeDirectoryRecursive examplesPath
ExampleScript _ _ -> removeDirectoryRecursive examplesPath
ExamplePath _ -> return ()
runBenchmarks = runBenchmarksFun benchDir
return SetupResult{..}
setupDocumentContents :: Config -> Session [DocumentPositions]
setupDocumentContents config =
forM (exampleModules $ example config) $ \m -> do
doc <- openDoc m "haskell"
-- Setup the special positions used by the experiments
lastLine <- fromIntegral . length . T.lines <$> documentContents doc
changeDoc doc [TextDocumentContentChangeEvent $ InL
$ #range .== Range (Position lastLine 0) (Position lastLine 0)
.+ #rangeLength .== Nothing
.+ #text .== T.unlines [ "_hygienic = \"hygienic\"" ]]
let
-- Points to a string in the target file,
-- convenient for hygienic edits
stringLiteralP = Position lastLine 15
-- Find an identifier defined in another file in this project
symbols <- getDocumentSymbols doc
let endOfImports = case symbols of
Right symbols | Just x <- findEndOfImports symbols -> x
_ -> error $ "symbols: " <> show symbols
contents <- documentContents doc
identifierP <- searchSymbol doc contents endOfImports
return $ DocumentPositions{..}
findEndOfImports :: [DocumentSymbol] -> Maybe Position
findEndOfImports (DocumentSymbol{_kind = SymbolKind_Module, _name = "imports", _range} : _) =
Just $ Position (succ $ _line $ _end _range) 4
findEndOfImports [DocumentSymbol{_kind = SymbolKind_File, _children = Just (cc)}] =
findEndOfImports cc
findEndOfImports (DocumentSymbol{_range} : _) =
Just $ _range ^. L.start
findEndOfImports _ = Nothing
--------------------------------------------------------------------------------------------
pad :: Int -> String -> String
pad n [] = replicate n ' '
pad 0 _ = error "pad"
pad n (x:xx) = x : pad (n-1) xx
-- | Search for a position where:
-- - get definition works and returns a uri other than this file
-- - get completions returns a non empty list
searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)
searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do
-- this search is expensive, so we cache the result on disk
let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"
cachedRes <- liftIO $ try @_ @IOException $ A.decode . BSL.fromStrict <$> BS.readFile cachedPath
case cachedRes of
Left _ -> do
result <- loop pos
liftIO $ BS.writeFile cachedPath $ BSL.toStrict $ A.encode result
return result
Right res ->
return res
where
loop pos
| (fromIntegral $ _line pos) >= lll =
return Nothing
| (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =
loop (nextLine pos)
| otherwise = do
checks <- checkDefinitions pos &&^ checkCompletions pos
if checks
then return $ Just pos
else loop (nextIdent pos)
nextIdent p = p{_character = _character p + 2}
nextLine p = Position (_line p + 1) 4
lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)
ll = T.lines fileContents
lll = length ll
checkDefinitions pos = do
defs <- getDefinitions doc pos
case defs of
(InL (Definition (InR [Location uri _]))) -> return $ uri /= _uri
_ -> return False
checkCompletions pos =
not . null <$> getCompletions doc pos
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
getRebuildsCount :: Session (Either ResponseError Int)
getRebuildsCount = tryCallTestPlugin GetRebuildsCount
-- Copy&paste from ghcide/test/Development.IDE.Test
getStoredKeys :: Session [Text]
getStoredKeys = callTestPlugin GetStoredKeys
-- Copy&paste from ghcide/test/Development.IDE.Test
tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin cmd = do
let cm = SMethod_CustomMethod (Proxy @"test")
waitId <- sendRequest cm (A.toJSON cmd)
TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId
return $ case _result of
Left e -> Left e
Right json -> case A.fromJSON json of
A.Success a -> Right a
A.Error e -> error e
-- Copy&paste from ghcide/test/Development.IDE.Test
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