{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Hls
( module Test.Tasty.HUnit,
module Test.Tasty,
module Test.Tasty.ExpectedFailure,
module Test.Hls.Util,
module Language.LSP.Types,
module Language.LSP.Test,
module Control.Monad.IO.Class,
module Control.Applicative.Combinators,
defaultTestRunner,
goldenGitDiff,
goldenWithHaskellDoc,
goldenWithHaskellDocFormatter,
def,
runSessionWithServer,
runSessionWithServerFormatter,
runSessionWithServer',
waitForProgressDone,
PluginDescriptor,
IdeState,
)
where
import Control.Applicative.Combinators
import Control.Concurrent.Async (async, cancel, wait)
import Control.Concurrent.Extra
import Control.Exception.Base
import Control.Monad (unless)
import Control.Monad.IO.Class
import Data.ByteString.Lazy (ByteString)
import Data.Default (def)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Development.IDE (IdeState, hDuplicateTo',
noLogging)
import Development.IDE.Graph (ShakeOptions (shakeThreads))
import Development.IDE.Main
import qualified Development.IDE.Main as Ghcide
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
import Development.IDE.Types.Options
import GHC.IO.Handle
import Ide.Plugin.Config (Config, formattingProvider)
import Ide.PluginUtils (pluginDescToIdePlugins)
import Ide.Types
import Language.LSP.Test
import Language.LSP.Types
import Language.LSP.Types.Capabilities (ClientCapabilities)
import System.Directory (getCurrentDirectory,
setCurrentDirectory)
import System.FilePath
import System.IO.Extra
import System.IO.Unsafe (unsafePerformIO)
import System.Process.Extra (createPipe)
import System.Time.Extra
import Test.Hls.Util
import Test.Tasty hiding (Timeout)
import Test.Tasty.ExpectedFailure
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Test.Tasty.Ingredients.Rerun
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner :: TestTree -> IO ()
defaultTestRunner = TestTree -> IO ()
defaultMainWithRerun (TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Timeout -> Timeout) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Timeout -> Timeout -> Timeout
forall a b. a -> b -> a
const (Timeout -> Timeout -> Timeout) -> Timeout -> Timeout -> Timeout
forall a b. (a -> b) -> a -> b
$ Integer -> Timeout
mkTimeout Integer
600000000)
gitDiff :: FilePath -> FilePath -> [String]
gitDiff :: FilePath -> FilePath -> [FilePath]
gitDiff FilePath
fRef FilePath
fNew = [FilePath
"git", FilePath
"-c", FilePath
"core.fileMode=false", FilePath
"diff", FilePath
"--no-index", FilePath
"--text", FilePath
"--exit-code", FilePath
fRef, FilePath
fNew]
goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree
goldenGitDiff :: FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
name = FilePath
-> (FilePath -> FilePath -> [FilePath])
-> FilePath
-> IO ByteString
-> TestTree
goldenVsStringDiff FilePath
name FilePath -> FilePath -> [FilePath]
gitDiff
goldenWithHaskellDoc
:: PluginDescriptor IdeState
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc :: PluginDescriptor IdeState
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDoc PluginDescriptor IdeState
plugin FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
(IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ PluginDescriptor IdeState
-> FilePath -> Session ByteString -> IO ByteString
forall a.
PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin FilePath
testDataDir
(Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
(Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
goldenWithHaskellDocFormatter
:: PluginDescriptor IdeState
-> String
-> TestName
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter :: PluginDescriptor IdeState
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> (TextDocumentIdentifier -> Session ())
-> TestTree
goldenWithHaskellDocFormatter PluginDescriptor IdeState
plugin FilePath
formatter FilePath
title FilePath
testDataDir FilePath
path FilePath
desc FilePath
ext TextDocumentIdentifier -> Session ()
act =
FilePath -> FilePath -> IO ByteString -> TestTree
goldenGitDiff FilePath
title (FilePath
testDataDir FilePath -> FilePath -> FilePath
</> FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
desc FilePath -> FilePath -> FilePath
<.> FilePath
ext)
(IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ PluginDescriptor IdeState
-> FilePath -> FilePath -> Session ByteString -> IO ByteString
forall a.
PluginDescriptor IdeState
-> FilePath -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter FilePath
testDataDir
(Session ByteString -> IO ByteString)
-> Session ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict
(Text -> ByteString) -> Session Text -> Session ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
TextDocumentIdentifier
doc <- FilePath -> Text -> Session TextDocumentIdentifier
openDoc (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
ext) Text
"haskell"
TextDocumentIdentifier -> Session ()
act TextDocumentIdentifier
doc
TextDocumentIdentifier -> Session Text
documentContents TextDocumentIdentifier
doc
runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a
runSessionWithServer PluginDescriptor IdeState
plugin = [PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState
plugin] Config
forall a. Default a => a
def SessionConfig
forall a. Default a => a
def ClientCapabilities
fullCaps
runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a
runSessionWithServerFormatter :: PluginDescriptor IdeState
-> FilePath -> FilePath -> Session a -> IO a
runSessionWithServerFormatter PluginDescriptor IdeState
plugin FilePath
formatter =
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
forall a.
[PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer'
[PluginDescriptor IdeState
plugin]
Config
forall a. Default a => a
def {formattingProvider :: Text
formattingProvider = FilePath -> Text
T.pack FilePath
formatter}
SessionConfig
forall a. Default a => a
def
ClientCapabilities
fullCaps
silenceStderr :: IO a -> IO a
silenceStderr :: IO a -> IO a
silenceStderr IO a
action = (FilePath -> IO a) -> IO a
forall a. (FilePath -> IO a) -> IO a
withTempFile ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
temp ->
IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
temp IOMode
ReadWriteMode) Handle -> IO ()
hClose ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Handle
old <- Handle -> IO Handle
hDuplicate Handle
stderr
BufferMode
buf <- Handle -> IO BufferMode
hGetBuffering Handle
stderr
Handle
h Handle -> Handle -> IO ()
`hDuplicateTo'` Handle
stderr
IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` do
Handle
old Handle -> Handle -> IO ()
`hDuplicateTo'` Handle
stderr
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
buf
Handle -> IO ()
hClose Handle
old
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory :: IO a -> IO a
keepCurrentDirectory = IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
getCurrentDirectory FilePath -> IO ()
setCurrentDirectory ((FilePath -> IO a) -> IO a)
-> (IO a -> FilePath -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> FilePath -> IO a
forall a b. a -> b -> a
const
{-# NOINLINE lock #-}
lock :: Lock
lock :: Lock
lock = IO Lock -> Lock
forall a. IO a -> a
unsafePerformIO IO Lock
newLock
runSessionWithServer' ::
[PluginDescriptor IdeState] ->
Config ->
SessionConfig ->
ClientCapabilities ->
FilePath ->
Session a ->
IO a
runSessionWithServer' :: [PluginDescriptor IdeState]
-> Config
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithServer' [PluginDescriptor IdeState]
plugin Config
conf SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s = Lock -> IO a -> IO a
forall a. Lock -> IO a -> IO a
withLock Lock
lock (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
keepCurrentDirectory (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
silenceStderr (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
(Handle
inR, Handle
inW) <- IO (Handle, Handle)
createPipe
(Handle
outR, Handle
outW) <- IO (Handle, Handle)
createPipe
Async ()
server <-
IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
Arguments -> IO ()
Ghcide.defaultMain
Arguments
forall a. Default a => a
def
{ argsHandleIn :: IO Handle
argsHandleIn = Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
inR,
argsHandleOut :: IO Handle
argsHandleOut = Handle -> IO Handle
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
outW,
argsDefaultHlsConfig :: Config
argsDefaultHlsConfig = Config
conf,
argsLogger :: IO Logger
argsLogger = Logger -> IO Logger
forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
noLogging,
argsIdeOptions :: Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions = \Config
config Action IdeGhcSession
sessionLoader ->
let ideOptions :: IdeOptions
ideOptions = (Arguments -> Config -> Action IdeGhcSession -> IdeOptions
argsIdeOptions Arguments
forall a. Default a => a
def Config
config Action IdeGhcSession
sessionLoader) {optTesting :: IdeTesting
optTesting = Bool -> IdeTesting
IdeTesting Bool
True}
in IdeOptions
ideOptions {optShakeOptions :: ShakeOptions
optShakeOptions = (IdeOptions -> ShakeOptions
optShakeOptions IdeOptions
ideOptions) {shakeThreads :: Int
shakeThreads = Int
2}},
argsHlsPlugins :: IdePlugins IdeState
argsHlsPlugins = [PluginDescriptor IdeState] -> IdePlugins IdeState
forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
pluginDescToIdePlugins ([PluginDescriptor IdeState] -> IdePlugins IdeState)
-> [PluginDescriptor IdeState] -> IdePlugins IdeState
forall a b. (a -> b) -> a -> b
$ [PluginDescriptor IdeState]
plugin [PluginDescriptor IdeState]
-> [PluginDescriptor IdeState] -> [PluginDescriptor IdeState]
forall a. [a] -> [a] -> [a]
++ [PluginDescriptor IdeState]
Ghcide.descriptors
}
a
x <- Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
forall a.
Handle
-> Handle
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session a
-> IO a
runSessionWithHandles Handle
inW Handle
outR SessionConfig
sconf ClientCapabilities
caps FilePath
root Session a
s
Handle -> IO ()
hClose Handle
inW
Seconds -> IO () -> IO (Maybe ())
forall a. Seconds -> IO a -> IO (Maybe a)
timeout Seconds
3 (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
server) IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just () -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe ()
Nothing -> do
FilePath -> IO ()
putStrLn FilePath
"Server does not exit in 3s, canceling the async task..."
(Seconds
t, ()
_) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
server
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Finishing canceling (took " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Seconds -> FilePath
showDuration Seconds
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"s)"
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
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
SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
FromServerMessage
_ -> Maybe ()
forall a. Maybe a
Nothing
Bool
done <- Set ProgressToken -> 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