{-# 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

-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes
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

-- | Run an action, with stderr silenced
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

-- | Restore cwd after running an action
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 #-}
-- | Never run in parallel
lock :: Lock
lock :: Lock
lock = IO Lock -> Lock
forall a. IO a -> a
unsafePerformIO IO Lock
newLock

-- | Host a server, and run a test session on it
-- Note: cwd will be shifted into @root@ in @Session a@
runSessionWithServer' ::
  -- | plugins to load on the server
  [PluginDescriptor IdeState] ->
  -- | lsp config for the server
  Config ->
  -- | config for the test session
  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

-- | 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
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