Experiments.hs

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE ImplicitParams     #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedLabels   #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# 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