{-# 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 {
DocumentPositions -> Maybe Position
identifierP :: Maybe Position,
DocumentPositions -> Position
stringLiteralP :: !Position,
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
[] -> 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]
Session ()
waitForProgressStart
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
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
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
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,
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
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
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
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
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
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)
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 (),
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
[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)
[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
[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"
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
stringLiteralP :: Position
stringLiteralP = UInt -> UInt -> Position
Position UInt
lastLine UInt
15
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
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
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
getStoredKeys :: Session [Text]
getStoredKeys :: Session [Text]
getStoredKeys = forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
GetStoredKeys
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
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