df63fd7 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Tests for cradle loading (#460)

df63fd7Pepe Iborra7 years ago

exe/Arguments.hs+2

compare with master

unifiedsplit

@@ -12,6 +12,7 @@ data Arguments = Arguments

12 ,argFiles :: [FilePath]

13 ,argsVersion :: Bool

14 ,argsShakeProfiling :: Maybe FilePath

15+ ,argsTesting :: Bool

15 }

16 }

17getArguments :: IO Arguments

18getArguments :: IO Arguments

@@ -29,3 +30,4 @@ arguments = Arguments

29 <*> many (argument str (metavar "FILES/DIRS..."))

30 <*> many (argument str (metavar "FILES/DIRS..."))

30 <*> switch (long "version" <> help "Show ghcide and GHC versions")

31 <*> switch (long "version" <> help "Show ghcide and GHC versions")

31 <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")

32 <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")

33+ <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")

exe/Main.hs+4−117

@@ -8,7 +8,6 @@

8module Main(main) where

10import Arguments

11−import Data.Functor ((<&>))

12import Data.Maybe

11import Data.Maybe

13import Data.List.Extra

12import Data.List.Extra

14import System.FilePath

13import System.FilePath

@@ -16,9 +15,6 @@ import Control.Concurrent.Extra

16import Control.Exception

15import Control.Exception

17import Control.Monad.Extra

16import Control.Monad.Extra

18import Control.Monad.IO.Class

17import Control.Monad.IO.Class

19−import qualified Crypto.Hash.SHA1 as H

20−import qualified Data.ByteString.Char8 as B

21−import Data.ByteString.Base16

22import Data.Default

18import Data.Default

23import System.Time.Extra

19import System.Time.Extra

24import Development.IDE.Core.Debouncer

20import Development.IDE.Core.Debouncer

@@ -41,7 +37,6 @@ import qualified Data.Text as T

41import qualified Data.Text.IO as T

37import qualified Data.Text.IO as T

42import Language.Haskell.LSP.Messages

38import Language.Haskell.LSP.Messages

43import Language.Haskell.LSP.Types (LspId(IdInt))

39import Language.Haskell.LSP.Types (LspId(IdInt))

44−import Linker

45import Data.Version

40import Data.Version

46import Development.IDE.LSP.LanguageServer

41import Development.IDE.LSP.LanguageServer

47import qualified System.Directory.Extra as IO

42import qualified System.Directory.Extra as IO

@@ -50,35 +45,13 @@ import System.IO

50import System.Exit

45import System.Exit

51import Paths_ghcide

46import Paths_ghcide

52import Development.GitRev

47import Development.GitRev

53−import Development.Shake (doesDirectoryExist, Action, Rules, action, doesFileExist, need)

48+import Development.Shake (Action, Rules, action)

54import qualified Data.HashSet as HashSet

49import qualified Data.HashSet as HashSet

55import qualified Data.Map.Strict as Map

50import qualified Data.Map.Strict as Map

56−

57−import GHC hiding (def)

58−import qualified GHC.Paths

59−import DynFlags

60−

61−import HIE.Bios.Environment

62import HIE.Bios

51import HIE.Bios

63−import HIE.Bios.Cradle

52+import Rules

64−import HIE.Bios.Types

65import RuleTypes

53import RuleTypes

67−-- Prefix for the cache path

68−cacheDir :: String

69−cacheDir = "ghcide"

70−

71−-- Set the GHC libdir to the nix libdir if it's present.

72−getLibdir :: IO FilePath

73−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

74−

75−getCacheDir :: [String] -> IO FilePath

76−getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)

77− where

78− -- Create a unique folder per set of different GHC options, assuming that each different set of

79− -- GHC options will create incompatible interface files.

80− opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)

81−

82ghcideVersion :: IO String

55ghcideVersion :: IO String

83ghcideVersion = do

56ghcideVersion = do

84 path <- getExecutablePath

57 path <- getExecutablePath

@@ -122,6 +95,7 @@ main = do

122 let options = (defaultIdeOptions $ loadSession dir)

95 let options = (defaultIdeOptions $ loadSession dir)

123 { optReportProgress = clientSupportsProgress caps

96 { optReportProgress = clientSupportsProgress caps

124 , optShakeProfiling = argsShakeProfiling

97 , optShakeProfiling = argsShakeProfiling

98+ , optTesting = IdeTesting argsTesting

125 }

99 }

126 debouncer <- newAsyncDebouncer

100 debouncer <- newAsyncDebouncer

127 initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)

101 initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)

@@ -177,7 +151,7 @@ main = do

177

151

178cradleRules :: Rules ()

152cradleRules :: Rules ()

179cradleRules = do

153cradleRules = do

180− loadGhcSessionIO

154+ loadGhcSession

181 cradleToSession

155 cradleToSession

182

156

183expandFiles :: [FilePath] -> IO [FilePath]

157expandFiles :: [FilePath] -> IO [FilePath]

@@ -205,93 +179,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

205 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags

179 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags

206showEvent lock e = withLock lock $ print e

180showEvent lock e = withLock lock $ print e

207

181

208−loadGhcSessionIO :: Rules ()

209−loadGhcSessionIO =

210− -- This rule is for caching the GHC session. E.g., even when the cabal file

211− -- changed, if the resulting flags did not change, we would continue to use

212− -- the existing session.

213− defineNoFile $ \(GetHscEnv opts deps) ->

214− liftIO $ createSession $ ComponentOptions opts deps

215−

216−getComponentOptions :: Cradle a -> IO ComponentOptions

217−getComponentOptions cradle = do

218− let showLine s = putStrLn ("> " ++ s)

219− -- WARNING 'runCradle is very expensive and must be called as few times as possible

220− cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

221− case cradleRes of

222− CradleSuccess r -> pure r

223− CradleFail err -> throwIO err

224− -- TODO Rather than failing here, we should ignore any files that use this cradle.

225− -- That will require some more changes.

226− CradleNone -> fail "'none' cradle is not yet supported"

227−

228−

229−createSession :: ComponentOptions -> IO HscEnvEq

230−createSession (ComponentOptions theOpts _) = do

231− libdir <- getLibdir

232−

233− cacheDir <- Main.getCacheDir theOpts

234−

235− env <- runGhc (Just libdir) $ do

236− dflags <- getSessionDynFlags

237− (dflags', _targets) <- addCmdOpts theOpts dflags

238− _ <- setSessionDynFlags $

239− -- disabled, generated directly by ghcide instead

240− flip gopt_unset Opt_WriteInterface $

241− -- disabled, generated directly by ghcide instead

242− -- also, it can confuse the interface stale check

243− dontWriteHieFiles $

244− setHiDir cacheDir $

245− setDefaultHieDir cacheDir $

246− setIgnoreInterfacePragmas $

247− setLinkerOptions $

248− disableOptimisation dflags'

249− getSession

250− initDynLinker env

251− newHscEnvEq env

252−

253−-- we don't want to generate object code so we compile to bytecode

254−-- (HscInterpreted) which implies LinkInMemory

255−-- HscInterpreted

256−setLinkerOptions :: DynFlags -> DynFlags

257−setLinkerOptions df = df {

258− ghcLink = LinkInMemory

259− , hscTarget = HscNothing

260− , ghcMode = CompManager

261− }

262−

263−setIgnoreInterfacePragmas :: DynFlags -> DynFlags

264−setIgnoreInterfacePragmas df =

265− gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

266−

267−disableOptimisation :: DynFlags -> DynFlags

268−disableOptimisation df = updOptLevel 0 df

269−

270−setHiDir :: FilePath -> DynFlags -> DynFlags

271−setHiDir f d =

272− -- override user settings to avoid conflicts leading to recompilation

273− d { hiDir = Just f}

274−

275−cradleToSession :: Rules ()

276−cradleToSession = define $ \LoadCradle nfp -> do

277− let f = fromNormalizedFilePath nfp

278−

279− -- If the path points to a directory, load the implicit cradle

280− mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f

281− cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml

282−

283− cmpOpts <- liftIO $ getComponentOptions cradle

284− let opts = componentOptions cmpOpts

285− deps = componentDependencies cmpOpts

286− deps' = case mbYaml of

287− -- For direct cradles, the hie.yaml file itself must be watched.

288− Just yaml | isDirectCradle cradle -> yaml : deps

289− _ -> deps

290− existingDeps <- filterM doesFileExist deps'

291− need existingDeps

292− ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)

293−

294−

295loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

182loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

296loadSession dir = liftIO $ do

183loadSession dir = liftIO $ do

297 cradleLoc <- memoIO $ \v -> do

184 cradleLoc <- memoIO $ \v -> do

exe/Rules.hsnew file+153

@@ -0,0 +1,153 @@

1+module Rules

2+ ( loadGhcSession

3+ , cradleToSession

4+ , cradleLoadedMethod

5+ , createSession

6+ , getComponentOptions

7+ )

8+where

10+import Control.Exception

11+import Control.Monad (filterM, when)

12+import qualified Crypto.Hash.SHA1 as H

13+import Data.ByteString.Base16 (encode)

14+import qualified Data.ByteString.Char8 as B

15+import Data.Functor ((<&>))

16+import Data.Maybe (fromMaybe)

17+import Data.Text (Text)

18+import Development.IDE.Core.Rules (defineNoFile)

19+import Development.IDE.Core.Shake (ShakeExtras(ShakeExtras,isTesting), getShakeExtras, sendEvent, define, useNoFile_)

20+import Development.IDE.GHC.Util

21+import Development.IDE.Types.Location (fromNormalizedFilePath)

22+import Development.Shake

23+import DynFlags (gopt_set, gopt_unset,

24+ updOptLevel)

25+import GHC

26+import qualified GHC.Paths

27+import HIE.Bios

28+import HIE.Bios.Cradle

29+import HIE.Bios.Environment (addCmdOpts)

30+import HIE.Bios.Types

31+import Linker (initDynLinker)

32+import RuleTypes

33+import qualified System.Directory.Extra as IO

34+import System.Environment (lookupEnv)

35+import System.FilePath.Posix (addTrailingPathSeparator,

36+ (</>))

37+import Language.Haskell.LSP.Messages as LSP

38+import Language.Haskell.LSP.Types as LSP

39+import Data.Aeson (ToJSON(toJSON))

40+

41+-- Prefix for the cache path

42+cacheDir :: String

43+cacheDir = "ghcide"

44+

45+notifyCradleLoaded :: FilePath -> LSP.FromServerMessage

46+notifyCradleLoaded fp =

47+ LSP.NotCustomServer $

48+ LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $

49+ toJSON fp

50+

51+loadGhcSession :: Rules ()

52+loadGhcSession =

53+ -- This rule is for caching the GHC session. E.g., even when the cabal file

54+ -- changed, if the resulting flags did not change, we would continue to use

55+ -- the existing session.

56+ defineNoFile $ \(GetHscEnv opts deps) ->

57+ liftIO $ createSession $ ComponentOptions opts deps

58+

59+cradleToSession :: Rules ()

60+cradleToSession = define $ \LoadCradle nfp -> do

61+ let f = fromNormalizedFilePath nfp

62+

63+ ShakeExtras{isTesting} <- getShakeExtras

64+

65+ -- If the path points to a directory, load the implicit cradle

66+ mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f

67+ cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml

68+

69+ when isTesting $

70+ sendEvent $ notifyCradleLoaded f

71+

72+ cmpOpts <- liftIO $ getComponentOptions cradle

73+ let opts = componentOptions cmpOpts

74+ deps = componentDependencies cmpOpts

75+ deps' = case mbYaml of

76+ -- For direct cradles, the hie.yaml file itself must be watched.

77+ Just yaml | isDirectCradle cradle -> yaml : deps

78+ _ -> deps

79+ existingDeps <- filterM doesFileExist deps'

80+ need existingDeps

81+ ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)

82+

83+cradleLoadedMethod :: Text

84+cradleLoadedMethod = "ghcide/cradle/loaded"

85+

86+getComponentOptions :: Cradle a -> IO ComponentOptions

87+getComponentOptions cradle = do

88+ let showLine s = putStrLn ("> " ++ s)

89+ -- WARNING 'runCradle is very expensive and must be called as few times as possible

90+ cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

91+ case cradleRes of

92+ CradleSuccess r -> pure r

93+ CradleFail err -> throwIO err

94+ -- TODO Rather than failing here, we should ignore any files that use this cradle.

95+ -- That will require some more changes.

96+ CradleNone -> fail "'none' cradle is not yet supported"

97+

98+createSession :: ComponentOptions -> IO HscEnvEq

99+createSession (ComponentOptions theOpts _) = do

100+ libdir <- getLibdir

101+

102+ cacheDir <- getCacheDir theOpts

103+

104+ env <- runGhc (Just libdir) $ do

105+ dflags <- getSessionDynFlags

106+ (dflags', _targets) <- addCmdOpts theOpts dflags

107+ _ <- setSessionDynFlags $

108+ -- disabled, generated directly by ghcide instead

109+ flip gopt_unset Opt_WriteInterface $

110+ -- disabled, generated directly by ghcide instead

111+ -- also, it can confuse the interface stale check

112+ dontWriteHieFiles $

113+ setHiDir cacheDir $

114+ setDefaultHieDir cacheDir $

115+ setIgnoreInterfacePragmas $

116+ setLinkerOptions $

117+ disableOptimisation dflags'

118+ getSession

119+ initDynLinker env

120+ newHscEnvEq env

121+

122+-- Set the GHC libdir to the nix libdir if it's present.

123+getLibdir :: IO FilePath

124+getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

125+

126+-- we don't want to generate object code so we compile to bytecode

127+-- (HscInterpreted) which implies LinkInMemory

128+-- HscInterpreted

129+setLinkerOptions :: DynFlags -> DynFlags

130+setLinkerOptions df = df {

131+ ghcLink = LinkInMemory

132+ , hscTarget = HscNothing

133+ , ghcMode = CompManager

134+ }

135+

136+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

137+setIgnoreInterfacePragmas df =

138+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

139+

140+disableOptimisation :: DynFlags -> DynFlags

141+disableOptimisation df = updOptLevel 0 df

142+

143+setHiDir :: FilePath -> DynFlags -> DynFlags

144+setHiDir f d =

145+ -- override user settings to avoid conflicts leading to recompilation

146+ d { hiDir = Just f}

147+

148+getCacheDir :: [String] -> IO FilePath

149+getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)

150+ where

151+ -- Create a unique folder per set of different GHC options, assuming that each different set of

152+ -- GHC options will create incompatible interface files.

153+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)

ghcide.cabal+12

@@ -169,6 +169,7 @@ executable ghcide

169 main-is: Main.hs

170 build-depends:

171 hslogger,

172+ aeson,

172 base == 4.*,

173 base == 4.*,

173 binary,

174 binary,

174 base16-bytestring >=0.1.1 && <0.2,

175 base16-bytestring >=0.1.1 && <0.2,

@@ -185,6 +186,7 @@ executable ghcide

185 gitrev,

186 gitrev,

186 hashable,

187 hashable,

187 haskell-lsp,

188 haskell-lsp,

189+ haskell-lsp-types,

188 hie-bios >= 0.4.0 && < 0.5,

190 hie-bios >= 0.4.0 && < 0.5,

189 ghcide,

191 ghcide,

190 optparse-applicative,

192 optparse-applicative,

@@ -194,12 +196,22 @@ executable ghcide

194 other-modules:

196 other-modules:

195 Arguments

197 Arguments

196 Paths_ghcide

198 Paths_ghcide

199+ Rules

197 RuleTypes

200 RuleTypes

198

201

199 default-extensions:

202 default-extensions:

203+ BangPatterns

204+ DeriveFunctor

200 DeriveGeneric

205 DeriveGeneric

206+ GeneralizedNewtypeDeriving

207+ LambdaCase

208+ NamedFieldPuns

209+ OverloadedStrings

201 RecordWildCards

210 RecordWildCards

211+ ScopedTypeVariables

212+ StandaloneDeriving

202 TupleSections

213 TupleSections

214+ TypeApplications

203 ViewPatterns

215 ViewPatterns

204

216

205test-suite ghcide-tests

217test-suite ghcide-tests

src/Development/IDE/Core/Service.hs+1

@@ -61,6 +61,7 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =

61 logger

62 debouncer

63 (optShakeProfiling options)

64+ (optTesting options)

64 (optReportProgress options)

65 (optReportProgress options)

65 shakeOptions

66 shakeOptions

66 { shakeThreads = optThreads options

67 { shakeThreads = optThreads options

src/Development/IDE/Core/Shake.hs+4−1

@@ -102,6 +102,8 @@ data ShakeExtras = ShakeExtras

102 -- positions in a version of that document to positions in the latest version

103 ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)

104 -- ^ How many rules are running for each file

105+ ,isTesting :: Bool

106+ -- ^ enable additional messages used by the test suite to check invariants

105 }

107 }

106

108

107getShakeExtras :: Action ShakeExtras

109getShakeExtras :: Action ShakeExtras

@@ -297,11 +299,12 @@ shakeOpen :: IO LSP.LspId

297 -> Logger

299 -> Logger

298 -> Debouncer NormalizedUri

300 -> Debouncer NormalizedUri

299 -> Maybe FilePath

301 -> Maybe FilePath

302+ -> IdeTesting

300 -> IdeReportProgress

303 -> IdeReportProgress

301 -> ShakeOptions

304 -> ShakeOptions

302 -> Rules ()

305 -> Rules ()

303 -> IO IdeState

306 -> IO IdeState

304−shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

307+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeTesting isTesting) (IdeReportProgress reportProgress) opts rules = do

305 inProgress <- newVar HMap.empty

308 inProgress <- newVar HMap.empty

306 shakeExtras <- do

309 shakeExtras <- do

307 globals <- newVar HMap.empty

310 globals <- newVar HMap.empty

src/Development/IDE/Types/Options.hs+5

@@ -9,6 +9,7 @@ module Development.IDE.Types.Options

9 , IdePreprocessedSource(..)

10 , IdeReportProgress(..)

11 , IdeDefer(..)

12+ , IdeTesting(..)

12 , clientSupportsProgress

13 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15 , defaultIdeOptions

@@ -40,6 +41,8 @@ data IdeOptions = IdeOptions

40 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

41 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

41 , optShakeProfiling :: Maybe FilePath

42 , optShakeProfiling :: Maybe FilePath

42 -- ^ Set to 'Just' to create a directory of profiling reports.

43 -- ^ Set to 'Just' to create a directory of profiling reports.

44+ , optTesting :: IdeTesting

45+ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants

43 , optReportProgress :: IdeReportProgress

46 , optReportProgress :: IdeReportProgress

44 -- ^ Whether to report progress during long operations.

47 -- ^ Whether to report progress during long operations.

45 , optLanguageSyntax :: String

48 , optLanguageSyntax :: String

@@ -65,6 +68,7 @@ data IdePreprocessedSource = IdePreprocessedSource

66newtype IdeReportProgress = IdeReportProgress Bool

69newtype IdeReportProgress = IdeReportProgress Bool

67newtype IdeDefer = IdeDefer Bool

70newtype IdeDefer = IdeDefer Bool

71+newtype IdeTesting = IdeTesting Bool

69clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

73clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

70clientSupportsProgress caps = IdeReportProgress $ Just True ==

74clientSupportsProgress caps = IdeReportProgress $ Just True ==

@@ -83,6 +87,7 @@ defaultIdeOptions session = IdeOptions

83 ,optLanguageSyntax = "haskell"

87 ,optLanguageSyntax = "haskell"

84 ,optNewColonConvention = False

88 ,optNewColonConvention = False

85 ,optDefer = IdeDefer True

89 ,optDefer = IdeDefer True

90+ ,optTesting = IdeTesting False

86 }

91 }

test/exe/Main.hs+44−7

@@ -26,6 +26,7 @@ import Development.IDE.Test.Runfiles

26import Development.IDE.Types.Location

27import qualified Language.Haskell.LSP.Test as LSPTest

28import Language.Haskell.LSP.Test hiding (openDoc')

29+import Language.Haskell.LSP.Messages

29import Language.Haskell.LSP.Types

30import Language.Haskell.LSP.Types

30import Language.Haskell.LSP.Types.Capabilities

31import Language.Haskell.LSP.Types.Capabilities

31import Language.Haskell.LSP.VFS (applyChange)

32import Language.Haskell.LSP.VFS (applyChange)

@@ -45,10 +46,10 @@ main :: IO ()

45main = defaultMain $ testGroup "HIE"

46main = defaultMain $ testGroup "HIE"

46 [ testSession "open close" $ do

47 [ testSession "open close" $ do

47 doc <- openDoc' "Testing.hs" "haskell" ""

48 doc <- openDoc' "Testing.hs" "haskell" ""

48− void (message :: Session WorkDoneProgressCreateRequest)

49+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

49− void (message :: Session WorkDoneProgressBeginNotification)

50+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

50 closeDoc doc

51 closeDoc doc

51− void (message :: Session WorkDoneProgressEndNotification)

52+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

52 , initializeResponseTests

53 , initializeResponseTests

53 , completionTests

54 , completionTests

54 , cppTests

55 , cppTests

@@ -64,7 +65,7 @@ main = defaultMain $ testGroup "HIE"

64 , haddockTests

65 , haddockTests

65 , positionMappingTests

66 , positionMappingTests

66 , watchedFilesTests

67 , watchedFilesTests

67− , sessionDepsArePickedUp

68+ , cradleTests

68 ]

69 ]

70initializeResponseTests :: TestTree

71initializeResponseTests :: TestTree

@@ -143,8 +144,8 @@ diagnosticTests = testGroup "diagnostics"

143 , testSessionWait "introduce syntax error" $ do

144 , testSessionWait "introduce syntax error" $ do

144 let content = T.unlines [ "module Testing where" ]

145 let content = T.unlines [ "module Testing where" ]

145 doc <- openDoc' "Testing.hs" "haskell" content

146 doc <- openDoc' "Testing.hs" "haskell" content

146− void (message :: Session WorkDoneProgressCreateRequest)

147+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

147− void (message :: Session WorkDoneProgressBeginNotification)

148+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

148 let change = TextDocumentContentChangeEvent

149 let change = TextDocumentContentChangeEvent

149 { _range = Just (Range (Position 0 15) (Position 0 18))

150 { _range = Just (Range (Position 0 15) (Position 0 18))

150 , _rangeLength = Nothing

151 , _rangeLength = Nothing

@@ -1864,6 +1865,42 @@ haddockTests

1864 where

1865 where

1865 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

1866 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

1866

1867

1868+cradleTests :: TestTree

1869+cradleTests = testGroup "cradle"

1870+ [testGroup "dependencies" [sessionDepsArePickedUp]

1871+ ,testGroup "loading" [loadCradleOnlyonce]

1872+ ]

1873+

1874+loadCradleOnlyonce :: TestTree

1875+loadCradleOnlyonce = testGroup "load cradle only once"

1876+ [ testSession' "implicit" implicit

1877+ , testSession' "direct" direct

1878+ ]

1879+ where

1880+ direct dir = do

1881+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")

1882+ "cradle: {direct: {arguments: []}}"

1883+ test dir

1884+ implicit dir = test dir

1885+ test _dir = do

1886+ doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"

1887+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1888+ liftIO $ length msgs @?= 1

1889+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

1890+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1891+ liftIO $ length msgs @?= 0

1892+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"

1893+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1894+ liftIO $ length msgs @?= 0

1895+

1896+

1897+cradleLoadedMessage :: Session FromServerMessage

1898+cradleLoadedMessage = satisfy $ \case

1899+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

1900+ _ -> False

1901+

1902+cradleLoadedMethod :: T.Text

1903+cradleLoadedMethod = "ghcide/cradle/loaded"

1867

1904

1868sessionDepsArePickedUp :: TestTree

1905sessionDepsArePickedUp :: TestTree

1869sessionDepsArePickedUp = testSession'

1906sessionDepsArePickedUp = testSession'

@@ -1954,7 +1991,7 @@ runInDir dir s = do

1954 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

1991 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

1955 createDirectoryIfMissing True $ dir ++ "/Data"

1992 createDirectoryIfMissing True $ dir ++ "/Data"

1956

1993

1957− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

1994+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

1958 -- HIE calls getXgdDirectory which assumes that HOME is set.

1995 -- HIE calls getXgdDirectory which assumes that HOME is set.

1959 -- Only sets HOME if it wasn't already set.

1996 -- Only sets HOME if it wasn't already set.

1960 setEnv "HOME" "/homeless-shelter" False

1997 setEnv "HOME" "/homeless-shelter" False