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