{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE ImplicitParams            #-}
{-# LANGUAGE ImpredicativeTypes        #-}
{-# 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.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           Data.Either                     (fromRight)
import           Data.List
import           Data.Maybe
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.Test
import           Language.LSP.Types              hiding
                                                 (SemanticTokenAbsolute (length, line),
                                                  SemanticTokenRelative (length),
                                                  SemanticTokensEdit (_start))
import           Language.LSP.Types.Capabilities
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 :: Position -> TextDocumentContentChangeEvent
charEdit Position
p =
    TextDocumentContentChangeEvent
    { $sel:_range:TextDocumentContentChangeEvent :: Maybe Range
_range = forall a. a -> Maybe a
Just (Position -> Position -> Range
Range Position
p Position
p),
      $sel:_rangeLength:TextDocumentContentChangeEvent :: Maybe UInt
_rangeLength = forall a. Maybe a
Nothing,
      $sel:_text:TextDocumentContentChangeEvent :: Text
_text = Text
"a"
    }

data DocumentPositions = DocumentPositions {
    -- | A position that can be used to generate non null goto-def and completion responses
    DocumentPositions -> Maybe Position
identifierP    :: Maybe Position,
    -- | A position that can be modified without generating a new diagnostic
    DocumentPositions -> Position
stringLiteralP :: !Position,
    -- | The document containing the above positions
    DocumentPositions -> TextDocumentIdentifier
doc            :: !TextDocumentIdentifier
}

allWithIdentifierPos :: MonadFail m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos :: forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos DocumentPositions -> m Bool
f [DocumentPositions]
docs = case [DocumentPositions]
applicableDocs of
    -- fail if there are no documents to benchmark
    []    -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"None of the example modules have identifier positions"
    [DocumentPositions]
docs' -> forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DocumentPositions -> m Bool
f [DocumentPositions]
docs'
  where
    applicableDocs :: [DocumentPositions]
applicableDocs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentPositions -> Maybe Position
identifierP) [DocumentPositions]
docs

experiments :: HasConfig => [Bench]
experiments :: HasConfig => [Bench]
experiments =
    [ ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"hover" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
        forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"edit" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
          -- wait for a fresh build start
          Session ()
waitForProgressStart
        -- wait for the build to be finished
        forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output [Char]
"edit: waitForProgressDone"
        Session ()
waitForProgressDone
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"hover after edit" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"getDefinition" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a |? b) -> Either a b
toEither forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Position -> Session ([Location] |? [LocationLink])
getDefinitions TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"getDefinition after edit" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a |? b) -> Either a b
toEither forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Position -> Session ([Location] |? [LocationLink])
getDefinitions TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"documentSymbols" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextDocumentIdentifier
-> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
doc,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"documentSymbols after edit" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols TextDocumentIdentifier
doc,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"completions" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"completions after edit" forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
          Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"code actions"
        ( \[DocumentPositions]
docs -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentPositions -> Maybe Position
identifierP) [DocumentPositions]
docs) forall a b. (a -> b) -> a -> b
$
                forall a. HasCallStack => [Char] -> a
error [Char]
"None of the example modules is suitable for this experiment"
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p -> TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
p]
                Session ()
waitForProgressStart
            Session ()
waitForProgressDone
        )
        ( \[DocumentPositions]
docs -> Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DocumentPositions]
docs (\DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p ->
              TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions TextDocumentIdentifier
doc (Position -> Position -> Range
Range Position
p Position
p))
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"code actions after edit"
        ( \[DocumentPositions]
docs -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentPositions -> Maybe Position
identifierP) [DocumentPositions]
docs) forall a b. (a -> b) -> a -> b
$
                forall a. HasCallStack => [Char] -> a
error [Char]
"None of the example modules is suitable for this experiment"
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p -> TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
p]
        )
        ( \[DocumentPositions]
docs -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
              TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
              Session ()
waitForProgressStart
            Session ()
waitForProgressDone
            Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DocumentPositions]
docs (\DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
              forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p ->
                TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions TextDocumentIdentifier
doc (Position -> Position -> Range
Range Position
p Position
p))
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"code actions after cradle edit"
        ( \[DocumentPositions]
docs -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p -> do
                    TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
p]
                    Session ()
waitForProgressStart
            forall (f :: * -> *) a. Functor f => f a -> f ()
void Session Seconds
waitForBuildQueue
        )
        ( \[DocumentPositions]
docs -> do
            Uri
hieYamlUri <- [Char] -> Session Uri
getDocUri [Char]
"hie.yaml"
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
appendFile (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Uri -> Maybe [Char]
uriToFilePath Uri
hieYamlUri) [Char]
"##\n"
            forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'WorkspaceDidChangeWatchedFiles
SWorkspaceDidChangeWatchedFiles forall a b. (a -> b) -> a -> b
$ List FileEvent -> DidChangeWatchedFilesParams
DidChangeWatchedFilesParams forall a b. (a -> b) -> a -> b
$
                forall a. [a] -> List a
List [ Uri -> FileChangeType -> FileEvent
FileEvent Uri
hieYamlUri FileChangeType
FcChanged ]
            Session ()
waitForProgressStart
            Session ()
waitForProgressStart
            Session ()
waitForProgressStart -- the Session logic restarts a second time
            Session ()
waitForProgressDone
            Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DocumentPositions]
docs (\DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
              forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP forall a b. (a -> b) -> a -> b
$ \Position
p ->
                TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions TextDocumentIdentifier
doc (Position -> Position -> Range
Range Position
p Position
p))
        ),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench
        [Char]
"hover after cradle edit"
        (\[DocumentPositions]
docs -> do
            Uri
hieYamlUri <- [Char] -> Session Uri
getDocUri [Char]
"hie.yaml"
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
appendFile (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Uri -> Maybe [Char]
uriToFilePath Uri
hieYamlUri) [Char]
"##\n"
            forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'WorkspaceDidChangeWatchedFiles
SWorkspaceDidChangeWatchedFiles forall a b. (a -> b) -> a -> b
$ List FileEvent -> DidChangeWatchedFilesParams
DidChangeWatchedFilesParams forall a b. (a -> b) -> a -> b
$
                forall a. [a] -> List a
List [ Uri -> FileChangeType -> FileEvent
FileEvent Uri
hieYamlUri FileChangeType
FcChanged ]
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP)
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"hole fit suggestions"
        ( forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
            let TextDocumentContentChangeEvent
edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent
                  { $sel:_range:TextDocumentContentChangeEvent :: Maybe Range
_range = forall a. a -> Maybe a
Just Range {_start :: Position
_start = Position
bottom, _end :: Position
_end = Position
bottom}
                  , $sel:_rangeLength:TextDocumentContentChangeEvent :: Maybe UInt
_rangeLength = forall a. Maybe a
Nothing, $sel:_text:TextDocumentContentChangeEvent :: Text
_text = Text
t}
                bottom :: Position
bottom = UInt -> UInt -> Position
Position forall a. Bounded a => a
maxBound UInt
0
                t :: Text
t = [Text] -> Text
T.unlines
                    [Text
""
                    ,Text
"holef :: [Int] -> [Int]"
                    ,Text
"holef = _"
                    ,Text
""
                    ,Text
"holeg :: [()] -> [()]"
                    ,Text
"holeg = _"
                    ]
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [TextDocumentContentChangeEvent
edit]
        )
        (\[DocumentPositions]
docs -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} ->
              TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
            forall (f :: * -> *) a. Functor f => f a -> f ()
void Session [Diagnostic]
waitForDiagnostics
            Session ()
waitForProgressDone
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM [DocumentPositions]
docs forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} -> do
                Int
bottom <- forall a. Enum a => a -> a
pred forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
                [Diagnostic]
diags <- TextDocumentIdentifier -> Session [Diagnostic]
getCurrentDiagnostics TextDocumentIdentifier
doc
                case forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Maybe [Char]
requireDiagnostic [Diagnostic]
diags (DiagnosticSeverity
DsError, (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bottom, UInt
8), Text
"Found hole", forall a. Maybe a
Nothing) of
                    Maybe [Char]
Nothing   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    Just [Char]
_err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        )
    ]

---------------------------------------------------------------------------------------------

examplesPath :: FilePath
examplesPath :: [Char]
examplesPath = [Char]
"bench/example"

defConfig :: Config
Success Config
defConfig = forall a. ParserPrefs -> ParserInfo a -> [[Char]] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs (forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Config
configP forall a. InfoMod a
fullDesc) []

quiet, verbose :: Config -> Bool
verbose :: Config -> Bool
verbose = (forall a. Eq a => a -> a -> Bool
== Verbosity
All) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Verbosity
verbosity
quiet :: Config -> Bool
quiet   = (forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Verbosity
verbosity

type HasConfig = (?config :: Config)

configP :: Parser Config
configP :: Parser Config
configP =
  Verbosity
-> Maybe [Char]
-> Maybe [Char]
-> [Char]
-> CabalStack
-> [[Char]]
-> [[Char]]
-> Maybe Natural
-> [Char]
-> Int
-> Example
-> Bool
-> Config
Config
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Mod FlagFields a -> Parser a
flag' Verbosity
All (forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'v' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"verbose")
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Verbosity
Quiet (forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'q' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"quiet")
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
Normal
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"shake-profiling" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"PATH"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"ot-profiling" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"DIR" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Enable OpenTelemetry and write eventlog for each benchmark in DIR"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"csv" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"PATH" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"results.csv" forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Show a => Mod f a
showDefault)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag CabalStack
Cabal CabalStack
Stack (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"stack" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Use stack (by default cabal is used)")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"ghcide-options" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"additional options for ghcide"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"select" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"select which benchmarks to run"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"samples" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"NAT" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"override sampling count"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"ghcide" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"PATH" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"path to ghcide" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"ghcide")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"timeout" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
60 forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"timeout for waiting for a ghcide response")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( [Char]
-> Either [Char] ExamplePackage -> [[Char]] -> [[Char]] -> Example
Example [Char]
"name"
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ExamplePackage
packageP)
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser [Char]
moduleOption forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"src/Distribution/Simple.hs"])
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          [Char]
-> Either [Char] ExamplePackage -> [[Char]] -> [[Char]] -> Example
Example [Char]
"name"
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Char]
pathP)
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser [Char]
moduleOption
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"lsp-config" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Read an LSP config payload from standard input")
  where
      moduleOption :: Parser [Char]
moduleOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-module" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"PATH")

      packageP :: Parser ExamplePackage
packageP = [Char] -> Version -> ExamplePackage
ExamplePackage
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-package-name" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"Cabal")
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Version
versionP (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-package-version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ([Int] -> Version
makeVersion [Int
3,Int
6,Int
0,Int
0]))
      pathP :: Parser [Char]
pathP = forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-path")

versionP :: ReadM Version
versionP :: ReadM Version
versionP = forall a. ([Char] -> Maybe a) -> ReadM a
maybeReader forall a b. (a -> b) -> a -> b
$ forall {a} {a}. (Eq a, IsString a) => [(a, a)] -> Maybe a
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion
  where
      extract :: [(a, a)] -> Maybe a
extract [(a, a)]
parses = forall a. [a] -> Maybe a
listToMaybe [ a
res | (a
res,a
"") <- [(a, a)]
parses]

output :: (MonadIO m, HasConfig) => String -> m ()
output :: forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output = if Config -> Bool
quietHasConfig
?config then (\[Char]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn

---------------------------------------------------------------------------------------

type Experiment = [DocumentPositions] -> Session Bool

data Bench =
  Bench
  { Bench -> [Char]
name       :: !String,
    Bench -> Bool
enabled    :: !Bool,
    Bench -> Natural
samples    :: !Natural,
    Bench -> [DocumentPositions] -> Session ()
benchSetup :: [DocumentPositions] -> Session (),
    Bench -> Experiment
experiment :: Experiment
  }

select :: HasConfig => Bench -> Bool
select :: HasConfig => Bench -> Bool
select Bench {[Char]
name :: [Char]
name :: Bench -> [Char]
name, Bool
enabled :: Bool
enabled :: Bench -> Bool
enabled} =
  Bool
enabled Bool -> Bool -> Bool
&& (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
mm Bool -> Bool -> Bool
|| [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
mm)
  where
    mm :: [[Char]]
mm = Config -> [[Char]]
matches HasConfig
?config

benchWithSetup ::
  String ->
  ([DocumentPositions] -> Session ()) ->
  Experiment ->
  Bench
benchWithSetup :: [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup [Char]
name [DocumentPositions] -> Session ()
benchSetup Experiment
experiment = Bench {Bool
Natural
[Char]
Experiment
[DocumentPositions] -> Session ()
samples :: Natural
enabled :: Bool
experiment :: Experiment
benchSetup :: [DocumentPositions] -> Session ()
name :: [Char]
experiment :: Experiment
benchSetup :: [DocumentPositions] -> Session ()
samples :: Natural
enabled :: Bool
name :: [Char]
..}
  where
    enabled :: Bool
enabled = Bool
True
    samples :: Natural
samples = Natural
100

bench :: String -> Experiment -> Bench
bench :: [Char] -> Experiment -> Bench
bench [Char]
name = [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup [Char]
name (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()
runBenchmarksFun :: HasConfig => [Char] -> [Bench] -> IO ()
runBenchmarksFun [Char]
dir [Bench]
allBenchmarks = do
  let benchmarks :: [Bench]
benchmarks = [ Bench
b{samples :: Natural
samples = forall a. a -> Maybe a -> a
fromMaybe Natural
100 (Config -> Maybe Natural
repetitions HasConfig
?config) }
                   | Bench
b <- [Bench]
allBenchmarks
                   , HasConfig => Bench -> Bool
select Bench
b ]

  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Config -> Maybe [Char]
otMemoryProfiling HasConfig
?config) forall a b. (a -> b) -> a -> b
$ \[Char]
eventlogDir ->
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
eventlogDir

  Maybe Value
lspConfig <- if Config -> Bool
Experiments.Types.lspConfig HasConfig
?config
    then forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecodeStrict' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
BS.getContents
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  let conf :: SessionConfig
conf = SessionConfig
defaultConfig
        { logStdErr :: Bool
logStdErr = Config -> Bool
verbose HasConfig
?config,
          logMessages :: Bool
logMessages = Config -> Bool
verbose HasConfig
?config,
          logColor :: Bool
logColor = Bool
False,
          lspConfig :: Maybe Value
Language.LSP.Test.lspConfig = Maybe Value
lspConfig,
          messageTimeout :: Int
messageTimeout = Config -> Int
timeoutLsp HasConfig
?config
        }
  [(Bench, BenchRun)]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Bench]
benchmarks forall a b. (a -> b) -> a -> b
$ \b :: Bench
b@Bench{[Char]
name :: [Char]
name :: Bench -> [Char]
name} ->  do
    let p :: CreateProcess
p = ([Char] -> [[Char]] -> CreateProcess
proc (Config -> [Char]
ghcide HasConfig
?config) (HasConfig => [Char] -> [Char] -> [[Char]]
allArgs [Char]
name [Char]
dir))
                { std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }
        run :: Session BenchRun -> IO BenchRun
run Session BenchRun
sess = forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p forall a b. (a -> b) -> a -> b
$ \(Just Handle
inH) (Just Handle
outH) (Just Handle
errH) ProcessHandle
pH -> do
                    -- Need to continuously consume to stderr else it gets blocked
                    -- Can't pass NoStream either to std_err
                    Handle -> BufferMode -> IO ()
hSetBuffering Handle
errH BufferMode
NoBuffering
                    Handle -> Bool -> IO ()
hSetBinaryMode Handle
errH Bool
True
                    let errSinkThread :: IO Any
errSinkThread =
                            forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
errH forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
verbose HasConfig
?config)forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn
                    forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
errSinkThread forall a b. (a -> b) -> a -> b
$ \Async Any
_ -> do
                        forall a.
Maybe ProcessHandle
-> Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> [Char]
-> Session a
-> IO a
runSessionWithHandles' (forall a. a -> Maybe a
Just ProcessHandle
pH) Handle
inH Handle
outH SessionConfig
conf ClientCapabilities
lspTestCaps [Char]
dir Session BenchRun
sess
    (Bench
b,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasConfig =>
(Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun
runBench Session BenchRun -> IO BenchRun
run Bench
b

  -- output raw data as CSV
  let headers :: [[Char]]
headers =
        [ [Char]
"name"
        , [Char]
"success"
        , [Char]
"samples"
        , [Char]
"startup"
        , [Char]
"setup"
        , [Char]
"userT"
        , [Char]
"delayedT"
        , [Char]
"1stBuildT"
        , [Char]
"avgPerRespT"
        , [Char]
"totalT"
        , [Char]
"rulesBuilt"
        , [Char]
"rulesChanged"
        , [Char]
"rulesVisited"
        , [Char]
"rulesTotal"
        , [Char]
"ruleEdges"
        , [Char]
"ghcRebuilds"
        ]
      rows :: [[[Char]]]
rows =
        [ [ [Char]
name,
            forall a. Show a => a -> [Char]
show Bool
success,
            forall a. Show a => a -> [Char]
show Natural
samples,
            Seconds -> [Char]
showMs Seconds
startup,
            Seconds -> [Char]
showMs Seconds
runSetup',
            Seconds -> [Char]
showMs Seconds
userWaits,
            Seconds -> [Char]
showMs Seconds
delayedWork,
            Seconds -> [Char]
showMs forall a b. (a -> b) -> a -> b
$ Seconds
firstResponseforall a. Num a => a -> a -> a
+Seconds
firstResponseDelayed,
            -- Exclude first response as it has a lot of setup time included
            -- Assume that number of requests = number of modules * number of samples
            Seconds -> [Char]
showMs ((Seconds
userWaits forall a. Num a => a -> a -> a
- Seconds
firstResponse)forall a. Fractional a => a -> a -> a
/((forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
samples forall a. Num a => a -> a -> a
- Seconds
1)forall a. Num a => a -> a -> a
*Seconds
modules)),
            Seconds -> [Char]
showMs Seconds
runExperiment,
            forall a. Show a => a -> [Char]
show Int
rulesBuilt,
            forall a. Show a => a -> [Char]
show Int
rulesChanged,
            forall a. Show a => a -> [Char]
show Int
rulesVisited,
            forall a. Show a => a -> [Char]
show Int
rulesTotal,
            forall a. Show a => a -> [Char]
show Int
edgesTotal,
            forall a. Show a => a -> [Char]
show Int
rebuildsTotal
          ]
          | (Bench {[Char]
name :: [Char]
name :: Bench -> [Char]
name, Natural
samples :: Natural
samples :: Bench -> Natural
samples}, BenchRun {Bool
Seconds
Int
success :: BenchRun -> Bool
rebuildsTotal :: BenchRun -> Int
edgesTotal :: BenchRun -> Int
rulesTotal :: BenchRun -> Int
rulesVisited :: BenchRun -> Int
rulesChanged :: BenchRun -> Int
rulesBuilt :: BenchRun -> Int
firstResponseDelayed :: BenchRun -> Seconds
firstResponse :: BenchRun -> Seconds
delayedWork :: BenchRun -> Seconds
userWaits :: BenchRun -> Seconds
runExperiment :: BenchRun -> Seconds
runSetup :: BenchRun -> Seconds
startup :: BenchRun -> Seconds
runSetup :: Seconds
rebuildsTotal :: Int
edgesTotal :: Int
rulesTotal :: Int
rulesVisited :: Int
rulesChanged :: Int
rulesBuilt :: Int
runExperiment :: Seconds
firstResponseDelayed :: Seconds
firstResponse :: Seconds
delayedWork :: Seconds
userWaits :: Seconds
startup :: Seconds
success :: Bool
..}) <- [(Bench, BenchRun)]
results,
            let runSetup' :: Seconds
runSetup' = if Seconds
runSetup forall a. Ord a => a -> a -> Bool
< Seconds
0.01 then Seconds
0 else Seconds
runSetup
                modules :: Seconds
modules = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ Example -> [[Char]]
exampleModules forall a b. (a -> b) -> a -> b
$ Config -> Example
example HasConfig
?config
        ]
      csv :: [Char]
csv = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", ") ([[Char]]
headers forall a. a -> [a] -> [a]
: [[[Char]]]
rows)
  [Char] -> [Char] -> IO ()
writeFile (Config -> [Char]
outputCSV HasConfig
?config) [Char]
csv

  -- print a nice table
  let pads :: [Int]
pads = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length) (forall a. [[a]] -> [[a]]
transpose ([[Char]]
headers forall a. a -> [a] -> [a]
: [[[Char]]]
rowsHuman))
      paddedHeaders :: [[Char]]
paddedHeaders = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Char] -> [Char]
pad [Int]
pads [[Char]]
headers
      outputRow :: [[Char]] -> IO ()
outputRow = [Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" | "
      rowsHuman :: [[[Char]]]
rowsHuman =
        [ [ [Char]
name,
            forall a. Show a => a -> [Char]
show Bool
success,
            forall a. Show a => a -> [Char]
show Natural
samples,
            Seconds -> [Char]
showDuration Seconds
startup,
            Seconds -> [Char]
showDuration Seconds
runSetup',
            Seconds -> [Char]
showDuration Seconds
userWaits,
            Seconds -> [Char]
showDuration Seconds
delayedWork,
            Seconds -> [Char]
showDuration Seconds
firstResponse,
            Seconds -> [Char]
showDuration Seconds
runExperiment,
            forall a. Show a => a -> [Char]
show Int
rulesBuilt,
            forall a. Show a => a -> [Char]
show Int
rulesChanged,
            forall a. Show a => a -> [Char]
show Int
rulesVisited,
            forall a. Show a => a -> [Char]
show Int
rulesTotal,
            forall a. Show a => a -> [Char]
show Int
edgesTotal,
            forall a. Show a => a -> [Char]
show Int
rebuildsTotal
          ]
          | (Bench {[Char]
name :: [Char]
name :: Bench -> [Char]
name, Natural
samples :: Natural
samples :: Bench -> Natural
samples}, BenchRun {Bool
Seconds
Int
firstResponseDelayed :: Seconds
runSetup :: Seconds
rebuildsTotal :: Int
edgesTotal :: Int
rulesTotal :: Int
rulesVisited :: Int
rulesChanged :: Int
rulesBuilt :: Int
runExperiment :: Seconds
firstResponse :: Seconds
delayedWork :: Seconds
userWaits :: Seconds
startup :: Seconds
success :: Bool
success :: BenchRun -> Bool
rebuildsTotal :: BenchRun -> Int
edgesTotal :: BenchRun -> Int
rulesTotal :: BenchRun -> Int
rulesVisited :: BenchRun -> Int
rulesChanged :: BenchRun -> Int
rulesBuilt :: BenchRun -> Int
firstResponseDelayed :: BenchRun -> Seconds
firstResponse :: BenchRun -> Seconds
delayedWork :: BenchRun -> Seconds
userWaits :: BenchRun -> Seconds
runExperiment :: BenchRun -> Seconds
runSetup :: BenchRun -> Seconds
startup :: BenchRun -> Seconds
..}) <- [(Bench, BenchRun)]
results,
            let runSetup' :: Seconds
runSetup' = if Seconds
runSetup forall a. Ord a => a -> a -> Bool
< Seconds
0.01 then Seconds
0 else Seconds
runSetup
        ]
  [[Char]] -> IO ()
outputRow [[Char]]
paddedHeaders
  [[Char]] -> IO ()
outputRow forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map) (forall a b. a -> b -> a
const Char
'-') [[Char]]
paddedHeaders
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[[Char]]]
rowsHuman forall a b. (a -> b) -> a -> b
$ \[[Char]]
row -> [[Char]] -> IO ()
outputRow forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Char] -> [Char]
pad [Int]
pads [[Char]]
row
  where
    ghcideArgs :: a -> [a]
ghcideArgs a
dir =
        [ a
"--lsp",
          a
"--test",
          a
"--cwd",
          a
dir
        ]
    allArgs :: [Char] -> [Char] -> [[Char]]
allArgs [Char]
name [Char]
dir =
        forall {a}. IsString a => a -> [a]
ghcideArgs [Char]
dir
          forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ [Char]
"+RTS"
               , [Char]
"-l"
               , [Char]
"-ol" forall a. [a] -> [a] -> [a]
++ ([Char]
dir [Char] -> [Char] -> [Char]
</> forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' then Char
'-' else Char
c) [Char]
name [Char] -> [Char] -> [Char]
<.> [Char]
"eventlog")
               , [Char]
"-RTS"
               ]
             | Just [Char]
dir <- [Config -> Maybe [Char]
otMemoryProfiling HasConfig
?config]
             ]
          forall a. [a] -> [a] -> [a]
++ Config -> [[Char]]
ghcideOptions HasConfig
?config
          forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [[Char]
"--shake-profiling", [Char]
path] | Just [Char]
path <- [Config -> Maybe [Char]
shakeProfiling HasConfig
?config]
            ]
          forall a. [a] -> [a] -> [a]
++ [[Char]
"--ot-memory-profiling" | Just [Char]
_ <- [Config -> Maybe [Char]
otMemoryProfiling HasConfig
?config]]
    lspTestCaps :: ClientCapabilities
lspTestCaps =
      ClientCapabilities
fullCaps {$sel:_window:ClientCapabilities :: Maybe WindowClientCapabilities
_window = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Bool
-> Maybe ShowMessageRequestClientCapabilities
-> Maybe ShowDocumentClientCapabilities
-> WindowClientCapabilities
WindowClientCapabilities (forall a. a -> Maybe a
Just Bool
True) forall a. Maybe a
Nothing forall a. Maybe a
Nothing }

showMs :: Seconds -> String
showMs :: Seconds -> [Char]
showMs = forall r. PrintfType r => [Char] -> r
printf [Char]
"%.2f"

data BenchRun = BenchRun
  { BenchRun -> Seconds
startup              :: !Seconds,
    BenchRun -> Seconds
runSetup             :: !Seconds,
    BenchRun -> Seconds
runExperiment        :: !Seconds,
    BenchRun -> Seconds
userWaits            :: !Seconds,
    BenchRun -> Seconds
delayedWork          :: !Seconds,
    BenchRun -> Seconds
firstResponse        :: !Seconds,
    BenchRun -> Seconds
firstResponseDelayed :: !Seconds,
    BenchRun -> Int
rulesBuilt           :: !Int,
    BenchRun -> Int
rulesChanged         :: !Int,
    BenchRun -> Int
rulesVisited         :: !Int,
    BenchRun -> Int
rulesTotal           :: !Int,
    BenchRun -> Int
edgesTotal           :: !Int,
    BenchRun -> Int
rebuildsTotal        :: !Int,
    BenchRun -> Bool
success              :: !Bool
  }

badRun :: BenchRun
badRun :: BenchRun
badRun = Seconds
-> Seconds
-> Seconds
-> Seconds
-> Seconds
-> Seconds
-> Seconds
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Bool
-> BenchRun
BenchRun Seconds
0 Seconds
0 Seconds
0 Seconds
0 Seconds
0 Seconds
0 Seconds
0 Int
0 Int
0 Int
0 Int
0 Int
0 Int
0 Bool
False

waitForProgressStart :: Session ()
waitForProgressStart :: Session ()
waitForProgressStart = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy forall a b. (a -> b) -> a -> b
$ \case
      FromServerMess SMethod m
SWindowWorkDoneProgressCreate Message m
_ -> Bool
True
      FromServerMessage
_                                              -> Bool
False

-- | Wait for all progress to be done
-- Needs at least one progress done notification to return
waitForProgressDone :: Session ()
waitForProgressDone :: Session ()
waitForProgressDone = Session ()
loop
  where
    loop :: Session ()
loop = do
      ~() <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess SMethod m
SProgress (NotificationMessage Text
_ SMethod 'Progress
_ (ProgressParams ProgressToken
_ (End WorkDoneProgressEndParams
_))) -> forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> forall a. Maybe a
Nothing
      Bool
done <- forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done Session ()
loop

-- | Wait for the build queue to be empty
waitForBuildQueue :: Session Seconds
waitForBuildQueue :: Session Seconds
waitForBuildQueue = do
    let m :: SMethod 'CustomMethod
m = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m (forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, ResponseMessage 'CustomMethod
resp) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
m LspId 'CustomMethod
waitId
    case ResponseMessage 'CustomMethod
resp of
        ResponseMessage{$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result=Right Value
ResponseResult 'CustomMethod
Null} -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        ResponseMessage 'CustomMethod
_                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
0

runBench ::
  HasConfig =>
  (Session BenchRun -> IO BenchRun) ->
  Bench ->
  IO BenchRun
runBench :: HasConfig =>
(Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun
runBench Session BenchRun -> IO BenchRun
runSess Bench
b = forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
handleAny (\SomeException
e -> forall a. Show a => a -> IO ()
print SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return BenchRun
badRun)
  forall a b. (a -> b) -> a -> b
$ Session BenchRun -> IO BenchRun
runSess
  forall a b. (a -> b) -> a -> b
$ do
    case Bench
b of
     Bench{Bool
Natural
[Char]
Experiment
[DocumentPositions] -> Session ()
experiment :: Experiment
benchSetup :: [DocumentPositions] -> Session ()
samples :: Natural
enabled :: Bool
name :: [Char]
experiment :: Bench -> Experiment
benchSetup :: Bench -> [DocumentPositions] -> Session ()
samples :: Bench -> Natural
enabled :: Bench -> Bool
name :: Bench -> [Char]
..} -> do
      (Seconds
startup, [DocumentPositions]
docs) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ do
        (Seconds
d, [DocumentPositions]
docs) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ Config -> Session [DocumentPositions]
setupDocumentContents HasConfig
?config
        forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output forall a b. (a -> b) -> a -> b
$ [Char]
"Setting up document contents took " forall a. Semigroup a => a -> a -> a
<> Seconds -> [Char]
showDuration Seconds
d
        -- wait again, as the progress is restarted once while loading the cradle
        -- make an edit, to ensure this doesn't block
        let DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
doc :: DocumentPositions -> TextDocumentIdentifier
stringLiteralP :: DocumentPositions -> Position
identifierP :: DocumentPositions -> Maybe Position
..} = forall a. [a] -> a
head [DocumentPositions]
docs
        TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        Session ()
waitForProgressDone
        forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentPositions]
docs

      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output forall a b. (a -> b) -> a -> b
$ [Char]
"Running " forall a. Semigroup a => a -> a -> a
<> [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" benchmark"
      (Seconds
runSetup, ()) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ [DocumentPositions] -> Session ()
benchSetup [DocumentPositions]
docs
      let loop' :: Maybe (Seconds, Seconds)
-> Seconds
-> Seconds
-> Natural
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
loop' (Just (Seconds, Seconds)
timeForFirstResponse) !Seconds
userWaits !Seconds
delayedWork Natural
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Seconds
userWaits, Seconds
delayedWork, (Seconds, Seconds)
timeForFirstResponse)
          loop' Maybe (Seconds, Seconds)
timeForFirstResponse !Seconds
userWaits !Seconds
delayedWork Natural
n = do
            (Seconds
t, Bool
res) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ Experiment
experiment [DocumentPositions]
docs
            if Bool -> Bool
not Bool
res
              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            else do
                forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output (Seconds -> [Char]
showDuration Seconds
t)
                -- Wait for the delayed actions to finish
                Seconds
td <- Session Seconds
waitForBuildQueue
                Maybe (Seconds, Seconds)
-> Seconds
-> Seconds
-> Natural
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
loop' (Maybe (Seconds, Seconds)
timeForFirstResponse forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (Seconds
t,Seconds
td)) (Seconds
userWaitsforall a. Num a => a -> a -> a
+Seconds
t) (Seconds
delayedWorkforall a. Num a => a -> a -> a
+Seconds
td) (Natural
n forall a. Num a => a -> a -> a
-Natural
1)
          loop :: Seconds
-> Seconds
-> Natural
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
loop = Maybe (Seconds, Seconds)
-> Seconds
-> Seconds
-> Natural
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
loop' forall a. Maybe a
Nothing

      (Seconds
runExperiment, Maybe (Seconds, Seconds, (Seconds, Seconds))
result) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration forall a b. (a -> b) -> a -> b
$ Seconds
-> Seconds
-> Natural
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
loop Seconds
0 Seconds
0 Natural
samples
      let success :: Bool
success = forall a. Maybe a -> Bool
isJust Maybe (Seconds, Seconds, (Seconds, Seconds))
result
          (Seconds
userWaits, Seconds
delayedWork, (Seconds
firstResponse, Seconds
firstResponseDelayed)) = forall a. a -> Maybe a -> a
fromMaybe (Seconds
0,Seconds
0,(Seconds
0,Seconds
0)) Maybe (Seconds, Seconds, (Seconds, Seconds))
result

      Int
rulesTotal <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session [Text]
getStoredKeys
      Int
rulesBuilt <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Int
0) forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Either ResponseError [Text])
getBuildKeysBuilt
      Int
rulesChanged <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Int
0) forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Either ResponseError [Text])
getBuildKeysChanged
      Int
rulesVisited <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Int
0) forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Either ResponseError [Text])
getBuildKeysVisited
      Int
edgesTotal   <- forall b a. b -> Either a b -> b
fromRight Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Either ResponseError Int)
getBuildEdgesCount
      Int
rebuildsTotal <- forall b a. b -> Either a b -> b
fromRight Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Either ResponseError Int)
getRebuildsCount

      forall (m :: * -> *) a. Monad m => a -> m a
return BenchRun {Bool
Seconds
Int
rebuildsTotal :: Int
edgesTotal :: Int
rulesVisited :: Int
rulesChanged :: Int
rulesBuilt :: Int
rulesTotal :: Int
firstResponseDelayed :: Seconds
firstResponse :: Seconds
delayedWork :: Seconds
userWaits :: Seconds
success :: Bool
runExperiment :: Seconds
runSetup :: Seconds
startup :: Seconds
success :: Bool
rebuildsTotal :: Int
edgesTotal :: Int
rulesTotal :: Int
rulesVisited :: Int
rulesChanged :: Int
rulesBuilt :: Int
firstResponseDelayed :: Seconds
firstResponse :: Seconds
delayedWork :: Seconds
userWaits :: Seconds
runExperiment :: Seconds
runSetup :: Seconds
startup :: Seconds
..}

data SetupResult = SetupResult {
    SetupResult -> [Bench] -> IO ()
runBenchmarks :: [Bench] -> IO (),
    -- | Path to the setup benchmark example
    SetupResult -> [Char]
benchDir      :: FilePath,
    SetupResult -> IO ()
cleanUp       :: IO ()
}

callCommandLogging :: HasConfig => String -> IO ()
callCommandLogging :: HasConfig => [Char] -> IO ()
callCommandLogging [Char]
cmd = do
    forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output [Char]
cmd
    [Char] -> IO ()
callCommand [Char]
cmd

setup :: HasConfig => IO SetupResult
setup :: HasConfig => IO SetupResult
setup = do
--   when alreadyExists $ removeDirectoryRecursive examplesPath
  [Char]
benchDir <- case Example -> Either [Char] ExamplePackage
exampleDetails(Config -> Example
example HasConfig
?config) of
      Left [Char]
examplePath -> do
          let hieYamlPath :: [Char]
hieYamlPath = [Char]
examplePath [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
          Bool
alreadyExists <- [Char] -> IO Bool
doesFileExist [Char]
hieYamlPath
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists forall a b. (a -> b) -> a -> b
$
                forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ ([Char] -> CmdOption
Cwd [Char]
examplePath) ([Char] -> CmdOption
FileStdout [Char]
hieYamlPath) ([Char]
"gen-hie"::String)
          forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
examplePath
      Right ExamplePackage{[Char]
Version
packageVersion :: ExamplePackage -> Version
packageName :: ExamplePackage -> [Char]
packageVersion :: Version
packageName :: [Char]
..} -> do
        let path :: [Char]
path = [Char]
examplesPath [Char] -> [Char] -> [Char]
</> [Char]
package
            package :: [Char]
package = [Char]
packageName forall a. Semigroup a => a -> a -> a
<> [Char]
"-" forall a. Semigroup a => a -> a -> a
<> Version -> [Char]
showVersion Version
packageVersion
            hieYamlPath :: [Char]
hieYamlPath = [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
        Bool
alreadySetup <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadySetup forall a b. (a -> b) -> a -> b
$
          case Config -> CabalStack
buildTool HasConfig
?config of
            CabalStack
Cabal -> do
                let cabalVerbosity :: [Char]
cabalVerbosity = [Char]
"-v" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Enum a => a -> Int
fromEnum (Config -> Bool
verbose HasConfig
?config))
                HasConfig => [Char] -> IO ()
callCommandLogging forall a b. (a -> b) -> a -> b
$ [Char]
"cabal get " forall a. Semigroup a => a -> a -> a
<> [Char]
cabalVerbosity forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> [Char]
package forall a. Semigroup a => a -> a -> a
<> [Char]
" -d " forall a. Semigroup a => a -> a -> a
<> [Char]
examplesPath
                let hieYamlPath :: [Char]
hieYamlPath = [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
                forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ ([Char] -> CmdOption
Cwd [Char]
path) ([Char] -> CmdOption
FileStdout [Char]
hieYamlPath) ([Char]
"gen-hie"::String)
                -- Need this in case there is a parent cabal.project somewhere
                [Char] -> [Char] -> IO ()
writeFile
                    ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"cabal.project")
                    [Char]
"packages: ."
                [Char] -> [Char] -> IO ()
writeFile
                    ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"cabal.project.local")
                    [Char]
""
            CabalStack
Stack -> do
                let stackVerbosity :: [Char]
stackVerbosity = case Config -> Verbosity
verbosity HasConfig
?config of
                        Verbosity
Quiet  -> [Char]
"--silent"
                        Verbosity
Normal -> [Char]
""
                        Verbosity
All    -> [Char]
"--verbose"
                HasConfig => [Char] -> IO ()
callCommandLogging forall a b. (a -> b) -> a -> b
$ [Char]
"stack " forall a. Semigroup a => a -> a -> a
<> [Char]
stackVerbosity forall a. Semigroup a => a -> a -> a
<> [Char]
" unpack " forall a. Semigroup a => a -> a -> a
<> [Char]
package forall a. Semigroup a => a -> a -> a
<> [Char]
" --to " forall a. Semigroup a => a -> a -> a
<> [Char]
examplesPath
                -- Generate the stack descriptor to match the one used to build ghcide
                [Char]
stack_yaml <- forall a. a -> Maybe a -> a
fromMaybe [Char]
"stack.yaml" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
getEnv [Char]
"STACK_YAML"
                [[Char]]
stack_yaml_lines <- [Char] -> [[Char]]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
stack_yaml
                [Char] -> [Char] -> IO ()
writeFile ([Char]
path [Char] -> [Char] -> [Char]
</> [Char]
stack_yaml)
                        ([[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
                        [Char]
"packages: [.]" forall a. a -> [a] -> [a]
:
                            [ [Char]
l
                            | [Char]
l <- [[Char]]
stack_yaml_lines
                            , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
l)
                                [[Char]
"resolver"
                                ,[Char]
"allow-newer"
                                ,[Char]
"compiler"]
                            ]
                        )

                forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ ([Char] -> CmdOption
Cwd [Char]
path) ([Char] -> CmdOption
FileStdout [Char]
hieYamlPath) ([Char]
"gen-hie"::String) [[Char]
"--stack"::String]
        forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
path

  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (Config -> Maybe [Char]
shakeProfiling HasConfig
?config) forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True

  let cleanUp :: IO ()
cleanUp = case Example -> Either [Char] ExamplePackage
exampleDetails(Config -> Example
example HasConfig
?config) of
        Right ExamplePackage
_ -> [Char] -> IO ()
removeDirectoryRecursive [Char]
examplesPath
        Left [Char]
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      runBenchmarks :: [Bench] -> IO ()
runBenchmarks = HasConfig => [Char] -> [Bench] -> IO ()
runBenchmarksFun [Char]
benchDir

  forall (m :: * -> *) a. Monad m => a -> m a
return SetupResult{[Char]
IO ()
[Bench] -> IO ()
runBenchmarks :: [Bench] -> IO ()
cleanUp :: IO ()
benchDir :: [Char]
cleanUp :: IO ()
benchDir :: [Char]
runBenchmarks :: [Bench] -> IO ()
..}

setupDocumentContents :: Config -> Session [DocumentPositions]
setupDocumentContents :: Config -> Session [DocumentPositions]
setupDocumentContents Config
config =
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Example -> [[Char]]
exampleModules forall a b. (a -> b) -> a -> b
$ Config -> Example
example Config
config) forall a b. (a -> b) -> a -> b
$ \[Char]
m -> do
        TextDocumentIdentifier
doc <- [Char] -> Text -> Session TextDocumentIdentifier
openDoc [Char]
m Text
"haskell"

        -- Setup the special positions used by the experiments
        UInt
lastLine <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
        TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [TextDocumentContentChangeEvent
            { $sel:_range:TextDocumentContentChangeEvent :: Maybe Range
_range = forall a. a -> Maybe a
Just (Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
lastLine UInt
0) (UInt -> UInt -> Position
Position UInt
lastLine UInt
0))
            , $sel:_rangeLength:TextDocumentContentChangeEvent :: Maybe UInt
_rangeLength = forall a. Maybe a
Nothing
            , $sel:_text:TextDocumentContentChangeEvent :: Text
_text = [Text] -> Text
T.unlines [ Text
"_hygienic = \"hygienic\"" ]
            }]
        let
        -- Points to a string in the target file,
        -- convenient for hygienic edits
            stringLiteralP :: Position
stringLiteralP = UInt -> UInt -> Position
Position UInt
lastLine UInt
15

        -- Find an identifier defined in another file in this project
        Either [DocumentSymbol] [SymbolInformation]
symbols <- TextDocumentIdentifier
-> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols TextDocumentIdentifier
doc
        let endOfImports :: Position
endOfImports = case Either [DocumentSymbol] [SymbolInformation]
symbols of
                Left [DocumentSymbol]
symbols | Just Position
x <- [DocumentSymbol] -> Maybe Position
findEndOfImports [DocumentSymbol]
symbols -> Position
x
                Either [DocumentSymbol] [SymbolInformation]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"symbols: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Either [DocumentSymbol] [SymbolInformation]
symbols
        Text
contents <- TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
        Maybe Position
identifierP <- TextDocumentIdentifier
-> Text -> Position -> Session (Maybe Position)
searchSymbol TextDocumentIdentifier
doc Text
contents Position
endOfImports
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
doc :: TextDocumentIdentifier
stringLiteralP :: Position
identifierP :: Maybe Position
..}

findEndOfImports :: [DocumentSymbol] -> Maybe Position
findEndOfImports :: [DocumentSymbol] -> Maybe Position
findEndOfImports (DocumentSymbol{$sel:_kind:DocumentSymbol :: DocumentSymbol -> SymbolKind
_kind = SymbolKind
SkModule, $sel:_name:DocumentSymbol :: DocumentSymbol -> Text
_name = Text
"imports", Range
$sel:_range:DocumentSymbol :: DocumentSymbol -> Range
_range :: Range
_range} : [DocumentSymbol]
_) =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ UInt -> UInt -> Position
Position (forall a. Enum a => a -> a
succ forall a b. (a -> b) -> a -> b
$ Position -> UInt
_line forall a b. (a -> b) -> a -> b
$ Range -> Position
_end Range
_range) UInt
4
findEndOfImports [DocumentSymbol{$sel:_kind:DocumentSymbol :: DocumentSymbol -> SymbolKind
_kind = SymbolKind
SkFile, $sel:_children:DocumentSymbol :: DocumentSymbol -> Maybe (List DocumentSymbol)
_children = Just (List [DocumentSymbol]
cc)}] =
    [DocumentSymbol] -> Maybe Position
findEndOfImports [DocumentSymbol]
cc
findEndOfImports (DocumentSymbol{Range
_range :: Range
$sel:_range:DocumentSymbol :: DocumentSymbol -> Range
_range} : [DocumentSymbol]
_) =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Range -> Position
_start Range
_range
findEndOfImports [DocumentSymbol]
_ = forall a. Maybe a
Nothing

--------------------------------------------------------------------------------------------

pad :: Int -> String -> String
pad :: Int -> [Char] -> [Char]
pad Int
n []     = forall a. Int -> a -> [a]
replicate Int
n Char
' '
pad Int
0 [Char]
_      = forall a. HasCallStack => [Char] -> a
error [Char]
"pad"
pad Int
n (Char
x:[Char]
xx) = Char
x forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
pad (Int
nforall a. Num a => a -> a -> a
-Int
1) [Char]
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 :: TextDocumentIdentifier
-> Text -> Position -> Session (Maybe Position)
searchSymbol doc :: TextDocumentIdentifier
doc@TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} Text
fileContents Position
pos = do
    -- this search is expensive, so we cache the result on disk
    let cachedPath :: [Char]
cachedPath = forall a. HasCallStack => Maybe a -> a
fromJust (Uri -> Maybe [Char]
uriToFilePath Uri
_uri) [Char] -> [Char] -> [Char]
<.> [Char]
"identifierPosition"
    Either IOException (Maybe Position)
cachedRes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @IOException forall a b. (a -> b) -> a -> b
$ forall a. Read a => [Char] -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [Char]
readFile [Char]
cachedPath
    case Either IOException (Maybe Position)
cachedRes of
        Left IOException
_ -> do
            Maybe Position
result <- Position -> Session (Maybe Position)
loop Position
pos
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
cachedPath forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Maybe Position
result
            forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Position
result
        Right Maybe Position
res ->
            forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Position
res
  where
      loop :: Position -> Session (Maybe Position)
loop Position
pos
        | (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Position -> UInt
_line Position
pos) forall a. Ord a => a -> a -> Bool
>= Int
lll =
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Position -> UInt
_character Position
pos) forall a. Ord a => a -> a -> Bool
>= Int -> Int
lengthOfLine (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Position -> UInt
_line Position
pos) =
            Position -> Session (Maybe Position)
loop (Position -> Position
nextLine Position
pos)
        | Bool
otherwise = do
                Bool
checks <- Position -> Session Bool
checkDefinitions Position
pos forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Position -> Session Bool
checkCompletions Position
pos
                if Bool
checks
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Position
pos
                    else Position -> Session (Maybe Position)
loop (Position -> Position
nextIdent Position
pos)

      nextIdent :: Position -> Position
nextIdent Position
p = Position
p{_character :: UInt
_character = Position -> UInt
_character Position
p forall a. Num a => a -> a -> a
+ UInt
2}
      nextLine :: Position -> Position
nextLine Position
p = UInt -> UInt -> Position
Position (Position -> UInt
_line Position
p forall a. Num a => a -> a -> a
+ UInt
1) UInt
4

      lengthOfLine :: Int -> Int
lengthOfLine Int
n = if Int
n forall a. Ord a => a -> a -> Bool
>= Int
lll then Int
0 else Text -> Int
T.length ([Text]
ll forall a. [a] -> Int -> a
!! Int
n)
      ll :: [Text]
ll = Text -> [Text]
T.lines Text
fileContents
      lll :: Int
lll = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ll

      checkDefinitions :: Position -> Session Bool
checkDefinitions Position
pos = do
        [Location] |? [LocationLink]
defs <- TextDocumentIdentifier
-> Position -> Session ([Location] |? [LocationLink])
getDefinitions TextDocumentIdentifier
doc Position
pos
        case [Location] |? [LocationLink]
defs of
            (InL [Location Uri
uri Range
_]) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Uri
uri forall a. Eq a => a -> a -> Bool
/= Uri
_uri
            [Location] |? [LocationLink]
_                      -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      checkCompletions :: Position -> Session Bool
checkCompletions Position
pos =
        Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions TextDocumentIdentifier
doc Position
pos


getBuildKeysBuilt :: Session (Either ResponseError [T.Text])
getBuildKeysBuilt :: Session (Either ResponseError [Text])
getBuildKeysBuilt = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
GetBuildKeysBuilt

getBuildKeysVisited :: Session (Either ResponseError [T.Text])
getBuildKeysVisited :: Session (Either ResponseError [Text])
getBuildKeysVisited = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
GetBuildKeysVisited

getBuildKeysChanged :: Session (Either ResponseError [T.Text])
getBuildKeysChanged :: Session (Either ResponseError [Text])
getBuildKeysChanged = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
GetBuildKeysChanged

getBuildEdgesCount :: Session (Either ResponseError Int)
getBuildEdgesCount :: Session (Either ResponseError Int)
getBuildEdgesCount = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
GetBuildEdgesCount

getRebuildsCount :: Session (Either ResponseError Int)
getRebuildsCount :: Session (Either ResponseError Int)
getRebuildsCount = forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
GetRebuildsCount

-- Copy&paste from ghcide/test/Development.IDE.Test
getStoredKeys :: Session [Text]
getStoredKeys :: Session [Text]
getStoredKeys = forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
GetStoredKeys

-- Copy&paste from ghcide/test/Development.IDE.Test
tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin :: forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
cmd = do
    let cm :: SMethod 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    ResponseMessage{Either ResponseError (ResponseResult 'CustomMethod)
_result :: Either ResponseError (ResponseResult 'CustomMethod)
$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result} <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
waitId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either ResponseError (ResponseResult 'CustomMethod)
_result of
         Left ResponseError
e -> forall a b. a -> Either a b
Left ResponseError
e
         Right ResponseResult 'CustomMethod
json -> case forall a. FromJSON a => Value -> Result a
A.fromJSON ResponseResult 'CustomMethod
json of
             A.Success b
a -> forall a b. b -> Either a b
Right b
a
             A.Error [Char]
e   -> forall a. HasCallStack => [Char] -> a
error [Char]
e

-- Copy&paste from ghcide/test/Development.IDE.Test
callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
callTestPlugin :: forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
cmd = do
    Either ResponseError b
res <- forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
cmd
    case Either ResponseError b
res of
        Left (ResponseError ErrorCode
t Text
err Maybe Value
_) -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ErrorCode
t forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
        Right b
a                      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a