{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE ImplicitParams     #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}

module Experiments
( Bench(..)
, BenchRun(..)
, Config(..)
, Verbosity(..)
, CabalStack(..)
, SetupResult(..)
, Example(..)
, experiments
, configP
, defConfig
, output
, setup
, runBench
, exampleToOptions
) where
import           Control.Applicative.Combinators    (skipManyTill)
import           Control.Concurrent.Async           (withAsync)
import           Control.Exception.Safe             (IOException, handleAny,
                                                     try)
import           Control.Lens                       (_Just, (&), (.~), (^.),
                                                     (^?))
import           Control.Lens.Extras                (is)
import           Control.Monad.Extra                (allM, forM, forM_, forever,
                                                     unless, void, when,
                                                     whenJust, (&&^))
import           Control.Monad.IO.Class
import           Data.Aeson                         (Value (Null),
                                                     eitherDecodeStrict',
                                                     toJSON)
import qualified Data.Aeson                         as A
import qualified Data.ByteString                    as BS
import qualified Data.ByteString.Lazy               as BSL
import           Data.Either                        (fromRight)
import           Data.List
import           Data.Maybe
import           Data.Proxy
import           Data.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), cmd_)
import           Experiments.Types
import           Language.LSP.Protocol.Capabilities
import qualified Language.LSP.Protocol.Lens         as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types        hiding (Null,
                                                     SemanticTokenAbsolute (..))
import qualified Language.LSP.Protocol.Types        as LSP
import           Language.LSP.Test
import           Numeric.Natural
import           Options.Applicative
import           System.Directory
import           System.Environment.Blank           (getEnv)
import           System.FilePath                    ((<.>), (</>))
import           System.IO
import           System.Process
import           System.Time.Extra
import           Text.ParserCombinators.ReadP       (readP_to_S)
import           Text.Printf

charEdit :: Position -> TextDocumentContentChangeEvent
charEdit :: Position -> TextDocumentContentChangeEvent
charEdit Position
p =
    (TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
        { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range Position
p Position
p
        , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
        , $sel:_text:TextDocumentContentChangePartial :: Text
_text = Text
"a"
        }

headerEdit :: TextDocumentContentChangeEvent
headerEdit :: TextDocumentContentChangeEvent
headerEdit =
    (TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
        { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
0 UInt
0) (UInt -> UInt -> Position
Position UInt
0 UInt
0)
        , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
        , $sel:_text:TextDocumentContentChangePartial :: Text
_text = Text
"-- header comment \n"
        }

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
    []    -> [Char] -> m Bool
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"None of the example modules have identifier positions"
    [DocumentPositions]
docs' -> (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DocumentPositions -> m Bool
f [DocumentPositions]
docs'
  where
    applicableDocs :: [DocumentPositions]
applicableDocs = (DocumentPositions -> Bool)
-> [DocumentPositions] -> [DocumentPositions]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Position -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Position -> Bool)
-> (DocumentPositions -> Maybe Position)
-> DocumentPositions
-> Bool
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]
"semanticTokens" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Starting semanticTokens"
        [Bool]
r <- [DocumentPositions]
-> (DocumentPositions -> Session Bool) -> Session [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session [Bool])
-> (DocumentPositions -> Session Bool) -> Session [Bool]
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
            Session ()
waitForProgressStart
            Session ()
waitForProgressDone
            SemanticTokens |? Null
tks <- TextDocumentIdentifier -> Session (SemanticTokens |? Null)
getSemanticTokens TextDocumentIdentifier
doc
            case SemanticTokens |? Null
tks (SemanticTokens |? Null)
-> Getting
     (First SemanticTokens) (SemanticTokens |? Null) SemanticTokens
-> Maybe SemanticTokens
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First SemanticTokens) (SemanticTokens |? Null) SemanticTokens
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (a |? b) (f (a |? b))
LSP._L of
                Just SemanticTokens
_  -> Bool -> Session Bool
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                Maybe SemanticTokens
Nothing -> Bool -> Session Bool
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool -> Session Bool
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Session Bool) -> Bool -> Session Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"hover" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos ((DocumentPositions -> Session Bool) -> Experiment)
-> (DocumentPositions -> Session Bool) -> Experiment
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
        Maybe Hover -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Hover -> Bool) -> Session (Maybe Hover) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"hover after edit" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          Maybe Hover -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Hover -> Bool) -> Session (Maybe Hover) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench
        [Char]
"hover after cradle edit"
        (\[DocumentPositions]
docs -> do
            Uri
hieYamlUri <- [Char] -> Session Uri
getDocUri [Char]
"hie.yaml"
            IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
appendFile (Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe [Char]
uriToFilePath Uri
hieYamlUri) [Char]
"##\n"
            SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> Session ()
forall (m :: Method 'ClientToServer 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
SMethod_WorkspaceDidChangeWatchedFiles (MessageParams 'Method_WorkspaceDidChangeWatchedFiles
 -> Session ())
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> Session ()
forall a b. (a -> b) -> a -> b
$ [FileEvent] -> DidChangeWatchedFilesParams
DidChangeWatchedFilesParams
             [ Uri -> FileChangeType -> FileEvent
FileEvent Uri
hieYamlUri FileChangeType
FileChangeType_Changed ]
            ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> Maybe Hover -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Hover -> Bool) -> Session (Maybe Hover) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP)
        ),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"edit" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> 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
        [Char] -> Session ()
forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output [Char]
"edit: waitForProgressDone"
        Session ()
waitForProgressDone
        Bool -> Session Bool
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"edit-header" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [TextDocumentContentChangeEvent
headerEdit]
          -- wait for a fresh build start
          Session ()
waitForProgressStart
        -- wait for the build to be finished
        [Char] -> Session ()
forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output [Char]
"edit: waitForProgressDone"
        Session ()
waitForProgressDone
        Bool -> Session Bool
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"getDefinition" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos ((DocumentPositions -> Session Bool) -> Experiment)
-> (DocumentPositions -> Session Bool) -> Experiment
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
        (Definition |? ([DefinitionLink] |? Null)) -> Bool
forall {t :: * -> *} {a}.
Foldable t =>
(Definition |? (t a |? Null)) -> Bool
hasDefinitions ((Definition |? ([DefinitionLink] |? Null)) -> Bool)
-> Session (Definition |? ([DefinitionLink] |? Null))
-> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Position -> Session (Definition |? ([DefinitionLink] |? Null))
getDefinitions TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"getDefinition after edit" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
          [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
          ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
            (Definition |? ([DefinitionLink] |? Null)) -> Bool
forall {t :: * -> *} {a}.
Foldable t =>
(Definition |? (t a |? Null)) -> Bool
hasDefinitions ((Definition |? ([DefinitionLink] |? Null)) -> Bool)
-> Session (Definition |? ([DefinitionLink] |? Null))
-> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Position -> Session (Definition |? ([DefinitionLink] |? Null))
getDefinitions TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"documentSymbols" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ((DocumentPositions -> Session Bool) -> Experiment)
-> (DocumentPositions -> Session Bool) -> Experiment
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
        (Either [SymbolInformation] [DocumentSymbol] -> Bool)
-> Session (Either [SymbolInformation] [DocumentSymbol])
-> Session Bool
forall a b. (a -> b) -> Session a -> Session b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([SymbolInformation] -> Bool)
-> ([DocumentSymbol] -> Bool)
-> Either [SymbolInformation] [DocumentSymbol]
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not (Bool -> Bool)
-> ([SymbolInformation] -> Bool) -> [SymbolInformation] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolInformation] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not (Bool -> Bool)
-> ([DocumentSymbol] -> Bool) -> [DocumentSymbol] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DocumentSymbol] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)) (Session (Either [SymbolInformation] [DocumentSymbol])
 -> Session Bool)
-> (TextDocumentIdentifier
    -> Session (Either [SymbolInformation] [DocumentSymbol]))
-> TextDocumentIdentifier
-> Session Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextDocumentIdentifier
-> Session (Either [SymbolInformation] [DocumentSymbol])
getDocumentSymbols (TextDocumentIdentifier -> Session Bool)
-> TextDocumentIdentifier -> Session Bool
forall a b. (a -> b) -> a -> b
$ TextDocumentIdentifier
doc,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"documentSymbols after edit" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          ([SymbolInformation] -> Bool)
-> ([DocumentSymbol] -> Bool)
-> Either [SymbolInformation] [DocumentSymbol]
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Bool
not (Bool -> Bool)
-> ([SymbolInformation] -> Bool) -> [SymbolInformation] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SymbolInformation] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Bool -> Bool
not (Bool -> Bool)
-> ([DocumentSymbol] -> Bool) -> [DocumentSymbol] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DocumentSymbol] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Either [SymbolInformation] [DocumentSymbol] -> Bool)
-> Session (Either [SymbolInformation] [DocumentSymbol])
-> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier
-> Session (Either [SymbolInformation] [DocumentSymbol])
getDocumentSymbols TextDocumentIdentifier
doc,
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"completions" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          Bool -> Bool
not (Bool -> Bool)
-> ([CompletionItem] -> Bool) -> [CompletionItem] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompletionItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CompletionItem] -> Bool)
-> Session [CompletionItem] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench [Char]
"completions after edit" (Experiment -> Bench) -> Experiment -> Bench
forall a b. (a -> b) -> a -> b
$ \[DocumentPositions]
docs -> do
        [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *).
MonadFail m =>
(DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool
allWithIdentifierPos [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
          Bool -> Bool
not (Bool -> Bool)
-> ([CompletionItem] -> Bool) -> [CompletionItem] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompletionItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CompletionItem] -> Bool)
-> Session [CompletionItem] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions TextDocumentIdentifier
doc (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Position
identifierP),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench
        [Char]
"code actions"
        ( \[DocumentPositions]
docs -> do
            Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((DocumentPositions -> Bool) -> [DocumentPositions] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Position -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Position -> Bool)
-> (DocumentPositions -> Maybe Position)
-> DocumentPositions
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentPositions -> Maybe Position
identifierP) [DocumentPositions]
docs) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> Session ()
forall a. HasCallStack => [Char] -> a
error [Char]
"None of the example modules is suitable for this experiment"
            Bool -> Bool
not (Bool -> Bool)
-> ([Maybe [Command |? CodeAction]] -> Bool)
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Command |? CodeAction]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Command |? CodeAction]] -> Bool)
-> ([Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]])
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Command |? CodeAction]] -> Bool)
-> Session [Maybe [Command |? CodeAction]] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session (Maybe [Command |? CodeAction]))
-> Session [Maybe [Command |? CodeAction]]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              Maybe Position
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP ((Position -> Session [Command |? CodeAction])
 -> Session (Maybe [Command |? CodeAction]))
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
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]
"code actions after edit"
        ( \[DocumentPositions]
docs -> do
            Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((DocumentPositions -> Bool) -> [DocumentPositions] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Position -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Position -> Bool)
-> (DocumentPositions -> Maybe Position)
-> DocumentPositions
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentPositions -> Maybe Position
identifierP) [DocumentPositions]
docs) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> Session ()
forall a. HasCallStack => [Char] -> a
error [Char]
"None of the example modules is suitable for this experiment"
            [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
              Session ()
waitForProgressStart
            Session ()
waitForProgressDone
            Bool -> Bool
not (Bool -> Bool)
-> ([Maybe [Command |? CodeAction]] -> Bool)
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Command |? CodeAction]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Command |? CodeAction]] -> Bool)
-> ([Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]])
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Command |? CodeAction]] -> Bool)
-> Session [Maybe [Command |? CodeAction]] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session (Maybe [Command |? CodeAction]))
-> Session [Maybe [Command |? CodeAction]]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              Maybe Position
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP ((Position -> Session [Command |? CodeAction])
 -> Session (Maybe [Command |? CodeAction]))
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
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]
"code actions after cradle edit"
        ( \[DocumentPositions]
docs -> do
            Uri
hieYamlUri <- [Char] -> Session Uri
getDocUri [Char]
"hie.yaml"
            IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
appendFile (Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe [Char]
uriToFilePath Uri
hieYamlUri) [Char]
"##\n"
            SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> Session ()
forall (m :: Method 'ClientToServer 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SClientMethod 'Method_WorkspaceDidChangeWatchedFiles
SMethod_WorkspaceDidChangeWatchedFiles (MessageParams 'Method_WorkspaceDidChangeWatchedFiles
 -> Session ())
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> Session ()
forall a b. (a -> b) -> a -> b
$ [FileEvent] -> DidChangeWatchedFilesParams
DidChangeWatchedFilesParams
             [ Uri -> FileChangeType -> FileEvent
FileEvent Uri
hieYamlUri FileChangeType
FileChangeType_Changed ]
            Session ()
waitForProgressStart
            Session ()
waitForProgressStart
            Session ()
waitForProgressStart -- the Session logic restarts a second time
            Session ()
waitForProgressDone
            Bool -> Bool
not (Bool -> Bool)
-> ([Maybe [Command |? CodeAction]] -> Bool)
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Command |? CodeAction] -> Bool)
-> [[Command |? CodeAction]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Command |? CodeAction] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[Command |? CodeAction]] -> Bool)
-> ([Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]])
-> [Maybe [Command |? CodeAction]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Command |? CodeAction]] -> [[Command |? CodeAction]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Command |? CodeAction]] -> Bool)
-> Session [Maybe [Command |? CodeAction]] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session (Maybe [Command |? CodeAction]))
-> Session [Maybe [Command |? CodeAction]]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              Maybe Position
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Position
identifierP ((Position -> Session [Command |? CodeAction])
 -> Session (Maybe [Command |? CodeAction]))
-> (Position -> Session [Command |? CodeAction])
-> Session (Maybe [Command |? CodeAction])
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]
"code lens"
        ( \[DocumentPositions]
docs -> Bool -> Bool
not (Bool -> Bool) -> ([[CodeLens]] -> Bool) -> [[CodeLens]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[CodeLens]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[CodeLens]] -> Bool) -> Session [[CodeLens]] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session [CodeLens])
-> Session [[CodeLens]]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
            TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses TextDocumentIdentifier
doc)
        ),
      ---------------------------------------------------------------------------------------
      [Char] -> Experiment -> Bench
bench
        [Char]
"code lens after edit"
        ( \[DocumentPositions]
docs -> do
            [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
              Session ()
waitForProgressStart
            Session ()
waitForProgressDone
            Bool -> Bool
not (Bool -> Bool) -> ([[CodeLens]] -> Bool) -> [[CodeLens]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[CodeLens]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[CodeLens]] -> Bool) -> Session [[CodeLens]] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session [CodeLens])
-> Session [[CodeLens]]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses TextDocumentIdentifier
doc)
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"hole fit suggestions"
        ( (DocumentPositions -> Session ())
-> [DocumentPositions] -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DocumentPositions -> Session ())
 -> [DocumentPositions] -> Session ())
-> (DocumentPositions -> Session ())
-> [DocumentPositions]
-> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
            let edit :: TextDocumentContentChangeEvent
edit = (TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
                  { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range Position
bottom Position
bottom
                  , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
                  , $sel:_text:TextDocumentContentChangePartial :: Text
_text = Text
t
                  }
                bottom :: Position
bottom = UInt -> UInt -> Position
Position UInt
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
            [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DocumentPositions]
docs ((DocumentPositions -> Session ()) -> Session ())
-> (DocumentPositions -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} ->
              TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
            Session [Diagnostic] -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session [Diagnostic]
waitForDiagnostics
            Session ()
waitForProgressDone
            ((DocumentPositions -> Session Bool) -> Experiment)
-> [DocumentPositions]
-> (DocumentPositions -> Session Bool)
-> Session Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DocumentPositions -> Session Bool) -> Experiment
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM [DocumentPositions]
docs ((DocumentPositions -> Session Bool) -> Session Bool)
-> (DocumentPositions -> Session Bool) -> Session Bool
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
                Int
bottom <- Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> (Text -> Int) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> (Text -> [Text]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> Int) -> Session Text -> Session Int
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 [Diagnostic]
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Maybe [Char]
forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Maybe [Char]
requireDiagnostic [Diagnostic]
diags (DiagnosticSeverity
DiagnosticSeverity_Error, (Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bottom, UInt
8), Text
"Found hole", Maybe DiagnosticTag
forall a. Maybe a
Nothing) of
                    Maybe [Char]
Nothing   -> Bool -> Session Bool
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                    Just [Char]
_err -> Bool -> Session Bool
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"eval execute single-line code lens"
        ( (DocumentPositions -> Session ())
-> [DocumentPositions] -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DocumentPositions -> Session ())
 -> [DocumentPositions] -> Session ())
-> (DocumentPositions -> Session ())
-> [DocumentPositions]
-> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
            let edit :: TextDocumentContentChangeEvent
edit = (TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
                  { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range Position
bottom Position
bottom
                  , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
                  , $sel:_text:TextDocumentContentChangePartial :: Text
_text = Text
t
                  }
                bottom :: Position
bottom = UInt -> UInt -> Position
Position UInt
forall a. Bounded a => a
maxBound UInt
0
                t :: Text
t = [Text] -> Text
T.unlines
                    [ Text
""
                    , Text
"-- >>> 1 + 2"
                    ]
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [TextDocumentContentChangeEvent
edit]
        )
        ( \[DocumentPositions]
docs -> do
            Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([()] -> Bool) -> Session [()] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session [()]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              [CodeLens]
lenses <- TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses TextDocumentIdentifier
doc
              [CodeLens] -> (CodeLens -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CodeLens]
lenses ((CodeLens -> Session ()) -> Session ())
-> (CodeLens -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
                CodeLens { $sel:_command:CodeLens :: CodeLens -> Maybe Command
_command = Just Command
cmd } -> do
                  Command -> Session ()
executeCommand Command
cmd
                  Session ()
waitForProgressStart
                  Session ()
waitForProgressDone
                CodeLens
_ -> () -> Session ()
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              )
        ),
      ---------------------------------------------------------------------------------------
      [Char]
-> ([DocumentPositions] -> Session ()) -> Experiment -> Bench
benchWithSetup
        [Char]
"eval execute multi-line code lens"
        ( (DocumentPositions -> Session ())
-> [DocumentPositions] -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((DocumentPositions -> Session ())
 -> [DocumentPositions] -> Session ())
-> (DocumentPositions -> Session ())
-> [DocumentPositions]
-> Session ()
forall a b. (a -> b) -> a -> b
$ \DocumentPositions{Maybe Position
Position
TextDocumentIdentifier
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
            let edit :: TextDocumentContentChangeEvent
edit = (TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
                  { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range Position
bottom Position
bottom
                  , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
                  , $sel:_text:TextDocumentContentChangePartial :: Text
_text = Text
t
                  }
                bottom :: Position
bottom = UInt -> UInt -> Position
Position UInt
forall a. Bounded a => a
maxBound UInt
0
                t :: Text
t = [Text] -> Text
T.unlines
                    [ Text
""
                    , Text
"data T = A | B | C | D"
                    , Text
"  deriving (Show, Eq, Ord, Bounded, Enum)"
                    , Text
""
                    , Text
"{-"
                    , Text
">>> import Data.List (nub)"
                    , Text
">>> xs = ([minBound..maxBound] ++ [minBound..maxBound] :: [T])"
                    , Text
">>> nub xs"
                    , Text
"-}"
                    ]
            TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [TextDocumentContentChangeEvent
edit]
        )
        ( \[DocumentPositions]
docs -> do
            Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([()] -> Bool) -> Session [()] -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DocumentPositions]
-> (DocumentPositions -> Session ()) -> Session [()]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} -> do
              [CodeLens]
lenses <- TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses TextDocumentIdentifier
doc
              [CodeLens] -> (CodeLens -> Session ()) -> Session ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CodeLens]
lenses ((CodeLens -> Session ()) -> Session ())
-> (CodeLens -> Session ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
                CodeLens { $sel:_command:CodeLens :: CodeLens -> Maybe Command
_command = Just Command
cmd } -> do
                  Command -> Session ()
executeCommand Command
cmd
                  Session ()
waitForProgressStart
                  Session ()
waitForProgressDone
                CodeLens
_ -> () -> Session ()
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              )
        )
    ]
    where hasDefinitions :: (Definition |? (t a |? Null)) -> Bool
hasDefinitions (InL (Definition (InL Location
_)))  = Bool
True
          hasDefinitions (InL (Definition (InR [Location]
ls))) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Location] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Location]
ls
          hasDefinitions (InR (InL t a
ds))              = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
ds
          hasDefinitions (InR (InR Null
LSP.Null))        = Bool
False
---------------------------------------------------------------------------------------------

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

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

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

      packageP :: Parser ExamplePackage
packageP = [Char] -> Version -> ExamplePackage
ExamplePackage
            ([Char] -> Version -> ExamplePackage)
-> Parser [Char] -> Parser (Version -> ExamplePackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption ([Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-package-name" Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"Cabal")
            Parser (Version -> ExamplePackage)
-> Parser Version -> Parser ExamplePackage
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Version -> Mod OptionFields Version -> Parser Version
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Version
versionP ([Char] -> Mod OptionFields Version
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-package-version" Mod OptionFields Version
-> Mod OptionFields Version -> Mod OptionFields Version
forall a. Semigroup a => a -> a -> a
<> Version -> Mod OptionFields Version
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ([Int] -> Version
makeVersion [Int
3,Int
6,Int
0,Int
0]))
      pathOrScriptP :: Parser ExampleDetails
pathOrScriptP = [Char] -> ExampleDetails
ExamplePath   ([Char] -> ExampleDetails)
-> Parser [Char] -> Parser ExampleDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption ([Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-path")
                  Parser ExampleDetails
-> Parser ExampleDetails -> Parser ExampleDetails
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Char] -> [[Char]] -> ExampleDetails
ExampleScript ([Char] -> [[Char]] -> ExampleDetails)
-> Parser [Char] -> Parser ([[Char]] -> ExampleDetails)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption ([Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-script") Parser ([[Char]] -> ExampleDetails)
-> Parser [[Char]] -> Parser ExampleDetails
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char] -> Parser [[Char]]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption ([Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"example-script-args" Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"arguments for the example generation script"))

versionP :: ReadM Version
versionP :: ReadM Version
versionP = ([Char] -> Maybe Version) -> ReadM Version
forall a. ([Char] -> Maybe a) -> ReadM a
maybeReader (([Char] -> Maybe Version) -> ReadM Version)
-> ([Char] -> Maybe Version) -> ReadM Version
forall a b. (a -> b) -> a -> b
$ [(Version, [Char])] -> Maybe Version
forall {a} {a}. (Eq a, IsString a) => [(a, a)] -> Maybe a
extract ([(Version, [Char])] -> Maybe Version)
-> ([Char] -> [(Version, [Char])]) -> [Char] -> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> [Char] -> [(Version, [Char])]
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion
  where
      extract :: [(a, a)] -> Maybe a
extract [(a, a)]
parses = [a] -> Maybe a
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
quiet HasConfig
Config
?config then (\[Char]
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> ([Char] -> IO ()) -> [Char] -> m ()
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 :: Bench -> [Char]
name :: [Char]
name, Bool
enabled :: Bench -> Bool
enabled :: Bool
enabled} =
  Bool
enabled Bool -> Bool -> Bool
&& ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
mm Bool -> Bool -> Bool
|| [Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
mm)
  where
    mm :: [[Char]]
mm = Config -> [[Char]]
matches HasConfig
Config
?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 ()
name :: [Char]
enabled :: Bool
samples :: Natural
benchSetup :: [DocumentPositions] -> Session ()
experiment :: Experiment
name :: [Char]
benchSetup :: [DocumentPositions] -> Session ()
experiment :: Experiment
enabled :: Bool
samples :: Natural
..}
  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 (Session () -> [DocumentPositions] -> Session ()
forall a b. a -> b -> a
const (Session () -> [DocumentPositions] -> Session ())
-> Session () -> [DocumentPositions] -> Session ()
forall a b. (a -> b) -> a -> b
$ () -> Session ()
forall a. a -> Session a
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 = fromMaybe 100 (repetitions ?config) }
                   | Bench
b <- [Bench]
allBenchmarks
                   , HasConfig => Bench -> Bool
Bench -> Bool
select Bench
b ]

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

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

  let conf :: SessionConfig
conf = SessionConfig
defaultConfig
        { logStdErr = verbose ?config,
          logMessages = verbose ?config,
          logColor = False,
          Language.LSP.Test.lspConfig = lspConfig,
          messageTimeout = timeoutLsp ?config
        }
  [(Bench, BenchRun)]
results <- [Bench]
-> (Bench -> IO (Bench, BenchRun)) -> IO [(Bench, BenchRun)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Bench]
benchmarks ((Bench -> IO (Bench, BenchRun)) -> IO [(Bench, BenchRun)])
-> (Bench -> IO (Bench, BenchRun)) -> IO [(Bench, BenchRun)]
forall a b. (a -> b) -> a -> b
$ \b :: Bench
b@Bench{[Char]
name :: Bench -> [Char]
name :: [Char]
name} ->  do
    let p :: CreateProcess
p = ([Char] -> [[Char]] -> CreateProcess
proc (Config -> [Char]
ghcide HasConfig
Config
?config) (HasConfig => [Char] -> [Char] -> [[Char]]
[Char] -> [Char] -> [[Char]]
allArgs [Char]
name [Char]
dir))
                { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
        run :: Session BenchRun -> IO BenchRun
run Session BenchRun
sess = CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO BenchRun)
-> IO BenchRun
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
p ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO BenchRun)
 -> IO BenchRun)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO BenchRun)
-> IO BenchRun
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 =
                            IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
errH IO [Char] -> ([Char] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
verbose HasConfig
Config
?config)(IO () -> IO ()) -> ([Char] -> IO ()) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn
                    IO Any -> (Async Any -> IO BenchRun) -> IO BenchRun
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Any
errSinkThread ((Async Any -> IO BenchRun) -> IO BenchRun)
-> (Async Any -> IO BenchRun) -> IO BenchRun
forall a b. (a -> b) -> a -> b
$ \Async Any
_ -> do
                        Maybe ProcessHandle
-> Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> [Char]
-> Session BenchRun
-> IO BenchRun
forall a.
Maybe ProcessHandle
-> Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> [Char]
-> Session a
-> IO a
runSessionWithHandles' (ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
pH) Handle
inH Handle
outH SessionConfig
conf ClientCapabilities
lspTestCaps [Char]
dir Session BenchRun
sess
    (Bench
b,) (BenchRun -> (Bench, BenchRun))
-> IO BenchRun -> IO (Bench, BenchRun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasConfig =>
(Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun
(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,
            Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
success,
            Natural -> [Char]
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 (Seconds -> [Char]) -> Seconds -> [Char]
forall a b. (a -> b) -> a -> b
$ Seconds
firstResponseSeconds -> Seconds -> Seconds
forall 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 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
firstResponse)Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/((Natural -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
samples Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
1)Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
*Seconds
modules)),
            Seconds -> [Char]
showMs Seconds
runExperiment,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesBuilt,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesChanged,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesVisited,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesTotal,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
edgesTotal,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rebuildsTotal
          ]
          | (Bench {[Char]
name :: Bench -> [Char]
name :: [Char]
name, Natural
samples :: Bench -> Natural
samples :: Natural
samples}, BenchRun {Bool
Seconds
Int
success :: Bool
startup :: Seconds
userWaits :: Seconds
delayedWork :: Seconds
firstResponse :: Seconds
firstResponseDelayed :: Seconds
runExperiment :: Seconds
rulesBuilt :: Int
rulesChanged :: Int
rulesVisited :: Int
rulesTotal :: Int
edgesTotal :: Int
rebuildsTotal :: Int
runSetup :: Seconds
startup :: BenchRun -> Seconds
runSetup :: BenchRun -> Seconds
runExperiment :: BenchRun -> Seconds
userWaits :: BenchRun -> Seconds
delayedWork :: BenchRun -> Seconds
firstResponse :: BenchRun -> Seconds
firstResponseDelayed :: BenchRun -> Seconds
rulesBuilt :: BenchRun -> Int
rulesChanged :: BenchRun -> Int
rulesVisited :: BenchRun -> Int
rulesTotal :: BenchRun -> Int
edgesTotal :: BenchRun -> Int
rebuildsTotal :: BenchRun -> Int
success :: BenchRun -> Bool
..}) <- [(Bench, BenchRun)]
results,
            let runSetup' :: Seconds
runSetup' = if Seconds
runSetup Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds
0.01 then Seconds
0 else Seconds
runSetup
                modules :: Seconds
modules = Int -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Seconds) -> Int -> Seconds
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> Int) -> [[Char]] -> Int
forall a b. (a -> b) -> a -> b
$ Example -> [[Char]]
exampleModules (Example -> [[Char]]) -> Example -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Config -> Example
example HasConfig
Config
?config
        ]
      csv :: [Char]
csv = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", ") ([[Char]]
headers [[Char]] -> [[[Char]]] -> [[[Char]]]
forall a. a -> [a] -> [a]
: [[[Char]]]
rows)
  [Char] -> [Char] -> IO ()
writeFile (Config -> [Char]
outputCSV HasConfig
Config
?config) [Char]
csv

  -- print a nice table
  let pads :: [Int]
pads = ([[Char]] -> Int) -> [[[Char]]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([[Char]] -> [Int]) -> [[Char]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[[Char]]] -> [[[Char]]]
forall a. [[a]] -> [[a]]
transpose ([[Char]]
headers [[Char]] -> [[[Char]]] -> [[[Char]]]
forall a. a -> [a] -> [a]
: [[[Char]]]
rowsHuman))
      paddedHeaders :: [[Char]]
paddedHeaders = (Int -> [Char] -> [Char]) -> [Int] -> [[Char]] -> [[Char]]
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 ([Char] -> IO ()) -> ([[Char]] -> [Char]) -> [[Char]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" | "
      rowsHuman :: [[[Char]]]
rowsHuman =
        [ [ [Char]
name,
            Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
success,
            Natural -> [Char]
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,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesBuilt,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesChanged,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesVisited,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rulesTotal,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
edgesTotal,
            Int -> [Char]
forall a. Show a => a -> [Char]
show Int
rebuildsTotal
          ]
          | (Bench {[Char]
name :: Bench -> [Char]
name :: [Char]
name, Natural
samples :: Bench -> Natural
samples :: Natural
samples}, BenchRun {Bool
Seconds
Int
startup :: BenchRun -> Seconds
runSetup :: BenchRun -> Seconds
runExperiment :: BenchRun -> Seconds
userWaits :: BenchRun -> Seconds
delayedWork :: BenchRun -> Seconds
firstResponse :: BenchRun -> Seconds
firstResponseDelayed :: BenchRun -> Seconds
rulesBuilt :: BenchRun -> Int
rulesChanged :: BenchRun -> Int
rulesVisited :: BenchRun -> Int
rulesTotal :: BenchRun -> Int
edgesTotal :: BenchRun -> Int
rebuildsTotal :: BenchRun -> Int
success :: BenchRun -> Bool
success :: Bool
startup :: Seconds
userWaits :: Seconds
delayedWork :: Seconds
firstResponse :: Seconds
runExperiment :: Seconds
rulesBuilt :: Int
rulesChanged :: Int
rulesVisited :: Int
rulesTotal :: Int
edgesTotal :: Int
rebuildsTotal :: Int
runSetup :: Seconds
firstResponseDelayed :: Seconds
..}) <- [(Bench, BenchRun)]
results,
            let runSetup' :: Seconds
runSetup' = if Seconds
runSetup Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds
0.01 then Seconds
0 else Seconds
runSetup
        ]
  [[Char]] -> IO ()
outputRow [[Char]]
paddedHeaders
  [[Char]] -> IO ()
outputRow ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$ (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char]) -> [[Char]] -> [[Char]])
-> ((Char -> Char) -> [Char] -> [Char])
-> (Char -> Char)
-> [[Char]]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map) (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'-') [[Char]]
paddedHeaders
  [[[Char]]] -> ([[Char]] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[[Char]]]
rowsHuman (([[Char]] -> IO ()) -> IO ()) -> ([[Char]] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[Char]]
row -> [[Char]] -> IO ()
outputRow ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> [Char] -> [Char]) -> [Int] -> [[Char]] -> [[Char]]
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 =
        [Char] -> [[Char]]
forall {a}. IsString a => a -> [a]
ghcideArgs [Char]
dir
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
             [ [ [Char]
"+RTS"
               , [Char]
"-l"
               , [Char]
"-ol" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char]
dir [Char] -> [Char] -> [Char]
</> (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
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
?config]
             ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Config -> [[Char]]
ghcideOptions HasConfig
Config
?config
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [[Char]
"--shake-profiling", [Char]
path] | Just [Char]
path <- [Config -> Maybe [Char]
shakeProfiling HasConfig
Config
?config]
            ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--ot-memory-profiling" | Just [Char]
_ <- [Config -> Maybe [Char]
otMemoryProfiling HasConfig
Config
?config]]
    lspTestCaps :: ClientCapabilities
lspTestCaps =
      ClientCapabilities
fullLatestClientCaps
        ClientCapabilities
-> (ClientCapabilities -> ClientCapabilities) -> ClientCapabilities
forall a b. a -> (a -> b) -> b
& ((Maybe WindowClientCapabilities
 -> Identity (Maybe WindowClientCapabilities))
-> ClientCapabilities -> Identity ClientCapabilities
forall s a. HasWindow s a => Lens' s a
Lens' ClientCapabilities (Maybe WindowClientCapabilities)
L.window ((Maybe WindowClientCapabilities
  -> Identity (Maybe WindowClientCapabilities))
 -> ClientCapabilities -> Identity ClientCapabilities)
-> ((WindowClientCapabilities -> Identity WindowClientCapabilities)
    -> Maybe WindowClientCapabilities
    -> Identity (Maybe WindowClientCapabilities))
-> (WindowClientCapabilities -> Identity WindowClientCapabilities)
-> ClientCapabilities
-> Identity ClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowClientCapabilities -> Identity WindowClientCapabilities)
-> Maybe WindowClientCapabilities
-> Identity (Maybe WindowClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just) ((WindowClientCapabilities -> Identity WindowClientCapabilities)
 -> ClientCapabilities -> Identity ClientCapabilities)
-> WindowClientCapabilities
-> ClientCapabilities
-> ClientCapabilities
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Bool
-> Maybe ShowMessageRequestClientCapabilities
-> Maybe ShowDocumentClientCapabilities
-> WindowClientCapabilities
WindowClientCapabilities (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) Maybe ShowMessageRequestClientCapabilities
forall a. Maybe a
Nothing Maybe ShowDocumentClientCapabilities
forall a. Maybe a
Nothing
        ClientCapabilities
-> (ClientCapabilities -> ClientCapabilities) -> ClientCapabilities
forall a b. a -> (a -> b) -> b
& ((Maybe TextDocumentClientCapabilities
 -> Identity (Maybe TextDocumentClientCapabilities))
-> ClientCapabilities -> Identity ClientCapabilities
forall s a. HasTextDocument s a => Lens' s a
Lens' ClientCapabilities (Maybe TextDocumentClientCapabilities)
L.textDocument ((Maybe TextDocumentClientCapabilities
  -> Identity (Maybe TextDocumentClientCapabilities))
 -> ClientCapabilities -> Identity ClientCapabilities)
-> ((ClientCodeActionResolveOptions
     -> Identity ClientCodeActionResolveOptions)
    -> Maybe TextDocumentClientCapabilities
    -> Identity (Maybe TextDocumentClientCapabilities))
-> (ClientCodeActionResolveOptions
    -> Identity ClientCodeActionResolveOptions)
-> ClientCapabilities
-> Identity ClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentClientCapabilities
 -> Identity TextDocumentClientCapabilities)
-> Maybe TextDocumentClientCapabilities
-> Identity (Maybe TextDocumentClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((TextDocumentClientCapabilities
  -> Identity TextDocumentClientCapabilities)
 -> Maybe TextDocumentClientCapabilities
 -> Identity (Maybe TextDocumentClientCapabilities))
-> ((ClientCodeActionResolveOptions
     -> Identity ClientCodeActionResolveOptions)
    -> TextDocumentClientCapabilities
    -> Identity TextDocumentClientCapabilities)
-> (ClientCodeActionResolveOptions
    -> Identity ClientCodeActionResolveOptions)
-> Maybe TextDocumentClientCapabilities
-> Identity (Maybe TextDocumentClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CodeActionClientCapabilities
 -> Identity (Maybe CodeActionClientCapabilities))
-> TextDocumentClientCapabilities
-> Identity TextDocumentClientCapabilities
forall s a. HasCodeAction s a => Lens' s a
Lens'
  TextDocumentClientCapabilities (Maybe CodeActionClientCapabilities)
L.codeAction ((Maybe CodeActionClientCapabilities
  -> Identity (Maybe CodeActionClientCapabilities))
 -> TextDocumentClientCapabilities
 -> Identity TextDocumentClientCapabilities)
-> ((ClientCodeActionResolveOptions
     -> Identity ClientCodeActionResolveOptions)
    -> Maybe CodeActionClientCapabilities
    -> Identity (Maybe CodeActionClientCapabilities))
-> (ClientCodeActionResolveOptions
    -> Identity ClientCodeActionResolveOptions)
-> TextDocumentClientCapabilities
-> Identity TextDocumentClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeActionClientCapabilities
 -> Identity CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
-> Identity (Maybe CodeActionClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((CodeActionClientCapabilities
  -> Identity CodeActionClientCapabilities)
 -> Maybe CodeActionClientCapabilities
 -> Identity (Maybe CodeActionClientCapabilities))
-> ((ClientCodeActionResolveOptions
     -> Identity ClientCodeActionResolveOptions)
    -> CodeActionClientCapabilities
    -> Identity CodeActionClientCapabilities)
-> (ClientCodeActionResolveOptions
    -> Identity ClientCodeActionResolveOptions)
-> Maybe CodeActionClientCapabilities
-> Identity (Maybe CodeActionClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ClientCodeActionResolveOptions
 -> Identity (Maybe ClientCodeActionResolveOptions))
-> CodeActionClientCapabilities
-> Identity CodeActionClientCapabilities
forall s a. HasResolveSupport s a => Lens' s a
Lens'
  CodeActionClientCapabilities (Maybe ClientCodeActionResolveOptions)
L.resolveSupport ((Maybe ClientCodeActionResolveOptions
  -> Identity (Maybe ClientCodeActionResolveOptions))
 -> CodeActionClientCapabilities
 -> Identity CodeActionClientCapabilities)
-> ((ClientCodeActionResolveOptions
     -> Identity ClientCodeActionResolveOptions)
    -> Maybe ClientCodeActionResolveOptions
    -> Identity (Maybe ClientCodeActionResolveOptions))
-> (ClientCodeActionResolveOptions
    -> Identity ClientCodeActionResolveOptions)
-> CodeActionClientCapabilities
-> Identity CodeActionClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientCodeActionResolveOptions
 -> Identity ClientCodeActionResolveOptions)
-> Maybe ClientCodeActionResolveOptions
-> Identity (Maybe ClientCodeActionResolveOptions)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just) ((ClientCodeActionResolveOptions
  -> Identity ClientCodeActionResolveOptions)
 -> ClientCapabilities -> Identity ClientCapabilities)
-> ClientCodeActionResolveOptions
-> ClientCapabilities
-> ClientCapabilities
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ([Text] -> ClientCodeActionResolveOptions
ClientCodeActionResolveOptions [Text
"edit"])
        ClientCapabilities
-> (ClientCapabilities -> ClientCapabilities) -> ClientCapabilities
forall a b. a -> (a -> b) -> b
& ((Maybe TextDocumentClientCapabilities
 -> Identity (Maybe TextDocumentClientCapabilities))
-> ClientCapabilities -> Identity ClientCapabilities
forall s a. HasTextDocument s a => Lens' s a
Lens' ClientCapabilities (Maybe TextDocumentClientCapabilities)
L.textDocument ((Maybe TextDocumentClientCapabilities
  -> Identity (Maybe TextDocumentClientCapabilities))
 -> ClientCapabilities -> Identity ClientCapabilities)
-> ((Bool -> Identity Bool)
    -> Maybe TextDocumentClientCapabilities
    -> Identity (Maybe TextDocumentClientCapabilities))
-> (Bool -> Identity Bool)
-> ClientCapabilities
-> Identity ClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentClientCapabilities
 -> Identity TextDocumentClientCapabilities)
-> Maybe TextDocumentClientCapabilities
-> Identity (Maybe TextDocumentClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((TextDocumentClientCapabilities
  -> Identity TextDocumentClientCapabilities)
 -> Maybe TextDocumentClientCapabilities
 -> Identity (Maybe TextDocumentClientCapabilities))
-> ((Bool -> Identity Bool)
    -> TextDocumentClientCapabilities
    -> Identity TextDocumentClientCapabilities)
-> (Bool -> Identity Bool)
-> Maybe TextDocumentClientCapabilities
-> Identity (Maybe TextDocumentClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe CodeActionClientCapabilities
 -> Identity (Maybe CodeActionClientCapabilities))
-> TextDocumentClientCapabilities
-> Identity TextDocumentClientCapabilities
forall s a. HasCodeAction s a => Lens' s a
Lens'
  TextDocumentClientCapabilities (Maybe CodeActionClientCapabilities)
L.codeAction ((Maybe CodeActionClientCapabilities
  -> Identity (Maybe CodeActionClientCapabilities))
 -> TextDocumentClientCapabilities
 -> Identity TextDocumentClientCapabilities)
-> ((Bool -> Identity Bool)
    -> Maybe CodeActionClientCapabilities
    -> Identity (Maybe CodeActionClientCapabilities))
-> (Bool -> Identity Bool)
-> TextDocumentClientCapabilities
-> Identity TextDocumentClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodeActionClientCapabilities
 -> Identity CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
-> Identity (Maybe CodeActionClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((CodeActionClientCapabilities
  -> Identity CodeActionClientCapabilities)
 -> Maybe CodeActionClientCapabilities
 -> Identity (Maybe CodeActionClientCapabilities))
-> ((Bool -> Identity Bool)
    -> CodeActionClientCapabilities
    -> Identity CodeActionClientCapabilities)
-> (Bool -> Identity Bool)
-> Maybe CodeActionClientCapabilities
-> Identity (Maybe CodeActionClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> CodeActionClientCapabilities
-> Identity CodeActionClientCapabilities
forall s a. HasDataSupport s a => Lens' s a
Lens' CodeActionClientCapabilities (Maybe Bool)
L.dataSupport ((Maybe Bool -> Identity (Maybe Bool))
 -> CodeActionClientCapabilities
 -> Identity CodeActionClientCapabilities)
-> ((Bool -> Identity Bool) -> Maybe Bool -> Identity (Maybe Bool))
-> (Bool -> Identity Bool)
-> CodeActionClientCapabilities
-> Identity CodeActionClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool) -> Maybe Bool -> Identity (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just) ((Bool -> Identity Bool)
 -> ClientCapabilities -> Identity ClientCapabilities)
-> Bool -> ClientCapabilities -> ClientCapabilities
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True

showMs :: Seconds -> String
showMs :: Seconds -> [Char]
showMs = [Char] -> Seconds -> [Char]
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 = Session FromServerMessage -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session FromServerMessage -> Session ())
-> Session FromServerMessage -> Session ()
forall a b. (a -> b) -> a -> b
$ do
    Session FromServerMessage
-> Session FromServerMessage -> Session FromServerMessage
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session FromServerMessage -> Session FromServerMessage)
-> Session FromServerMessage -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy ((FromServerMessage -> Bool) -> Session FromServerMessage)
-> (FromServerMessage -> Bool) -> Session FromServerMessage
forall a b. (a -> b) -> a -> b
$ \case
      FromServerMess SMethod m
SMethod_WindowWorkDoneProgressCreate TMessage 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
      ~() <- Session FromServerMessage -> Session () -> Session ()
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe ()) -> Session ()
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe ()) -> Session ())
-> (FromServerMessage -> Maybe ()) -> Session ()
forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess  SMethod m
SMethod_Progress  (TNotificationMessage Text
_ SMethod 'Method_Progress
_ (ProgressParams ProgressToken
_ Value
v)) | APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
-> Value -> Bool
forall s t a b. APrism s t a b -> s -> Bool
is APrism Value Value WorkDoneProgressEnd WorkDoneProgressEnd
Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd Value
v -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
        FromServerMessage
_ -> Maybe ()
forall a. Maybe a
Nothing
      Bool
done <- Set ProgressToken -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set ProgressToken -> Bool)
-> Session (Set ProgressToken) -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session (Set ProgressToken)
getIncompleteProgressSessions
      Bool -> Session () -> Session ()
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 ('Method_CustomMethod "test")
m = Proxy "test" -> SMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m (TestRequest -> Value
forall a. ToJSON a => a -> Value
toJSON TestRequest
WaitForShakeQueue)
    (Seconds
td, TResponseMessage ('Method_CustomMethod "test")
resp) <- Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session
     (Seconds, TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session
      (Seconds, TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session
     (Seconds, TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ Session FromServerMessage
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session (TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
m LspId ('Method_CustomMethod "test")
waitId
    case TResponseMessage ('Method_CustomMethod "test")
resp of
        TResponseMessage{$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either (TResponseError m) (MessageResult m)
_result=Right Value
MessageResult ('Method_CustomMethod "test")
Null} -> Seconds -> Session Seconds
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
td
        -- assume a ghcide binary lacking the WaitForShakeQueue method
        TResponseMessage ('Method_CustomMethod "test")
_                                    -> Seconds -> Session Seconds
forall a. a -> Session a
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{Bool
Natural
[Char]
Experiment
[DocumentPositions] -> Session ()
name :: Bench -> [Char]
enabled :: Bench -> Bool
samples :: Bench -> Natural
benchSetup :: Bench -> [DocumentPositions] -> Session ()
experiment :: Bench -> Experiment
name :: [Char]
enabled :: Bool
samples :: Natural
benchSetup :: [DocumentPositions] -> Session ()
experiment :: Experiment
..} = (SomeException -> IO BenchRun) -> IO BenchRun -> IO BenchRun
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
(SomeException -> m a) -> m a -> m a
handleAny (\SomeException
e -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e IO () -> IO BenchRun -> IO BenchRun
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BenchRun -> IO BenchRun
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BenchRun
badRun)
  (IO BenchRun -> IO BenchRun) -> IO BenchRun -> IO BenchRun
forall a b. (a -> b) -> a -> b
$ Session BenchRun -> IO BenchRun
runSess
  (Session BenchRun -> IO BenchRun)
-> Session BenchRun -> IO BenchRun
forall a b. (a -> b) -> a -> b
$ do
      (Seconds
startup, [DocumentPositions]
docs) <- Session [DocumentPositions]
-> Session (Seconds, [DocumentPositions])
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session [DocumentPositions]
 -> Session (Seconds, [DocumentPositions]))
-> Session [DocumentPositions]
-> Session (Seconds, [DocumentPositions])
forall a b. (a -> b) -> a -> b
$ do
        (Seconds
d, [DocumentPositions]
docs) <- Session [DocumentPositions]
-> Session (Seconds, [DocumentPositions])
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session [DocumentPositions]
 -> Session (Seconds, [DocumentPositions]))
-> Session [DocumentPositions]
-> Session (Seconds, [DocumentPositions])
forall a b. (a -> b) -> a -> b
$ Config -> Session [DocumentPositions]
setupDocumentContents HasConfig
Config
?config
        [Char] -> Session ()
forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output ([Char] -> Session ()) -> [Char] -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Setting up document contents took " [Char] -> [Char] -> [Char]
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
identifierP :: DocumentPositions -> Maybe Position
stringLiteralP :: DocumentPositions -> Position
doc :: DocumentPositions -> TextDocumentIdentifier
identifierP :: Maybe Position
stringLiteralP :: Position
doc :: TextDocumentIdentifier
..} = [DocumentPositions] -> DocumentPositions
forall a. HasCallStack => [a] -> a
head [DocumentPositions]
docs
        TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [Position -> TextDocumentContentChangeEvent
charEdit Position
stringLiteralP]
        Session ()
waitForProgressDone
        [DocumentPositions] -> Session [DocumentPositions]
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return [DocumentPositions]
docs

      IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Running " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" benchmark"
      (Seconds
runSetup, ()) <- Session () -> Session (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session () -> Session (Seconds, ()))
-> Session () -> Session (Seconds, ())
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 = Maybe (Seconds, Seconds, (Seconds, Seconds))
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Seconds, Seconds, (Seconds, Seconds))
 -> Session (Maybe (Seconds, Seconds, (Seconds, Seconds))))
-> Maybe (Seconds, Seconds, (Seconds, Seconds))
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
forall a b. (a -> b) -> a -> b
$ (Seconds, Seconds, (Seconds, Seconds))
-> Maybe (Seconds, Seconds, (Seconds, Seconds))
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) <- Session Bool -> Session (Seconds, Bool)
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session Bool -> Session (Seconds, Bool))
-> Session Bool -> Session (Seconds, Bool)
forall a b. (a -> b) -> a -> b
$ Experiment
experiment [DocumentPositions]
docs
            if Bool -> Bool
not Bool
res
              then Maybe (Seconds, Seconds, (Seconds, Seconds))
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Seconds, Seconds, (Seconds, Seconds))
forall a. Maybe a
Nothing
            else do
                [Char] -> Session ()
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 Maybe (Seconds, Seconds)
-> Maybe (Seconds, Seconds) -> Maybe (Seconds, Seconds)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Seconds, Seconds) -> Maybe (Seconds, Seconds)
forall a. a -> Maybe a
Just (Seconds
t,Seconds
td)) (Seconds
userWaitsSeconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
+Seconds
t) (Seconds
delayedWorkSeconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
+Seconds
td) (Natural
n Natural -> Natural -> Natural
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' Maybe (Seconds, Seconds)
forall a. Maybe a
Nothing

      (Seconds
runExperiment, Maybe (Seconds, Seconds, (Seconds, Seconds))
result) <- Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
-> Session (Seconds, Maybe (Seconds, Seconds, (Seconds, Seconds)))
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
 -> Session (Seconds, Maybe (Seconds, Seconds, (Seconds, Seconds))))
-> Session (Maybe (Seconds, Seconds, (Seconds, Seconds)))
-> Session (Seconds, Maybe (Seconds, Seconds, (Seconds, Seconds)))
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 = Maybe (Seconds, Seconds, (Seconds, Seconds)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Seconds, Seconds, (Seconds, Seconds))
result
          (Seconds
userWaits, Seconds
delayedWork, (Seconds
firstResponse, Seconds
firstResponseDelayed)) = (Seconds, Seconds, (Seconds, Seconds))
-> Maybe (Seconds, Seconds, (Seconds, Seconds))
-> (Seconds, Seconds, (Seconds, Seconds))
forall a. a -> Maybe a -> a
fromMaybe (Seconds
0,Seconds
0,(Seconds
0,Seconds
0)) Maybe (Seconds, Seconds, (Seconds, Seconds))
result

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

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

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
    [Char] -> IO ()
forall (m :: * -> *). (MonadIO m, HasConfig) => [Char] -> m ()
output [Char]
cmd
    [Char] -> IO ()
callCommand [Char]
cmd

simpleCabalCradleContent :: String
simpleCabalCradleContent :: [Char]
simpleCabalCradleContent = [Char]
"cradle:\n  cabal:\n"

simpleStackCradleContent :: String
simpleStackCradleContent :: [Char]
simpleStackCradleContent = [Char]
"cradle:\n  stack:\n"

-- | Setup the benchmark
-- we need to create a hie.yaml file for the examples
-- or the hie.yaml file would be searched in the parent directories recursively
-- implicit-hie is error prone for the example test `lsp-types-2.1.1.0`
-- we are using the simpleCabalCradleContent for the hie.yaml file instead.
-- it works if we have cabal > 3.2.
setup :: HasConfig => IO SetupResult
setup :: HasConfig => IO SetupResult
setup = do
  [Char]
benchDir <- case Example -> ExampleDetails
exampleDetails(Config -> Example
example HasConfig
Config
?config) of
      ExamplePath [Char]
examplePath -> do
          let hieYamlPath :: [Char]
hieYamlPath = [Char]
examplePath [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
          Bool
alreadyExists <- [Char] -> IO Bool
doesFileExist [Char]
hieYamlPath
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
hieYamlPath [Char]
simpleCabalCradleContent
          [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
examplePath
      ExampleScript [Char]
examplePath' [[Char]]
scriptArgs -> do
          let exampleDir :: [Char]
exampleDir = [Char]
examplesPath [Char] -> [Char] -> [Char]
</> Example -> [Char]
exampleName (Config -> Example
example HasConfig
Config
?config)
          Bool
alreadySetup <- [Char] -> IO Bool
doesDirectoryExist [Char]
exampleDir
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadySetup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
exampleDir
            [Char]
examplePath <- [Char] -> IO [Char]
makeAbsolute [Char]
examplePath'
            CmdOption -> [Char] -> [[Char]] -> IO ()
forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ ([Char] -> CmdOption
Cwd [Char]
exampleDir) [Char]
examplePath [[Char]]
scriptArgs
            let hieYamlPath :: [Char]
hieYamlPath = [Char]
exampleDir [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
            Bool
alreadyExists <- [Char] -> IO Bool
doesFileExist [Char]
hieYamlPath
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFile [Char]
hieYamlPath [Char]
simpleCabalCradleContent

          [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
exampleDir
      ExampleHackage ExamplePackage{[Char]
Version
packageName :: [Char]
packageVersion :: Version
packageName :: ExamplePackage -> [Char]
packageVersion :: ExamplePackage -> Version
..} -> do
        let path :: [Char]
path = [Char]
examplesPath [Char] -> [Char] -> [Char]
</> [Char]
package
            package :: [Char]
package = [Char]
packageName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-" [Char] -> [Char] -> [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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadySetup (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          case Config -> CabalStack
buildTool HasConfig
Config
?config of
            CabalStack
Cabal -> do
                let cabalVerbosity :: [Char]
cabalVerbosity = [Char]
"-v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Config -> Bool
verbose HasConfig
Config
?config))
                HasConfig => [Char] -> IO ()
[Char] -> IO ()
callCommandLogging ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"cabal get " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
cabalVerbosity [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
package [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" -d " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
examplesPath
                let hieYamlPath :: [Char]
hieYamlPath = [Char]
path [Char] -> [Char] -> [Char]
</> [Char]
"hie.yaml"
                [Char] -> [Char] -> IO ()
writeFile [Char]
hieYamlPath [Char]
simpleCabalCradleContent
                -- 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
?config of
                        Verbosity
Quiet  -> [Char]
"--silent"
                        Verbosity
Normal -> [Char]
""
                        Verbosity
All    -> [Char]
"--verbose"
                HasConfig => [Char] -> IO ()
[Char] -> IO ()
callCommandLogging ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"stack " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
stackVerbosity [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" unpack " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
package [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" --to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
examplesPath
                -- Generate the stack descriptor to match the one used to build ghcide
                [Char]
stack_yaml <- [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"stack.yaml" (Maybe [Char] -> [Char]) -> IO (Maybe [Char]) -> IO [Char]
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 ([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
                        [Char]
"packages: [.]" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:
                            [ [Char]
l
                            | [Char]
l <- [[Char]]
stack_yaml_lines
                            , ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
l)
                                [[Char]
"resolver"
                                ,[Char]
"allow-newer"
                                ,[Char]
"compiler"]
                            ]
                        )
                [Char] -> [Char] -> IO ()
writeFile [Char]
hieYamlPath [Char]
simpleStackCradleContent
        [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
path

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

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

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

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

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

        -- Setup the special positions used by the experiments
        UInt
lastLine <- Int -> UInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> UInt) -> (Text -> Int) -> Text -> UInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> (Text -> [Text]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> UInt) -> Session Text -> Session UInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
        TextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> Session ()
changeDoc TextDocumentIdentifier
doc [(TextDocumentContentChangePartial
 |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((TextDocumentContentChangePartial
  |? TextDocumentContentChangeWholeDocument)
 -> TextDocumentContentChangeEvent)
-> (TextDocumentContentChangePartial
    |? TextDocumentContentChangeWholeDocument)
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ TextDocumentContentChangePartial
-> TextDocumentContentChangePartial
   |? TextDocumentContentChangeWholeDocument
forall a b. a -> a |? b
InL TextDocumentContentChangePartial
                        { $sel:_range:TextDocumentContentChangePartial :: Range
_range = Position -> Position -> Range
Range (UInt -> UInt -> Position
Position UInt
lastLine UInt
0) (UInt -> UInt -> Position
Position UInt
lastLine UInt
0)
                        , $sel:_rangeLength:TextDocumentContentChangePartial :: Maybe UInt
_rangeLength = Maybe UInt
forall a. Maybe a
Nothing
                        , $sel:_text:TextDocumentContentChangePartial :: 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 [SymbolInformation] [DocumentSymbol]
symbols <- TextDocumentIdentifier
-> Session (Either [SymbolInformation] [DocumentSymbol])
getDocumentSymbols TextDocumentIdentifier
doc
        let endOfImports :: Position
endOfImports = case Either [SymbolInformation] [DocumentSymbol]
symbols of
                Right [DocumentSymbol]
symbols | Just Position
x <- [DocumentSymbol] -> Maybe Position
findEndOfImports [DocumentSymbol]
symbols -> Position
x
                Either [SymbolInformation] [DocumentSymbol]
_ -> [Char] -> Position
forall a. HasCallStack => [Char] -> a
error ([Char] -> Position) -> [Char] -> Position
forall a b. (a -> b) -> a -> b
$ [Char]
"symbols: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Either [SymbolInformation] [DocumentSymbol] -> [Char]
forall a. Show a => a -> [Char]
show Either [SymbolInformation] [DocumentSymbol]
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
        DocumentPositions -> Session DocumentPositions
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (DocumentPositions -> Session DocumentPositions)
-> DocumentPositions -> Session DocumentPositions
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
SymbolKind_Module, $sel:_name:DocumentSymbol :: DocumentSymbol -> Text
_name = Text
"imports", Range
_range :: Range
$sel:_range:DocumentSymbol :: DocumentSymbol -> Range
_range} : [DocumentSymbol]
_) =
    Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ UInt -> UInt -> Position
Position (UInt -> UInt
forall a. Enum a => a -> a
succ (UInt -> UInt) -> UInt -> UInt
forall a b. (a -> b) -> a -> b
$ Position -> UInt
_line (Position -> UInt) -> Position -> UInt
forall a b. (a -> b) -> a -> b
$ Range -> Position
_end Range
_range) UInt
4
findEndOfImports [DocumentSymbol{$sel:_kind:DocumentSymbol :: DocumentSymbol -> SymbolKind
_kind = SymbolKind
SymbolKind_File, $sel:_children:DocumentSymbol :: DocumentSymbol -> Maybe [DocumentSymbol]
_children = Just [DocumentSymbol]
cc}] =
    [DocumentSymbol] -> Maybe Position
findEndOfImports [DocumentSymbol]
cc
findEndOfImports (DocumentSymbol{Range
$sel:_range:DocumentSymbol :: DocumentSymbol -> Range
_range :: Range
_range} : [DocumentSymbol]
_) =
    Position -> Maybe Position
forall a. a -> Maybe a
Just (Position -> Maybe Position) -> Position -> Maybe Position
forall a b. (a -> b) -> a -> b
$ Range
_range Range -> Getting Position Range Position -> Position
forall s a. s -> Getting a s a -> a
^. Getting Position Range Position
forall s a. HasStart s a => Lens' s a
Lens' Range Position
L.start
findEndOfImports [DocumentSymbol]
_ = Maybe Position
forall a. Maybe a
Nothing

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

pad :: Int -> String -> String
pad :: Int -> [Char] -> [Char]
pad Int
n []     = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
' '
pad Int
0 [Char]
_      = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"pad"
pad Int
n (Char
x:[Char]
xx) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
pad (Int
nInt -> Int -> Int
forall 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
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} Text
fileContents Position
pos = do
    -- this search is expensive, so we cache the result on disk
    let cachedPath :: [Char]
cachedPath = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Uri -> Maybe [Char]
uriToFilePath Uri
_uri) [Char] -> [Char] -> [Char]
<.> [Char]
"identifierPosition"
    Either IOException (Maybe Position)
cachedRes <- IO (Either IOException (Maybe Position))
-> Session (Either IOException (Maybe Position))
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (Maybe Position))
 -> Session (Either IOException (Maybe Position)))
-> IO (Either IOException (Maybe Position))
-> Session (Either IOException (Maybe Position))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @IOException (IO (Maybe Position) -> IO (Either IOException (Maybe Position)))
-> IO (Maybe Position) -> IO (Either IOException (Maybe Position))
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Position
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> Maybe Position)
-> (ByteString -> ByteString) -> ByteString -> Maybe Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> Maybe Position)
-> IO ByteString -> IO (Maybe Position)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile [Char]
cachedPath
    case Either IOException (Maybe Position)
cachedRes of
        Left IOException
_ -> do
            Maybe Position
result <- Position -> Session (Maybe Position)
loop Position
pos
            IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
BS.writeFile [Char]
cachedPath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe Position -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode Maybe Position
result
            Maybe Position -> Session (Maybe Position)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Position
result
        Right Maybe Position
res ->
            Maybe Position -> Session (Maybe Position)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Position
res
  where
      loop :: Position -> Session (Maybe Position)
loop Position
pos
        | (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ Position -> UInt
_line Position
pos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lll =
            Maybe Position -> Session (Maybe Position)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Position
forall a. Maybe a
Nothing
        | (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
forall a b. (a -> b) -> a -> b
$ Position -> UInt
_character Position
pos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int
lengthOfLine (UInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UInt -> Int) -> UInt -> Int
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 Session Bool -> Session Bool -> Session Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Position -> Session Bool
checkCompletions Position
pos
                if Bool
checks
                    then Maybe Position -> Session (Maybe Position)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Position -> Session (Maybe Position))
-> Maybe Position -> Session (Maybe Position)
forall a b. (a -> b) -> a -> b
$ Position -> Maybe Position
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 = _character p + 2}
      nextLine :: Position -> Position
nextLine Position
p = UInt -> UInt -> Position
Position (Position -> UInt
_line Position
p UInt -> UInt -> UInt
forall a. Num a => a -> a -> a
+ UInt
1) UInt
4

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

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


getBuildKeysBuilt :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])
getBuildKeysBuilt :: Session
  (Either (TResponseError ('Method_CustomMethod "test")) [Text])
getBuildKeysBuilt = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) [Text])
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
GetBuildKeysBuilt

getBuildKeysVisited :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])
getBuildKeysVisited :: Session
  (Either (TResponseError ('Method_CustomMethod "test")) [Text])
getBuildKeysVisited = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) [Text])
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
GetBuildKeysVisited

getBuildKeysChanged :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) [T.Text])
getBuildKeysChanged :: Session
  (Either (TResponseError ('Method_CustomMethod "test")) [Text])
getBuildKeysChanged = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) [Text])
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
GetBuildKeysChanged

getBuildEdgesCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int)
getBuildEdgesCount :: Session (Either (TResponseError ('Method_CustomMethod "test")) Int)
getBuildEdgesCount = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) Int)
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
GetBuildEdgesCount

getRebuildsCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int)
getRebuildsCount :: Session (Either (TResponseError ('Method_CustomMethod "test")) Int)
getRebuildsCount = TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) Int)
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
GetRebuildsCount

-- Copy&paste from ghcide/test/Development.IDE.Test
getStoredKeys :: Session [Text]
getStoredKeys :: Session [Text]
getStoredKeys = TestRequest -> Session [Text]
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 (TResponseError @ClientToServer (Method_CustomMethod "test")) b)
tryCallTestPlugin :: forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
cmd = do
    let cm :: SMethod ('Method_CustomMethod "test")
cm = Proxy "test" -> SMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"test")
    LspId ('Method_CustomMethod "test")
waitId <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (TestRequest -> Value
forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    TResponseMessage{Either
  (TResponseError ('Method_CustomMethod "test"))
  (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either (TResponseError m) (MessageResult m)
_result :: Either
  (TResponseError ('Method_CustomMethod "test"))
  (MessageResult ('Method_CustomMethod "test"))
_result} <- Session FromServerMessage
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session (TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
waitId
    Either (TResponseError ('Method_CustomMethod "test")) b
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TResponseError ('Method_CustomMethod "test")) b
 -> Session
      (Either (TResponseError ('Method_CustomMethod "test")) b))
-> Either (TResponseError ('Method_CustomMethod "test")) b
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
forall a b. (a -> b) -> a -> b
$ case Either
  (TResponseError ('Method_CustomMethod "test"))
  (MessageResult ('Method_CustomMethod "test"))
_result of
         Left TResponseError ('Method_CustomMethod "test")
e -> TResponseError ('Method_CustomMethod "test")
-> Either (TResponseError ('Method_CustomMethod "test")) b
forall a b. a -> Either a b
Left TResponseError ('Method_CustomMethod "test")
e
         Right MessageResult ('Method_CustomMethod "test")
json -> case Value -> Result b
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
MessageResult ('Method_CustomMethod "test")
json of
             A.Success b
a -> b -> Either (TResponseError ('Method_CustomMethod "test")) b
forall a b. b -> Either a b
Right b
a
             A.Error [Char]
e   -> [Char] -> Either (TResponseError ('Method_CustomMethod "test")) b
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 (TResponseError ('Method_CustomMethod "test")) b
res <- TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
forall b.
FromJSON b =>
TestRequest
-> Session
     (Either (TResponseError ('Method_CustomMethod "test")) b)
tryCallTestPlugin TestRequest
cmd
    case Either (TResponseError ('Method_CustomMethod "test")) b
res of
        Left (TResponseError LSPErrorCodes |? ErrorCodes
t Text
err Maybe (ErrorData ('Method_CustomMethod "test"))
_) -> [Char] -> Session b
forall a. HasCallStack => [Char] -> a
error ([Char] -> Session b) -> [Char] -> Session b
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes) -> [Char]
forall a. Show a => a -> [Char]
show LSPErrorCodes |? ErrorCodes
t [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
        Right b
a                       -> b -> Session b
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a