1{-# LANGUAGE GADTs #-} 2{-# LANGUAGE LambdaCase #-} 3{-# LANGUAGE OverloadedStrings #-} 4module Test.Hls 5 ( module Test.Tasty.HUnit, 6 module Test.Tasty, 7 module Test.Tasty.ExpectedFailure, 8 module Test.Hls.Util, 9 module Language.LSP.Types, 10 module Language.LSP.Test, 11 module Control.Monad.IO.Class, 12 module Control.Applicative.Combinators, 13 defaultTestRunner, 14 goldenGitDiff, 15 goldenWithHaskellDoc, 16 goldenWithHaskellDocFormatter, 17 def, 18 runSessionWithServer, 19 runSessionWithServerFormatter, 20 runSessionWithServer', 21 waitForProgressDone, 22 PluginDescriptor, 23 IdeState, 24 ) 25where 26 27import Control.Applicative.Combinators 28import Control.Concurrent.Async (async, cancel, wait) 29import Control.Concurrent.Extra 30import Control.Exception.Base 31import Control.Monad (unless) 32import Control.Monad.IO.Class 33import Data.ByteString.Lazy (ByteString) 34import Data.Default (def) 35import qualified Data.Text as T 36import qualified Data.Text.Lazy as TL 37import qualified Data.Text.Lazy.Encoding as TL 38import Development.IDE (IdeState, hDuplicateTo', 39 noLogging) 40import Development.IDE.Graph (ShakeOptions (shakeThreads)) 41import Development.IDE.Main 42import qualified Development.IDE.Main as Ghcide 43import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide 44import Development.IDE.Types.Options 45import GHC.IO.Handle 46import Ide.Plugin.Config (Config, formattingProvider) 47import Ide.PluginUtils (pluginDescToIdePlugins) 48import Ide.Types 49import Language.LSP.Test 50import Language.LSP.Types hiding 51 (SemanticTokenAbsolute (length, line), 52 SemanticTokenRelative (length), 53 SemanticTokensEdit (_start)) 54import Language.LSP.Types.Capabilities (ClientCapabilities) 55import System.Directory (getCurrentDirectory, 56 setCurrentDirectory) 57import System.FilePath 58import System.IO.Extra 59import System.IO.Unsafe (unsafePerformIO) 60import System.Process.Extra (createPipe) 61import System.Time.Extra 62import Test.Hls.Util 63import Test.Tasty hiding (Timeout) 64import Test.Tasty.ExpectedFailure 65import Test.Tasty.Golden 66import Test.Tasty.HUnit 67import Test.Tasty.Ingredients.Rerun 68 69-- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes 70defaultTestRunner :: TestTree -> IO () 71defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) 72 73gitDiff :: FilePath -> FilePath -> [String] 74gitDiff fRef fNew = ["git", "-c", "core.fileMode=false", "diff", "--no-index", "--text", "--exit-code", fRef, fNew] 75 76goldenGitDiff :: TestName -> FilePath -> IO ByteString -> TestTree 77goldenGitDiff name = goldenVsStringDiff name gitDiff 78 79goldenWithHaskellDoc 80 :: PluginDescriptor IdeState 81 -> TestName 82 -> FilePath 83 -> FilePath 84 -> FilePath 85 -> FilePath 86 -> (TextDocumentIdentifier -> Session ()) 87 -> TestTree 88goldenWithHaskellDoc plugin title testDataDir path desc ext act = 89 goldenGitDiff title (testDataDir </> path <.> desc <.> ext) 90 $ runSessionWithServer plugin testDataDir 91 $ TL.encodeUtf8 . TL.fromStrict 92 <$> do 93 doc <- openDoc (path <.> ext) "haskell" 94 act doc 95 documentContents doc 96 97goldenWithHaskellDocFormatter 98 :: PluginDescriptor IdeState 99 -> String 100 -> TestName 101 -> FilePath 102 -> FilePath 103 -> FilePath 104 -> FilePath 105 -> (TextDocumentIdentifier -> Session ()) 106 -> TestTree 107goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext act = 108 goldenGitDiff title (testDataDir </> path <.> desc <.> ext) 109 $ runSessionWithServerFormatter plugin formatter testDataDir 110 $ TL.encodeUtf8 . TL.fromStrict 111 <$> do 112 doc <- openDoc (path <.> ext) "haskell" 113 act doc 114 documentContents doc 115 116runSessionWithServer :: PluginDescriptor IdeState -> FilePath -> Session a -> IO a 117runSessionWithServer plugin = runSessionWithServer' [plugin] def def fullCaps 118 119runSessionWithServerFormatter :: PluginDescriptor IdeState -> String -> FilePath -> Session a -> IO a 120runSessionWithServerFormatter plugin formatter = 121 runSessionWithServer' 122 [plugin] 123 def {formattingProvider = T.pack formatter} 124 def 125 fullCaps 126 127-- | Run an action, with stderr silenced 128silenceStderr :: IO a -> IO a 129silenceStderr action = withTempFile $ \temp -> 130 bracket (openFile temp ReadWriteMode) hClose $ \h -> do 131 old <- hDuplicate stderr 132 buf <- hGetBuffering stderr 133 h `hDuplicateTo'` stderr 134 action `finally` do 135 old `hDuplicateTo'` stderr 136 hSetBuffering stderr buf 137 hClose old 138 139-- | Restore cwd after running an action 140keepCurrentDirectory :: IO a -> IO a 141keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const 142 143{-# NOINLINE lock #-} 144-- | Never run in parallel 145lock :: Lock 146lock = unsafePerformIO newLock 147 148-- | Host a server, and run a test session on it 149-- Note: cwd will be shifted into @root@ in @Session a@ 150runSessionWithServer' :: 151 -- | plugins to load on the server 152 [PluginDescriptor IdeState] -> 153 -- | lsp config for the server 154 Config -> 155 -- | config for the test session 156 SessionConfig -> 157 ClientCapabilities -> 158 FilePath -> 159 Session a -> 160 IO a 161runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ silenceStderr $ do 162 (inR, inW) <- createPipe 163 (outR, outW) <- createPipe 164 server <- 165 async $ 166 Ghcide.defaultMain 167 def 168 { argsHandleIn = pure inR, 169 argsHandleOut = pure outW, 170 argsDefaultHlsConfig = conf, 171 argsLogger = pure noLogging, 172 argsIdeOptions = \config sessionLoader -> 173 let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} 174 in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, 175 argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ Ghcide.descriptors 176 } 177 x <- runSessionWithHandles inW outR sconf caps root s 178 hClose inW 179 timeout 3 (wait server) >>= \case 180 Just () -> pure () 181 Nothing -> do 182 putStrLn "Server does not exit in 3s, canceling the async task..." 183 (t, _) <- duration $ cancel server 184 putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" 185 pure x 186 187-- | Wait for all progress to be done 188-- Needs at least one progress done notification to return 189waitForProgressDone :: Session () 190waitForProgressDone = loop 191 where 192 loop = do 193 () <- skipManyTill anyMessage $ satisfyMaybe $ \case 194 FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () 195 _ -> Nothing 196 done <- null <$> getIncompleteProgressSessions 197 unless done loop 198