07cf929...master · ghcide

git.iko.soy/ghcide

on master help sign in

.azure/linux-stack.yml+6−2

since splitsnapshots

unifiedsplit

@@ -32,7 +32,9 @@ jobs:

32 ./fmt.sh

33 displayName: "HLint via ./fmt.sh"

34 - bash: |

35+ sudo add-apt-repository ppa:hvr/ghc

36+ sudo apt-get update

35− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev

37+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev cabal-install-3.2

36 if ! which stack >/dev/null 2>&1; then

38 if ! which stack >/dev/null 2>&1; then

37 curl -sSL https://get.haskellstack.org/ | sh

39 curl -sSL https://get.haskellstack.org/ | sh

38 fi

40 fi

@@ -41,7 +43,9 @@ jobs:

41 displayName: 'stack setup'

43 displayName: 'stack setup'

42 - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML

44 - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML

43 displayName: 'stack build --only-dependencies'

45 displayName: 'stack build --only-dependencies'

46+ - bash: |

47+ export PATH=/opt/cabal/bin:$PATH

44− - bash: stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML

48+ stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML

45 # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

49 # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

46 displayName: 'stack test --ghc-options=-Werror'

50 displayName: 'stack test --ghc-options=-Werror'

47 - bash: |

51 - bash: |

.azure/windows-stack.yml+1

@@ -46,6 +46,7 @@ jobs:

46 # Installing happy and alex standalone to avoid error "strip.exe: unable to rename ../*.exe; reason: File exists"

47 stack install happy --stack-yaml $STACK_YAML

48 stack install alex --stack-yaml $STACK_YAML

49+ stack install cabal-install --stack-yaml $STACK_YAML

49 stack build --only-dependencies --stack-yaml $STACK_YAML

50 stack build --only-dependencies --stack-yaml $STACK_YAML

50 displayName: 'stack build --only-dependencies'

51 displayName: 'stack build --only-dependencies'

51 - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML

52 - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML

.ghcideleted−25

@@ -1,25 +0,0 @@

1−:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns

2−

3−:set -XBangPatterns

4−:set -XDeriveFunctor

5−:set -XDeriveGeneric

6−:set -XGeneralizedNewtypeDeriving

7−:set -XLambdaCase

8−:set -XNamedFieldPuns

9−:set -XOverloadedStrings

10−:set -XRecordWildCards

11−:set -XScopedTypeVariables

12−:set -XStandaloneDeriving

13−:set -XTupleSections

14−:set -XTypeApplications

15−:set -XViewPatterns

16−

17−:set -package=ghc

18−:set -ignore-package=ghc-lib-parser

19−:set -DGHC_STABLE

20−:set -Iinclude

21−:set -idist/build/autogen

22−:set -isrc

23−:set -iexe

24−

25−:load Main

.gitignore+1

@@ -7,3 +7,4 @@ cabal.project.local

7/.tasty-rerun-log

8.vscode

9/.hlint-*

10+bench/example

.hlint.yaml−1

@@ -73,7 +73,6 @@

73 - {name: ViewPatterns, within: []}

75 # Shady extensions

76− - {name: ImplicitParams, within: []}

77 - name: CPP

76 - name: CPP

78 within:

77 within:

79 - Development.IDE.Compat

78 - Development.IDE.Compat

CHANGELOG.md+20

@@ -1,5 +1,25 @@

1### unreleased

3+### 0.2.0 (2020-06-02)

5+* Multi-component support (thanks @mpickering)

6+* Support for GHC 8.10 (thanks @sheaf and @chshersh)

7+* Fix some TH issues (thanks @mpickering)

8+* Automatically pick up changes to cradle dependencies (e.g. cabal

9+ files) (thanks @jinwoo)

10+* Track dependencies when using `qAddDependentFile` (thanks @mpickering)

11+* Add record fields to document symbols outline (thanks @bubba)

12+* Fix some space leaks (thanks @mpickering)

13+* Strip redundant path information from diagnostics (thanks @tek)

14+* Fix import suggestions for operators (thanks @eddiemundo)

15+* Significant reductions in memory usage by using interfaces and `.hie` files (thanks

16+ @pepeiborra)

17+* Minor improvements to completions

18+* More comprehensive suggestions for missing imports (thanks @pepeiborra)

19+* Group imports in document outline (thanks @fendor)

20+* Upgrade to haskell-lsp-0.22 (thanks @bubba)

21+* Upgrade to hie-bios 0.5 (thanks @fendor)

22+

3### 0.1.0 (2020-02-04)

23### 0.1.0 (2020-02-04)

5* Code action for inserting new definitions (see #309).

25* Code action for inserting new definitions (see #309).

README.md+43−2

@@ -25,13 +25,40 @@ There are more details about our approach [in this blog post](https://4ta.uk/p/s

25| Display type and source module of values | hover |

26| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |

28+

29+## Limitations to Multi-Component support

30+

31+`ghcide` supports loading multiple components into the same session so that

32+features such as go-to definition work across components. However, there are

33+some limitations to this.

34+

35+1. You will get much better results currently manually specifying the hie.yaml file.

36+Until tools like cabal and stack provide the right interface to support multi-component

37+projects, it is always advised to specify explicitly how your project partitions.

38+2. Cross-component features only work if you have loaded at least one file

39+from each component.

40+3. There is a known issue where if you have three components, such that A depends on B which depends on C

41+then if you load A and C into the session but not B then under certain situations you

42+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for

43+a simple reproduction of the bug.

44+

28## Using it

45## Using it

30### Install `ghcide`

47### Install `ghcide`

32#### With Nix

49#### With Nix

51+Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.

52+

53+1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via

54+ ```

55+ nix-env -iA haskellPackages.ghcide

56+ ```

57+ or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.

58+ Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.

59+

34−[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)

60+2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)

61+ which provides a `ghcide` via the `haskell.nix` infrastructure.

36#### With Cabal or Stack

63#### With Cabal or Stack

@@ -256,6 +283,20 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):

256This example above describes a setup in which `ghcide` is installed

283This example above describes a setup in which `ghcide` is installed

257using `stack install ghcide` within a project.

284using `stack install ghcide` within a project.

258

285

286+### Using with Kakoune

287+

288+Install [kak-lsp](https://github.com/ul/kak-lsp).

289+

290+Change `kak-lsp.toml` to include this:

291+

292+```toml

293+[language.haskell]

294+filetypes = ["haskell"]

295+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]

296+command = "ghcide"

297+args = ["--lsp"]

298+```

299+

259## Hacking on ghcide

300## Hacking on ghcide

260

301

261To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,

302To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,

@@ -284,7 +325,7 @@ Now opening a `.hs` file should work with `ghcide`.

284

325

285## History and relationship to other Haskell IDE's

326## History and relationship to other Haskell IDE's

286

327

287−The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).

328+The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).

288

329

289The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).

330The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).

290

331

bench/Main.hsnew file+287

@@ -0,0 +1,287 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE ImplicitParams #-}

5+{- An automated benchmark built around the simple experiment described in:

7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html

9+ As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and

10+ loads the module 'Distribution.Simple'. The rationale for this choice is:

11+

12+ - It's convenient to download with `cabal unpack Cabal-3.2.0.0`

13+ - It has very few dependencies, and all are already needed to build ghcide

14+ - Distribution.Simple has 235 transitive module dependencies, so non trivial

15+

16+ The experiments are sequences of lsp commands scripted using lsp-test.

17+ A more refined approach would be to record and replay real IDE interactions,

18+ once the replay functionality is available in lsp-test.

19+ A more declarative approach would be to reuse ide-debug-driver:

20+

21+ > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md

22+

23+ The result of an experiment is a total duration in seconds after a preset

24+ number of iterations. There is ample room for improvement:

25+ - Statistical analysis to detect outliers and auto infer the number of iterations needed

26+ - GC stats analysis (currently -S is printed as part of the experiment)

27+ - Analyisis of performance over the commit history of the project

28+

29+ How to run:

30+ 1. `cabal bench`

31+ 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`

32+

33+ Note that the package database influences the response times of certain actions,

34+ e.g. code actions, and therefore the two methods above do not necessarily

35+ produce the same results.

36+

37+ -}

38+

39+import Control.Applicative.Combinators

40+import Control.Concurrent

41+import Control.Exception.Safe

42+import Control.Monad.Extra

43+import Control.Monad.IO.Class

44+import Data.Aeson

45+import Data.List

46+import Data.Maybe

47+import Data.Version

48+import Language.Haskell.LSP.Test

49+import Language.Haskell.LSP.Types

50+import Language.Haskell.LSP.Types.Capabilities

51+import Numeric.Natural

52+import Options.Applicative

53+import System.Directory

54+import System.FilePath ((</>))

55+import System.Process

56+import System.Time.Extra

57+

58+-- Points to a string in the target file,

59+-- convenient for hygienic edits

60+hygienicP :: Position

61+hygienicP = Position 854 23

62+

63+-- Points to the middle of an identifier,

64+-- convenient for requesting goto-def, hover and completions

65+identifierP :: Position

66+identifierP = Position 853 12

67+

68+main :: IO ()

69+main = do

70+ config <- execParser $ info configP fullDesc

71+ let ?config = config

72+

73+ output "starting test"

74+

75+ cleanUp <- setup

76+

77+ runBenchmarks

78+ [ ---------------------------------------------------------------------------------------

79+ bench "hover" 10 $ \doc ->

80+ isJust <$> getHover doc identifierP,

81+ ---------------------------------------------------------------------------------------

82+ bench "getDefinition" 10 $ \doc ->

83+ not . null <$> getDefinitions doc identifierP,

84+ ---------------------------------------------------------------------------------------

85+ bench "documentSymbols" 100 $

86+ fmap (either (not . null) (not . null)) . getDocumentSymbols,

87+ ---------------------------------------------------------------------------------------

88+ bench "documentSymbols after edit" 100 $ \doc -> do

89+ let change =

90+ TextDocumentContentChangeEvent

91+ { _range = Just (Range hygienicP hygienicP),

92+ _rangeLength = Nothing,

93+ _text = " "

94+ }

95+ changeDoc doc [change]

96+ either (not . null) (not . null) <$> getDocumentSymbols doc,

97+ ---------------------------------------------------------------------------------------

98+ bench "completions after edit" 10 $ \doc -> do

99+ let change =

100+ TextDocumentContentChangeEvent

101+ { _range = Just (Range hygienicP hygienicP),

102+ _rangeLength = Nothing,

103+ _text = " "

104+ }

105+ changeDoc doc [change]

106+ not . null <$> getCompletions doc identifierP,

107+ ---------------------------------------------------------------------------------------

108+ benchWithSetup

109+ "code actions"

110+ 10

111+ ( \doc -> do

112+ let p = identifierP

113+ let change =

114+ TextDocumentContentChangeEvent

115+ { _range = Just (Range p p),

116+ _rangeLength = Nothing,

117+ _text = "a"

118+ }

119+ changeDoc doc [change]

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

121+ return p

122+ )

123+ ( \p doc -> do

124+ not . null <$> getCodeActions doc (Range p p)

125+ ),

126+ ---------------------------------------------------------------------------------------

127+ bench "code actions after edit" 10 $ \doc -> do

128+ let p = identifierP

129+ let change =

130+ TextDocumentContentChangeEvent

131+ { _range = Just (Range p p),

132+ _rangeLength = Nothing,

133+ _text = "a"

134+ }

135+ changeDoc doc [change]

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

137+ not . null <$> getCodeActions doc (Range p p)

138+ ]

139+ `finally` cleanUp

140+

141+---------------------------------------------------------------------------------------------

142+

143+examplePackageName :: String

144+examplePackageName = "Cabal"

145+

146+examplePackageVersion :: Version

147+examplePackageVersion = makeVersion [3, 2, 0, 0]

148+

149+examplePackage :: String

150+examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion

151+

152+exampleModulePath :: FilePath

153+exampleModulePath = "Distribution" </> "Simple.hs"

154+

155+examplesPath :: FilePath

156+examplesPath = "bench/example"

157+

158+data Config = Config

159+ { verbose :: !Bool,

160+ -- For some reason, the Shake profile files are truncated and won't load

161+ shakeProfiling :: !(Maybe FilePath),

162+ outputCSV :: !Bool

163+ }

164+

165+type HasConfig = (?config :: Config)

166+

167+configP :: Parser Config

168+configP = Config

169+ <$> (not <$> switch (long "quiet"))

170+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))

171+ <*> switch (long "csv")

172+

173+output :: (MonadIO m, HasConfig) => String -> m ()

174+output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())

175+

176+---------------------------------------------------------------------------------------

177+

178+type Experiment = TextDocumentIdentifier -> Session Bool

179+

180+data Bench = forall setup.

181+ Bench

182+ { name :: !String,

183+ samples :: !Natural,

184+ benchSetup :: TextDocumentIdentifier -> Session setup,

185+ experiment :: setup -> Experiment

186+ }

187+

188+bench :: String -> Natural -> Experiment -> Bench

189+bench name samples userExperiment = Bench {..}

190+ where

191+ experiment () = userExperiment

192+ benchSetup _ = return ()

193+

194+benchWithSetup ::

195+ String ->

196+ Natural ->

197+ (TextDocumentIdentifier -> Session p) ->

198+ (p -> Experiment) ->

199+ Bench

200+benchWithSetup = Bench

201+

202+runBenchmarks :: HasConfig => [Bench] -> IO ()

203+runBenchmarks benchmarks = do

204+ results <- forM benchmarks $ \b -> (b,) <$> runBench b

205+

206+ forM_ results $ \(Bench {name, samples}, duration) ->

207+ output $

208+ "TOTAL "

209+ <> name

210+ <> " = "

211+ <> showDuration duration

212+ <> " ("

213+ <> show samples

214+ <> " repetitions)"

215+

216+ when (outputCSV ?config) $ do

217+ putStrLn $ intercalate ", " $ map name benchmarks

218+ putStrLn $ intercalate ", " $ map (showDuration . snd) results

219+

220+runBench :: HasConfig => Bench -> IO Seconds

221+runBench Bench {..} = handleAny (\e -> print e >> return (-1))

222+ $ runSessionWithConfig conf cmd lspTestCaps dir

223+ $ do

224+ doc <- openDoc exampleModulePath "haskell"

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

226+

227+ liftIO $ output $ "Running " <> name <> " benchmark"

228+ userState <- benchSetup doc

229+ let loop 0 = return True

230+ loop n = do

231+ (t, res) <- duration $ experiment userState doc

232+ if not res

233+ then return False

234+ else do

235+ output (showDuration t)

236+ loop (n -1)

237+

238+ (t, res) <- duration $ loop samples

239+

240+ exitServer

241+ -- sleeep to give ghcide a chance to print the RTS stats

242+ liftIO $ threadDelay 50000

243+

244+ return $ if res then t else -1

245+ where

246+ cmd =

247+ unwords $

248+ [ "ghcide",

249+ "--lsp",

250+ "--cwd",

251+ dir,

252+ "+RTS",

253+ "-S",

254+ "-RTS"

255+ ]

256+ ++ concat

257+ [ ["--shake-profiling", path]

258+ | Just path <- [shakeProfiling ?config]

259+ ]

260+ dir = "bench/example/" <> examplePackage

261+ lspTestCaps =

262+ fullCaps {_window = Just $ WindowClientCapabilities $ Just True}

263+ conf =

264+ defaultConfig

265+ { logStdErr = verbose ?config,

266+ logMessages = False,

267+ logColor = False

268+ }

269+

270+setup :: HasConfig => IO (IO ())

271+setup = do

272+ alreadyExists <- doesDirectoryExist examplesPath

273+ when alreadyExists $ removeDirectoryRecursive examplesPath

274+ callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath

275+ writeFile

276+ (examplesPath </> examplePackage </> "hie.yaml")

277+ ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")

278+

279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280+

281+ return $ removeDirectoryRecursive examplesPath

282+

283+-- | Asks the server to shutdown and exit politely

284+exitServer :: Session ()

285+exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams

286+

287+--------------------------------------------------------------------------------------------

exe/Main.hs+520−62

@@ -7,16 +7,26 @@

8module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

10import Arguments

15import Arguments

11−import Data.Maybe

16+import Control.Concurrent.Async

12−import Data.List.Extra

13−import System.FilePath

14import Control.Concurrent.Extra

17import Control.Concurrent.Extra

15import Control.Exception

18import Control.Exception

16import Control.Monad.Extra

19import Control.Monad.Extra

17import Control.Monad.IO.Class

20import Control.Monad.IO.Class

18import Data.Default

21import Data.Default

19−import System.Time.Extra

22+import Data.Either

23+import Data.Function

24+import Data.List.Extra

25+import Data.Maybe

26+import qualified Data.Text as T

27+import qualified Data.Text.IO as T

28+import Data.Time.Clock (UTCTime)

29+import Data.Version

20import Development.IDE.Core.Debouncer

30import Development.IDE.Core.Debouncer

21import Development.IDE.Core.FileStore

31import Development.IDE.Core.FileStore

22import Development.IDE.Core.OfInterest

32import Development.IDE.Core.OfInterest

@@ -33,25 +43,39 @@ import Development.IDE.GHC.Util

33import Development.IDE.Plugin

43import Development.IDE.Plugin

34import Development.IDE.Plugin.Completions as Completions

44import Development.IDE.Plugin.Completions as Completions

35import Development.IDE.Plugin.CodeAction as CodeAction

45import Development.IDE.Plugin.CodeAction as CodeAction

36−import qualified Data.Text as T

37−import qualified Data.Text.IO as T

38import qualified Language.Haskell.LSP.Core as LSP

46import qualified Language.Haskell.LSP.Core as LSP

39import Language.Haskell.LSP.Messages

47import Language.Haskell.LSP.Messages

40−import Language.Haskell.LSP.Types (LspId(IdInt))

48+import Language.Haskell.LSP.Types

41−import Data.Version

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

42import Development.IDE.LSP.LanguageServer

50import Development.IDE.LSP.LanguageServer

43import qualified System.Directory.Extra as IO

51import qualified System.Directory.Extra as IO

44import System.Environment

52import System.Environment

45import System.IO

53import System.IO

46import System.Exit

54import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

58+import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)

47import Paths_ghcide

59import Paths_ghcide

48import Development.GitRev

60import Development.GitRev

49−import Development.Shake (Action, Rules, action)

61+import Development.Shake (Action, action)

50import qualified Data.HashSet as HashSet

62import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

51import qualified Data.Map.Strict as Map

64import qualified Data.Map.Strict as Map

65+import qualified Crypto.Hash.SHA1 as H

66+import qualified Data.ByteString.Char8 as B

67+import Data.ByteString.Base16 (encode)

68+import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))

69+import GhcMonad

70+import HscTypes (HscEnv(..), ic_dflags)

71+import GHC hiding (def)

72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )

73+import Data.Either.Extra

74+

52−import HIE.Bios

75+import HIE.Bios.Cradle

53−import Rules

76+import HIE.Bios.Types

77+

54−import RuleTypes

78+import Utils

56ghcideVersion :: IO String

80ghcideVersion :: IO String

57ghcideVersion = do

81ghcideVersion = do

@@ -97,15 +121,14 @@ main = do

97 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

121 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

98 t <- t

122 t <- t

99 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

100− let options = (defaultIdeOptions $ loadSession dir)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

101 { optReportProgress = clientSupportsProgress caps

125 { optReportProgress = clientSupportsProgress caps

102 , optShakeProfiling = argsShakeProfiling

126 , optShakeProfiling = argsShakeProfiling

103 , optTesting = argsTesting

127 , optTesting = argsTesting

104 , optThreads = argsThreads

128 , optThreads = argsThreads

105− , optInterfaceLoadingDiagnostics = argsTesting

106 }

129 }

107 debouncer <- newAsyncDebouncer

130 debouncer <- newAsyncDebouncer

108− initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)

131+ initialise caps (mainRule >> pluginRules plugins >> action kick)

109 getLspId event (logger minBound) debouncer options vfs

132 getLspId event (logger minBound) debouncer options vfs

110 else do

133 else do

111 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error

134 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error

@@ -115,55 +138,32 @@ main = do

115 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

116 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

117

140

118− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir

141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir

119 files <- expandFiles (argFiles ++ ["." | null argFiles])

142 files <- expandFiles (argFiles ++ ["." | null argFiles])

120 -- LSP works with absolute file paths, so try and behave similarly

143 -- LSP works with absolute file paths, so try and behave similarly

121 files <- nubOrd <$> mapM IO.canonicalizePath files

144 files <- nubOrd <$> mapM IO.canonicalizePath files

122 putStrLn $ "Found " ++ show (length files) ++ " files"

145 putStrLn $ "Found " ++ show (length files) ++ " files"

123

146

124− putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"

147+ putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"

125 cradles <- mapM findCradle files

148 cradles <- mapM findCradle files

126 let ucradles = nubOrd cradles

149 let ucradles = nubOrd cradles

127 let n = length ucradles

150 let n = length ucradles

128 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]

151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]

129− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do

130− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x

131− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg

132− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x

133− when (isNothing x) $ print cradle

134− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"

135− opts <- getComponentOptions cradle

136− createSession opts

137−

138− putStrLn "\nStep 5/6: Initializing the IDE"

152+ putStrLn "\nStep 3/4: Initializing the IDE"

139 vfs <- makeVFSHandle

153 vfs <- makeVFSHandle

140− let cradlesToSessions = Map.fromList $ zip ucradles sessions

154+ debouncer <- newAsyncDebouncer

141− let filesToCradles = Map.fromList $ zip files cradles

142− let grab file = fromMaybe (head sessions) $ do

143− cradle <- Map.lookup file filesToCradles

144− Map.lookup cradle cradlesToSessions

145−

146− let options =

147− (defaultIdeOptions $ return $ return . grab)

148− { optShakeProfiling = argsShakeProfiling }

149− ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs

155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs

150−

156+

151− putStrLn "\nStep 6/6: Type checking the files"

157+ putStrLn "\nStep 4/4: Type checking the files"

152 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files

158 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files

153− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files

159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)

154 let (worked, failed) = partition fst $ zip (map isJust results) files

160 let (worked, failed) = partition fst $ zip (map isJust results) files

155 when (failed /= []) $

161 when (failed /= []) $

156 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed

162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed

157

163

158 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"

164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"

159 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"

165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"

160−

166+ return ()

161− unless (null failed) exitFailure

162−

163−cradleRules :: Rules ()

164−cradleRules = do

165− loadGhcSession

166− cradleToSession

167

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

169expandFiles = concatMapM $ \x -> do

@@ -190,23 +190,405 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =

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

191showEvent lock e = withLock lock $ print e

192

193+

194+-- | Run the specific cradle on a specific FilePath via hie-bios.

195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)

196+cradleToSessionOpts cradle file = do

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

198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file

199+ case cradleRes of

200+ CradleSuccess r -> pure (Right r)

201+ CradleFail err -> return (Left [err])

202+ -- For the None cradle perhaps we still want to report an Info

203+ -- message about the fact that the file is being ignored.

204+ CradleNone -> return (Left [])

205+

206+emptyHscEnv :: IO HscEnv

207+emptyHscEnv = do

208+ libdir <- getLibdir

209+ env <- runGhc (Just libdir) getSession

210+ initDynLinker env

211+ pure env

212+

213+-- | Convert a target to a list of potential absolute paths.

214+-- A TargetModule can be anywhere listed by the supplied include

215+-- directories

216+-- A target file is a relative path but with a specific prefix so just need

217+-- to canonicalise it.

218+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]

219+targetToFile is (TargetModule mod) = do

220+ let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]

221+ exts = ["hs", "hs-boot", "lhs"]

222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223+targetToFile _ (TargetFile f _) = do

224+ f' <- canonicalizePath f

225+ return [toNormalizedFilePath' f']

226+

227+setNameCache :: IORef NameCache -> HscEnv -> HscEnv

228+setNameCache nc hsc = hsc { hsc_NC = nc }

229+

193−loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))

194−loadSession dir = liftIO $ do

231+loadSessionShake fp = do

232+ se <- getShakeExtras

233+ IdeOptions{optTesting} <- getIdeOptions

234+ res <- liftIO $ loadSession optTesting se fp

235+ return (fmap liftIO res)

236+

237+-- | This is the key function which implements multi-component support. All

238+-- components mapping to the same hie.yaml file are mapped to the same

239+-- HscEnv which is updated as new components are discovered.

240+loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))

241+loadSession optTesting ShakeExtras{logger, eventer} dir = do

242+ -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file

243+ hscEnvs <- newVar Map.empty :: IO (Var HieMap)

244+ -- Mapping from a Filepath to HscEnv

245+ fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)

246+

247+ -- This caches the mapping from Mod.hs -> hie.yaml

195− cradleLoc <- memoIO $ \v -> do

248+ cradleLoc <- memoIO $ \v -> do

196− res <- findCradle v

249+ res <- findCradle v

197− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

198− -- try and normalise that

251+ -- try and normalise that

199− -- e.g. see https://github.com/digital-asset/ghcide/issues/126

252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126

200− res' <- traverse IO.makeAbsolute res

253+ res' <- traverse IO.makeAbsolute res

201− return $ normalise <$> res'

254+ return $ normalise <$> res'

202− let session :: Maybe FilePath -> Action HscEnvEq

255+

203− session file = do

256+ -- Create a new HscEnv from a hieYaml root and a set of options

204− -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle

257+ -- If the hieYaml file already has an HscEnv, the new component is

205− let cradle = toNormalizedFilePath' $ fromMaybe dir file

258+ -- combined with the components in the old HscEnv into a new HscEnv

206− use_ LoadCradle cradle

259+ -- which contains the union.

260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)

261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])

262+ packageSetup (hieYaml, cfp, opts) = do

263+ -- Parse DynFlags for the newly discovered component

264+ hscEnv <- emptyHscEnv

265+ (df, targets) <- evalGhcEnv hscEnv $

266+ setOptions opts (hsc_dflags hscEnv)

267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)

268+ -- Now lookup to see whether we are combining with an existing HscEnv

269+ -- or making a new one. The lookup returns the HscEnv and a list of

270+ -- information about other components loaded into the HscEnv

271+ -- (unitId, DynFlag, Targets)

272+ modifyVar hscEnvs $ \m -> do

273+ -- Just deps if there's already an HscEnv

274+ -- Nothing is it's the first time we are making an HscEnv

275+ let oldDeps = Map.lookup hieYaml m

276+ let -- Add the raw information about this component to the list

277+ -- We will modify the unitId and DynFlags used for

278+ -- compilation but these are the true source of

279+ -- information.

280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info

281+ : maybe [] snd oldDeps

282+ -- Get all the unit-ids for things in this component

283+ inplace = map rawComponentUnitId new_deps

284+

285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do

286+ -- Remove all inplace dependencies from package flags for

287+ -- components in this HscEnv

288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags

289+ let prefix = show rawComponentUnitId

290+ -- See Note [Avoiding bad interface files]

291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2

292+ -- The final component information, mostly the same but the DynFlags don't

293+ -- contain any packages which are also loaded

294+ -- into the same component.

295+ pure $ ComponentInfo rawComponentUnitId

296+ processed_df

297+ uids

298+ rawComponentTargets

299+ rawComponentFP

300+ rawComponentCOptions

301+ rawComponentDependencyInfo

302+ -- Make a new HscEnv, we have to recompile everything from

303+ -- scratch again (for now)

304+ -- It's important to keep the same NameCache though for reasons

305+ -- that I do not fully understand

306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))

307+ hscEnv <- case oldDeps of

308+ Nothing -> emptyHscEnv

309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv

310+ newHscEnv <-

311+ -- Add the options for the current component to the HscEnv

312+ evalGhcEnv hscEnv $ do

313+ _ <- setSessionDynFlags df

314+ getSession

315+ -- Modify the map so the hieYaml now maps to the newly created

316+ -- HscEnv

317+ -- Returns

318+ -- . the new HscEnv so it can be used to modify the

319+ -- FilePath -> HscEnv map (fileToFlags)

320+ -- . The information for the new component which caused this cache miss

321+ -- . The modified information (without -inplace flags) for

322+ -- existing packages

323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))

324+

325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)

326+ session (hieYaml, cfp, opts) = do

327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)

328+ -- Make a map from unit-id to DynFlags, this is used when trying to

329+ -- resolve imports. (especially PackageImports)

330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)

331+

332+ -- For each component, now make a new HscEnvEq which contains the

333+ -- HscEnv for the hie.yaml file but the DynFlags for that component

334+

335+ -- New HscEnv for the component in question, returns the new HscEnvEq and

336+ -- a mapping from FilePath to the newly created HscEnvEq.

337+ let new_cache = newComponentCache logger hscEnv uids

338+ (cs, res) <- new_cache new

339+ -- Modified cache targets for everything else in the hie.yaml file

340+ -- which now uses the same EPS and so on

341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps

342+ modifyVar_ fileToFlags $ \var -> do

343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var

344+

345+ return (fst res)

346+

347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)

348+ consultCradle hieYaml cfp = do

349+ when optTesting $ eventer $ notifyCradleLoaded cfp

350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)

351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml

352+ eopts <- cradleToSessionOpts cradle cfp

353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)

354+ case eopts of

355+ -- The cradle gave us some options so get to work turning them

356+ -- into and HscEnv.

357+ Right opts -> do

358+ session (hieYaml, toNormalizedFilePath' cfp, opts)

359+ -- Failure case, either a cradle error or the none cradle

360+ Left err -> do

361+ dep_info <- getDependencyInfo (maybeToList hieYaml)

362+ let ncfp = toNormalizedFilePath' cfp

363+ let res = (map (renderCradleError ncfp) err, Nothing)

364+ modifyVar_ fileToFlags $ \var -> do

365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var

366+ return res

367+

368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]

369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)

370+ sessionOpts (hieYaml, file) = do

371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags

372+ cfp <- canonicalizePath file

373+ case HM.lookup (toNormalizedFilePath' cfp) v of

374+ Just (opts, old_di) -> do

375+ deps_ok <- checkDependencyInfo old_di

376+ if not deps_ok

377+ then do

378+ -- If the dependencies are out of date then clear both caches and start

379+ -- again.

380+ modifyVar_ fileToFlags (const (return Map.empty))

381+ -- Keep the same name cache

382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )

383+ consultCradle hieYaml cfp

384+ else return opts

385+ Nothing -> consultCradle hieYaml cfp

386+

387+ dummyAs <- async $ return (error "Uninitialised")

388+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))

389+ -- The main function which gets options for a file. We only want one of these running

390+ -- at a time. Therefore the IORef contains the currently running cradle, if we try

391+ -- to get some more options then we wait for the currently running action to finish

392+ -- before attempting to do so.

393+ let getOptions :: FilePath -> IO (IdeResult HscEnvEq)

394+ getOptions file = do

395+ hieYaml <- cradleLoc file

396+ sessionOpts (hieYaml, file)

207− return $ \file -> session =<< liftIO (cradleLoc file)

397+ return $ \file -> do

398+ join $ mask_ $ modifyVar runningCradle $ \as -> do

399+ -- If the cradle is not finished, then wait for it to finish.

400+ void $ wait as

401+ as <- async $ getOptions file

402+ return (as, wait as)

208

403

209

404

405+

406+-- | Create a mapping from FilePaths to HscEnvEqs

407+newComponentCache

408+ :: Logger

409+ -> HscEnv

410+ -> [(InstalledUnitId, DynFlags)]

411+ -> ComponentInfo

412+ -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))

413+newComponentCache logger hsc_env uids ci = do

414+ let df = componentDynFlags ci

415+ let hscEnv' = hsc_env { hsc_dflags = df

416+ , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }

417+

418+ versionMismatch <- checkGhcVersion

419+ henv <- case versionMismatch of

420+ Just mismatch -> return mismatch

421+ Nothing -> newHscEnvEq hscEnv' uids

422+ let res = (([], Just henv), componentDependencyInfo ci)

423+ logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))

424+

425+ let is = importPaths df

426+ ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci)

427+ -- A special target for the file which caused this wonderful

428+ -- component to be created. In case the cradle doesn't list all the targets for

429+ -- the component, in which case things will be horribly broken anyway.

430+ -- Otherwise, we will immediately attempt to reload this module which

431+ -- causes an infinite loop and high CPU usage.

432+ let special_target = (componentFP ci, res)

433+ let xs = map (,res) ctargets

434+ return (special_target:xs, res)

435+

436+{- Note [Avoiding bad interface files]

437+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

438+Originally, we set the cache directory for the various components once

439+on the first occurrence of the component.

440+This works fine if these components have no references to each other,

441+but you have components that depend on each other, the interface files are

442+updated for each component.

443+After restarting the session and only opening the component that depended

444+on the other, suddenly the interface files of this component are stale.

445+However, from the point of view of `ghcide`, they do not look stale,

446+thus, not regenerated and the IDE shows weird errors such as:

447+```

448+typecheckIface

449+Declaration for Rep_ClientRunFlags

450+Axiom branches Rep_ClientRunFlags:

451+ Failed to load interface for ‘Distribution.Simple.Flag’

452+ Use -v to see a list of the files searched for.

453+```

454+and

455+```

456+expectJust checkFamInstConsistency

457+CallStack (from HasCallStack):

458+ error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes

459+ expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst

460+```

461+

462+To mitigate this, we set the cache directory for each component dependent

463+on the components of the current `HscEnv`, additionally to the component options

464+of the respective components.

465+Assume two components, c1, c2, where c2 depends on c1, and the options of the

466+respective components are co1, co2.

467+If we want to load component c2, followed by c1, we set the cache directory for

468+each component in this way:

469+

470+ * Load component c2

471+ * (Cache Directory State)

472+ - name of c2 + co2

473+ * Load component c1

474+ * (Cache Directory State)

475+ - name of c2 + name of c1 + co2

476+ - name of c2 + name of c1 + co1

477+

478+Overall, we created three cache directories. If we opened c1 first, then we

479+create a fourth cache directory.

480+This makes sure that interface files are always correctly updated.

481+

482+Since this causes a lot of recompilation, we only update the cache-directory,

483+if the dependencies of a component have really changed.

484+E.g. when you load two executables, they can not depend on each other. They

485+should be filtered out, such that we dont have to re-compile everything.

486+-}

487+

488+-- | Set the cache-directory based on the ComponentOptions and a list of

489+-- internal packages.

490+-- For the exact reason, see Note [Avoiding bad interface files].

491+setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags

492+setCacheDir logger prefix hscComponents comps dflags = do

493+ cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)

494+ liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir

495+ pure $ dflags

496+ & setHiDir cacheDir

497+ & setDefaultHieDir cacheDir

498+

499+

500+renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic

501+renderCradleError nfp (CradleError _ec t) =

502+ ideErrorText nfp (T.unlines (map T.pack t))

503+

504+-- See Note [Multi Cradle Dependency Info]

505+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)

506+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])

507+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))

508+

509+-- This is pristine information about a component

510+data RawComponentInfo = RawComponentInfo

511+ { rawComponentUnitId :: InstalledUnitId

512+ -- | Unprocessed DynFlags. Contains inplace packages such as libraries.

513+ -- We do not want to use them unprocessed.

514+ , rawComponentDynFlags :: DynFlags

515+ -- | All targets of this components.

516+ , rawComponentTargets :: [Target]

517+ -- | Filepath which caused the creation of this component

518+ , rawComponentFP :: NormalizedFilePath

519+ -- | Component Options used to load the component.

520+ , rawComponentCOptions :: ComponentOptions

521+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file

522+ -- to last modification time. See Note [Multi Cradle Dependency Info].

523+ , rawComponentDependencyInfo :: DependencyInfo

524+ }

525+

526+-- This is processed information about the component, in particular the dynflags will be modified.

527+data ComponentInfo = ComponentInfo

528+ { componentUnitId :: InstalledUnitId

529+ -- | Processed DynFlags. Does not contain inplace packages such as local

530+ -- libraries. Can be used to actually load this Component.

531+ , componentDynFlags :: DynFlags

532+ -- | Internal units, such as local libraries, that this component

533+ -- is loaded with. These have been extracted from the original

534+ -- ComponentOptions.

535+ , componentInternalUnits :: [InstalledUnitId]

536+ -- | All targets of this components.

537+ , componentTargets :: [Target]

538+ -- | Filepath which caused the creation of this component

539+ , componentFP :: NormalizedFilePath

540+ -- | Component Options used to load the component.

541+ , componentCOptions :: ComponentOptions

542+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file

543+ -- to last modification time. See Note [Multi Cradle Dependency Info]

544+ , componentDependencyInfo :: DependencyInfo

545+ }

546+

547+-- | Check if any dependency has been modified lately.

548+checkDependencyInfo :: DependencyInfo -> IO Bool

549+checkDependencyInfo old_di = do

550+ di <- getDependencyInfo (Map.keys old_di)

551+ return (di == old_di)

552+

553+-- Note [Multi Cradle Dependency Info]

554+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

555+-- Why do we implement our own file modification tracking here?

556+-- The primary reason is that the custom caching logic is quite complicated and going into shake

557+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to

558+-- use shake rules rather than IO but eventually gave up.

559+

560+-- | Computes a mapping from a filepath to its latest modification date.

561+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead

562+-- of letting shake take care of it.

563+getDependencyInfo :: [FilePath] -> IO DependencyInfo

564+getDependencyInfo fs = Map.fromList <$> mapM do_one fs

565+

566+ where

567+ tryIO :: IO a -> IO (Either IOException a)

568+ tryIO = try

569+

570+ do_one :: FilePath -> IO (FilePath, Maybe UTCTime)

571+ do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)

572+

573+-- | This function removes all the -package flags which refer to packages we

574+-- are going to deal with ourselves. For example, if a executable depends

575+-- on a library component, then this function will remove the library flag

576+-- from the package flags for the executable

577+--

578+-- There are several places in GHC (for example the call to hptInstances in

579+-- tcRnImports) which assume that all modules in the HPT have the same unit

580+-- ID. Therefore we create a fake one and give them all the same unit id.

581+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])

582+removeInplacePackages us df = (df { packageFlags = ps

583+ , thisInstalledUnitId = fake_uid }, uids)

584+ where

585+ (uids, ps) = partitionEithers (map go (packageFlags df))

586+ fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")

587+ go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us

588+ then Left (toInstalledUnitId u)

589+ else Right p

590+ go p = Right p

591+

210-- | Memoize an IO function, with the characteristics:

592-- | Memoize an IO function, with the characteristics:

211--

593--

212-- * If multiple people ask for a result simultaneously, make sure you only compute it once.

594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.

@@ -223,3 +605,79 @@ memoIO op = do

223 res <- onceFork $ op k

605 res <- onceFork $ op k

224 return (Map.insert k res mp, res)

606 return (Map.insert k res mp, res)

225 Just res -> return (mp, res)

607 Just res -> return (mp, res)

608+

609+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])

610+setOptions (ComponentOptions theOpts compRoot _) dflags = do

611+ (dflags', targets) <- addCmdOpts theOpts dflags

612+ let dflags'' =

613+ -- disabled, generated directly by ghcide instead

614+ flip gopt_unset Opt_WriteInterface $

615+ -- disabled, generated directly by ghcide instead

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

617+ dontWriteHieFiles $

618+ setIgnoreInterfacePragmas $

619+ setLinkerOptions $

620+ disableOptimisation $

621+ makeDynFlagsAbsolute compRoot dflags'

622+ -- initPackages parses the -package flags and

623+ -- sets up the visibility for each component.

624+ (final_df, _) <- liftIO $ initPackages dflags''

625+ return (final_df, targets)

626+

627+

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

629+-- (HscInterpreted) which implies LinkInMemory

630+-- HscInterpreted

631+setLinkerOptions :: DynFlags -> DynFlags

632+setLinkerOptions df = df {

633+ ghcLink = LinkInMemory

634+ , hscTarget = HscNothing

635+ , ghcMode = CompManager

636+ }

637+

638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639+setIgnoreInterfacePragmas df =

640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641+

642+disableOptimisation :: DynFlags -> DynFlags

643+disableOptimisation df = updOptLevel 0 df

644+

645+setHiDir :: FilePath -> DynFlags -> DynFlags

646+setHiDir f d =

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

648+ d { hiDir = Just f}

649+

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

651+getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)

652+ where

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

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

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

656+

657+-- | Sub directory for the cache path

658+cacheDir :: String

659+cacheDir = "ghcide"

660+

661+notifyCradleLoaded :: FilePath -> FromServerMessage

662+notifyCradleLoaded fp =

663+ NotCustomServer $

664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665+ toJSON fp

666+

667+cradleLoadedMethod :: T.Text

668+cradleLoadedMethod = "ghcide/cradle/loaded"

669+

670+ghcVersionChecker :: IO VersionCheck

671+ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))

672+

673+checkGhcVersion :: IO (Maybe HscEnvEq)

674+checkGhcVersion = do

675+ res <- ghcVersionChecker

676+ case res of

677+ Failure err -> do

678+ putStrLn $ "Error while checking GHC version: " ++ show err

679+ return Nothing

680+ Mismatch {..} ->

681+ return $ Just GhcVersionMismatch {..}

682+ _ ->

683+ return Nothing

exe/RuleTypes.hsdeleted−33

@@ -1,33 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−module RuleTypes (GetHscEnv(..), LoadCradle(..)) where

3−

4−import Control.DeepSeq

5−import Data.Binary

6−import Data.Hashable (Hashable)

7−import Development.Shake

8−import Development.IDE.GHC.Util

9−import Data.Typeable (Typeable)

10−import GHC.Generics (Generic)

11−

12−-- Rule type for caching GHC sessions.

13−type instance RuleResult GetHscEnv = HscEnvEq

14−

15−data GetHscEnv = GetHscEnv

16− { hscenvOptions :: [String] -- componentOptions from hie-bios

17− , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

18− }

19− deriving (Eq, Show, Typeable, Generic)

20−

21−instance Hashable GetHscEnv

22−instance NFData GetHscEnv

23−instance Binary GetHscEnv

24−

25−-- Rule type for caching cradle loading

26−type instance RuleResult LoadCradle = HscEnvEq

27−

28−data LoadCradle = LoadCradle

29− deriving (Eq, Show, Typeable, Generic)

30−

31−instance Hashable LoadCradle

32−instance NFData LoadCradle

33−instance Binary LoadCradle

exe/Rules.hsdeleted−142

@@ -1,142 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−module Rules

3− ( loadGhcSession

4− , cradleToSession

5− , cradleLoadedMethod

6− , createSession

7− , getComponentOptions

8− )

9−where

10−

11−import Control.Exception

12−import Control.Monad (filterM, when)

13−import qualified Crypto.Hash.SHA1 as H

14−import Data.ByteString.Base16 (encode)

15−import qualified Data.ByteString.Char8 as B

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

17−import Data.Text (Text, pack)

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

19−import Development.IDE.Core.Service (getIdeOptions)

20−import Development.IDE.Core.Shake (actionLogger, sendEvent, define, useNoFile_)

21−import Development.IDE.GHC.Util

22−import Development.IDE.Types.Location (fromNormalizedFilePath)

23−import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting))

24−import Development.Shake

25−import GHC

26−import GHC.Check (VersionCheck(..), makeGhcVersionChecker)

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.FilePath.Posix (addTrailingPathSeparator,

35− (</>))

36−import qualified Language.Haskell.LSP.Messages as LSP

37−import qualified Language.Haskell.LSP.Types as LSP

38−import Data.Aeson (ToJSON(toJSON))

39−import Development.IDE.Types.Logger (logDebug)

40−import Util

41−

42−-- Prefix for the cache path

43−cacheDir :: String

44−cacheDir = "ghcide"

45−

46−notifyCradleLoaded :: FilePath -> LSP.FromServerMessage

47−notifyCradleLoaded fp =

48− LSP.NotCustomServer $

49− LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $

50− toJSON fp

51−

52−loadGhcSession :: Rules ()

53−loadGhcSession =

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

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

56− -- the existing session.

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

58− liftIO $ createSession $ ComponentOptions opts deps

59−

60−cradleToSession :: Rules ()

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

62−

63− let f = fromNormalizedFilePath nfp

64−

65− IdeOptions{optTesting} <- getIdeOptions

66−

67− logger <- actionLogger

68− liftIO $ logDebug logger $ "Running cradle " <> pack (fromNormalizedFilePath nfp)

69−

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

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

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

73−

74− when optTesting $

75− sendEvent $ notifyCradleLoaded f

76−

77− -- Avoid interrupting `getComponentOptions` since it calls external processes

78− cmpOpts <- liftIO $ mask $ \_ -> getComponentOptions cradle

79− let opts = componentOptions cmpOpts

80− deps = componentDependencies cmpOpts

81− deps' = case mbYaml of

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

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

84− _ -> deps

85− existingDeps <- filterM doesFileExist deps'

86− need existingDeps

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

88−

89−cradleLoadedMethod :: Text

90−cradleLoadedMethod = "ghcide/cradle/loaded"

91−

92−getComponentOptions :: Cradle a -> IO ComponentOptions

93−getComponentOptions cradle = do

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

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

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

97− case cradleRes of

98− CradleSuccess r -> pure r

99− CradleFail err -> throwIO err

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

101− -- That will require some more changes.

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

103−

104−ghcVersionChecker :: IO VersionCheck

105−ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))

106−

107−checkGhcVersion :: IO (Maybe HscEnvEq)

108−checkGhcVersion = do

109− res <- ghcVersionChecker

110− case res of

111− Failure err -> do

112− putStrLn $ "Error while checking GHC version: " ++ show err

113− return Nothing

114− Mismatch {..} ->

115− return $ Just GhcVersionMismatch {..}

116− _ ->

117− return Nothing

118−

119−createSession :: ComponentOptions -> IO HscEnvEq

120−createSession (ComponentOptions theOpts _) = do

121− libdir <- getLibdir

122−

123− cacheDir <- getCacheDir theOpts

124−

125− runGhc (Just libdir) $ do

126− dflags <- getSessionDynFlags

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

128− setupDynFlags cacheDir dflags'

129− versionMismatch <- liftIO checkGhcVersion

130− case versionMismatch of

131− Just mismatch -> return mismatch

132− Nothing -> do

133− env <- getSession

134− liftIO $ initDynLinker env

135− liftIO $ newHscEnvEq env

136−

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

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

139− where

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

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

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

exe/Util.hsdeleted−62

@@ -1,62 +0,0 @@

1−module Util (setupDynFlags, getLibdir) where

2−

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

4−import qualified GHC.Paths as GHCPaths

5−import DynFlags ( gopt_unset

6− , GhcMode(CompManager)

7− , HscTarget(HscNothing)

8− , GhcLink(LinkInMemory)

9− , GeneralFlag

10− ( Opt_IgnoreInterfacePragmas

11− , Opt_IgnoreOptimChanges

12− , Opt_WriteInterface

13− )

14− , gopt_set

15− , updOptLevel

16− , DynFlags(..)

17− )

18−import Data.Maybe ( fromMaybe )

19−import Development.IDE.GHC.Util ( setDefaultHieDir

20− , dontWriteHieFiles

21− )

22−import System.Environment ( lookupEnv )

23−import GHC (GhcMonad, setSessionDynFlags )

24−import Data.Functor ( void )

25−

26−setupDynFlags :: GhcMonad f => FilePath -> DynFlags -> f ()

27−setupDynFlags cacheDir =

28− void

29− . setSessionDynFlags

30− -- disabled, generated directly by ghcide instead

31− . flip gopt_unset Opt_WriteInterface

32− -- disabled, generated directly by ghcide instead

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

34− . dontWriteHieFiles

35− . setHiDir cacheDir

36− . setDefaultHieDir cacheDir

37− . setIgnoreInterfacePragmas

38− . setLinkerOptions

39− . disableOptimisation

40−

41−getLibdir :: IO FilePath

42−getLibdir = fromMaybe GHCPaths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

43−

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

45−-- (HscInterpreted) which implies LinkInMemory

46−

47−-- HscInterpreted

48−setLinkerOptions :: DynFlags -> DynFlags

49−setLinkerOptions df =

50− df { ghcLink = LinkInMemory, hscTarget = HscNothing, ghcMode = CompManager }

51−

52−setIgnoreInterfacePragmas :: DynFlags -> DynFlags

53−setIgnoreInterfacePragmas df =

54− gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

55−

56−disableOptimisation :: DynFlags -> DynFlags

57−disableOptimisation df = updOptLevel 0 df

58−

59−setHiDir :: FilePath -> DynFlags -> DynFlags

60−setHiDir f d =

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

62− d { hiDir = Just f }

exe/Utils.hsnew file+9

@@ -0,0 +1,9 @@

1+module Utils (getLibdir) where

3+import qualified GHC.Paths

4+import System.Environment

5+import Data.Maybe

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

8+getLibdir :: IO FilePath

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

ghcide.cabal+57−11

@@ -2,12 +2,12 @@ cabal-version: 1.20

2build-type: Simple

3category: Development

4name: ghcide

5−version: 0.1.0

5+version: 0.2.0

6license: Apache-2.0

7license-file: LICENSE

8author: Digital Asset

9maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

11synopsis: The core of an IDE

12description:

13 A library for building Haskell IDE's on top of the GHC API.

@@ -15,7 +15,13 @@ homepage: https://github.com/digital-asset/ghcide#readme

15bug-reports: https://github.com/digital-asset/ghcide/issues

16tested-with: GHC==8.6.5

17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md

18− test/data/GotoHover.hs

18+ test/data/hover/*.hs

19+ test/data/multi/cabal.project

20+ test/data/multi/hie.yaml

21+ test/data/multi/a/a.cabal

22+ test/data/multi/a/*.hs

23+ test/data/multi/b/b.cabal

24+ test/data/multi/b/*.hs

20source-repository head

26source-repository head

21 type: git

27 type: git

@@ -44,8 +50,8 @@ library

44 filepath,

50 filepath,

45 haddock-library >= 1.8,

51 haddock-library >= 1.8,

46 hashable,

52 hashable,

47− haskell-lsp-types == 0.21.*,

53+ haskell-lsp-types == 0.22.*,

48− haskell-lsp == 0.21.*,

54+ haskell-lsp == 0.22.*,

49 mtl,

55 mtl,

50 network-uri,

56 network-uri,

51 prettyprinter-ansi-terminal,

57 prettyprinter-ansi-terminal,

@@ -184,6 +190,8 @@ executable ghcide

184 "-with-rtsopts=-I0 -qg -A128M"

190 "-with-rtsopts=-I0 -qg -A128M"

185 main-is: Main.hs

191 main-is: Main.hs

186 build-depends:

192 build-depends:

193+ time,

194+ async,

187 hslogger,

195 hslogger,

188 aeson,

196 aeson,

189 base == 4.*,

197 base == 4.*,

@@ -197,25 +205,23 @@ executable ghcide

197 directory,

205 directory,

198 extra,

206 extra,

199 filepath,

207 filepath,

200− ghc-check >= 0.3.0.1,

208+ ghc-check >= 0.3.0.1 && < 0.4,

201 ghc-paths,

209 ghc-paths,

202 ghc,

210 ghc,

203 gitrev,

211 gitrev,

204 hashable,

212 hashable,

205 haskell-lsp,

213 haskell-lsp,

206 haskell-lsp-types,

214 haskell-lsp-types,

207− hie-bios >= 0.4.0 && < 0.5,

215+ hie-bios >= 0.5.0 && < 0.6,

208 ghcide,

216 ghcide,

209 optparse-applicative,

217 optparse-applicative,

210 shake,

218 shake,

211 text,

219 text,

212 unordered-containers

220 unordered-containers

213 other-modules:

221 other-modules:

222+ Utils

214 Arguments

223 Arguments

215 Paths_ghcide

224 Paths_ghcide

216− Rules

217− RuleTypes

218− Util

219

225

220 default-extensions:

226 default-extensions:

221 BangPatterns

227 BangPatterns

@@ -263,7 +269,7 @@ test-suite ghcide-tests

263 haskell-lsp-types,

269 haskell-lsp-types,

264 network-uri,

270 network-uri,

265 lens,

271 lens,

266− lsp-test >= 0.8,

272+ lsp-test >= 0.11.0.1 && < 0.12,

267 parser-combinators,

273 parser-combinators,

268 QuickCheck,

274 QuickCheck,

269 quickcheck-instances,

275 quickcheck-instances,

@@ -296,3 +302,43 @@ test-suite ghcide-tests

296 TupleSections

302 TupleSections

297 TypeApplications

303 TypeApplications

298 ViewPatterns

304 ViewPatterns

305+

306+benchmark ghcide-bench

307+ type: exitcode-stdio-1.0

308+ default-language: Haskell2010

309+ build-tool-depends:

310+ ghcide:ghcide,

311+ ghcide:ghcide-test-preprocessor

312+ build-depends:

313+ aeson,

314+ base,

315+ bytestring,

316+ containers,

317+ directory,

318+ extra,

319+ filepath,

320+ ghcide,

321+ lsp-test < 0.12,

322+ optparse-applicative,

323+ parser-combinators,

324+ process,

325+ safe-exceptions

326+ hs-source-dirs: bench

327+ include-dirs: include

328+ ghc-options: -threaded -Wall -Wno-name-shadowing

329+ main-is: Main.hs

330+ other-modules:

331+ default-extensions:

332+ BangPatterns

333+ DeriveFunctor

334+ DeriveGeneric

335+ GeneralizedNewtypeDeriving

336+ LambdaCase

337+ NamedFieldPuns

338+ OverloadedStrings

339+ RecordWildCards

340+ ScopedTypeVariables

341+ StandaloneDeriving

342+ TupleSections

343+ TypeApplications

344+ ViewPatterns

hie.yaml+12−1

@@ -1 +1,12 @@

1+cradle:

2+ cabal:

3+ - path: "./src"

1−cradle: {stack: {component: "ghcide:lib"}}

4+ component: "ghcide:lib:ghcide"

5+ - path: "./exe"

6+ component: "ghcide:exe:ghcide"

7+ - path: "./test"

8+ component: "ghcide:test:ghcide-tests"

9+ - path: "./bench"

10+ component: "ghcide:benchmark:ghcide-bench"

11+ - path: "./test/preprocessor"

12+ component: "ghcide:exe:ghcide-test-preprocessor"

src/Development/IDE/Core/Compile.hs+23−5

@@ -90,14 +90,15 @@ import Exception (ExceptionMonad)

90parseModule

91 :: IdeOptions

92 -> HscEnv

93+ -> [PackageName]

93 -> FilePath

94 -> FilePath

94 -> Maybe SB.StringBuffer

95 -> Maybe SB.StringBuffer

95 -> IO (IdeResult (StringBuffer, ParsedModule))

96 -> IO (IdeResult (StringBuffer, ParsedModule))

96−parseModule IdeOptions{..} env filename mbContents =

97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =

97 fmap (either (, Nothing) id) $

98 fmap (either (, Nothing) id) $

98 evalGhcEnv env $ runExceptT $ do

99 evalGhcEnv env $ runExceptT $ do

99 (contents, dflags) <- preprocessor filename mbContents

100 (contents, dflags) <- preprocessor filename mbContents

100− (diag, modu) <- parseFileContents optPreprocessor dflags filename contents

101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents

101 return (diag, Just (contents, modu))

102 return (diag, Just (contents, modu))

102

103

104

@@ -499,10 +500,11 @@ parseFileContents

499 :: GhcMonad m

500 :: GhcMonad m

500 => (GHC.ParsedSource -> IdePreprocessedSource)

501 => (GHC.ParsedSource -> IdePreprocessedSource)

501 -> DynFlags -- ^ flags to use

502 -> DynFlags -- ^ flags to use

503+ -> [PackageName] -- ^ The package imports to ignore

502 -> FilePath -- ^ the filename (for source locations)

504 -> FilePath -- ^ the filename (for source locations)

503 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

505 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

504 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

505−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

506 let loc = mkRealSrcLoc (mkFastString filename) 1 1

508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

507 case unP Parser.parseModule (mkPState dflags contents loc) of

509 case unP Parser.parseModule (mkPState dflags contents loc) of

508#if MIN_GHC_API_VERSION(8,10,0)

510#if MIN_GHC_API_VERSION(8,10,0)

@@ -534,18 +536,34 @@ parseFileContents customPreprocessor dflags filename contents = do

534 -- Ok, we got here. It's safe to continue.

536 -- Ok, we got here. It's safe to continue.

535 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

536 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

539+ let parsed' = removePackageImports comp_pkgs parsed

537 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

538− ms <- getModSummaryFromBuffer filename dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

539 let pm =

542 let pm =

540 ParsedModule {

543 ParsedModule {

541 pm_mod_summary = ms

544 pm_mod_summary = ms

542− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

543 , pm_extra_src_files=[] -- src imports not allowed

546 , pm_extra_src_files=[] -- src imports not allowed

544 , pm_annotations = hpm_annotations

547 , pm_annotations = hpm_annotations

545 }

548 }

546 warnings = diagFromErrMsgs "parser" dflags warns

549 warnings = diagFromErrMsgs "parser" dflags warns

547 pure (warnings ++ preproc_warnings, pm)

550 pure (warnings ++ preproc_warnings, pm)

548

551

552+

553+-- | After parsing the module remove all package imports referring to

554+-- these packages as we have already dealt with what they map to.

555+removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource

556+removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })

557+ where

558+ imports' = map do_one_import hsmodImports

559+ do_one_import (L l i@ImportDecl{ideclPkgQual}) =

560+ case PackageName . sl_fs <$> ideclPkgQual of

561+ Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })

562+ _ -> L l i

563+#if MIN_GHC_API_VERSION(8,6,0)

564+ do_one_import l = l

565+#endif

566+

549loadHieFile :: FilePath -> IO GHC.HieFile

567loadHieFile :: FilePath -> IO GHC.HieFile

550loadHieFile f = do

568loadHieFile f = do

551 u <- mkSplitUniqSupply 'a'

569 u <- mkSplitUniqSupply 'a'

src/Development/IDE/Core/FileExists.hs+15−11

@@ -91,20 +91,24 @@ getFileExists fp = use_ GetFileExists fp

91-- Provides a fast implementation if client supports dynamic watched files.

92-- Creates a global state as a side effect in that case.

93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs

94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

95+ -- Create the global always, although it should only be used if we have fast rules.

96+ -- But there's a chance someone will send unexpected notifications anyway,

97+ -- e.g. https://github.com/digital-asset/ghcide/issues/599

98+ addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

99+ case () of

95− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

100+ _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

96− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

97− , Just True <- _dynamicRegistration

102+ , Just True <- _dynamicRegistration

98− = fileExistsRulesFast getLspId vfs

103+ -> fileExistsRulesFast getLspId vfs

99− | otherwise = do

104+ | otherwise -> do

100− logger <- logger <$> getShakeExtrasRules

105+ logger <- logger <$> getShakeExtrasRules

101− liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"

106+ liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"

102− fileExistsRulesSlow vfs

107+ fileExistsRulesSlow vfs

103

108

104-- Requires an lsp client that provides WatchedFiles notifications.

109-- Requires an lsp client that provides WatchedFiles notifications.

105fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

110fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

106−fileExistsRulesFast getLspId vfs = do

111+fileExistsRulesFast getLspId vfs =

107− addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

108 defineEarlyCutoff $ \GetFileExists file -> do

112 defineEarlyCutoff $ \GetFileExists file -> do

109 isWf <- isWorkspaceFile file

113 isWf <- isWorkspaceFile file

110 if isWf

114 if isWf

src/Development/IDE/Core/PositionMapping.hs+48−10

@@ -2,10 +2,15 @@

2-- SPDX-License-Identifier: Apache-2.0

3module Development.IDE.Core.PositionMapping

4 ( PositionMapping(..)

5+ , fromCurrentPosition

6+ , toCurrentPosition

7+ , PositionDelta(..)

8+ , addDelta

9+ , mkDelta

5 , toCurrentRange

10 , toCurrentRange

6 , fromCurrentRange

11 , fromCurrentRange

7 , applyChange

12 , applyChange

8− , idMapping

13+ , zeroMapping

9 -- toCurrent and fromCurrent are mainly exposed for testing

14 -- toCurrent and fromCurrent are mainly exposed for testing

10 , toCurrent

15 , toCurrent

11 , fromCurrent

16 , fromCurrent

@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping

14import Control.Monad

19import Control.Monad

15import qualified Data.Text as T

20import qualified Data.Text as T

16import Language.Haskell.LSP.Types

21import Language.Haskell.LSP.Types

22+import Data.List

18−data PositionMapping = PositionMapping

24+-- The position delta is the difference between two versions

25+data PositionDelta = PositionDelta

19− { toCurrentPosition :: !(Position -> Maybe Position)

26+ { toDelta :: !(Position -> Maybe Position)

20− , fromCurrentPosition :: !(Position -> Maybe Position)

27+ , fromDelta :: !(Position -> Maybe Position)

21 }

28 }

30+fromCurrentPosition :: PositionMapping -> Position -> Maybe Position

31+fromCurrentPosition (PositionMapping pm) = fromDelta pm

32+

33+toCurrentPosition :: PositionMapping -> Position -> Maybe Position

34+toCurrentPosition (PositionMapping pm) = toDelta pm

35+

36+-- A position mapping is the difference from the current version to

37+-- a specific version

38+newtype PositionMapping = PositionMapping PositionDelta

39+

40+

23toCurrentRange :: PositionMapping -> Range -> Maybe Range

41toCurrentRange :: PositionMapping -> Range -> Maybe Range

24toCurrentRange mapping (Range a b) =

42toCurrentRange mapping (Range a b) =

25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range

28fromCurrentRange mapping (Range a b) =

46fromCurrentRange mapping (Range a b) =

29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

31−idMapping :: PositionMapping

49+zeroMapping :: PositionMapping

32−idMapping = PositionMapping Just Just

50+zeroMapping = PositionMapping idDelta

51+

52+-- | Compose two position mappings. Composes in the same way as function

53+-- composition (ie the second argument is applyed to the position first).

54+composeDelta :: PositionDelta

55+ -> PositionDelta

56+ -> PositionDelta

57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =

58+ PositionDelta (to1 <=< to2)

59+ (from1 >=> from2)

60+

61+idDelta :: PositionDelta

62+idDelta = PositionDelta Just Just

63+

64+-- | Convert a set of changes into a delta from k to k + 1

65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66+mkDelta cs = foldl' applyChange idDelta cs

67+

68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n

69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping

70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)

34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping

72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping

73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta

36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping

74+ { toDelta = toCurrent r t <=< toDelta

37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t

75+ , fromDelta = fromDelta <=< fromCurrent r t

38 }

76 }

39applyChange posMapping _ = posMapping

77applyChange posMapping _ = posMapping

src/Development/IDE/Core/Rules.hs+141−82

@@ -28,8 +28,8 @@ module Development.IDE.Core.Rules(

29import Fingerprint

31−import Data.Binary

31+import Data.Binary hiding (get, put)

32−import Data.Bifunctor (second)

32+import Data.Bifunctor (first, second)

33import Control.Monad.Extra

34import Control.Monad.Trans.Class

35import Control.Monad.Trans.Maybe

@@ -46,13 +46,11 @@ import Development.IDE.Types.Location

46import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

47import Development.IDE.GHC.Util

48import Development.IDE.GHC.WithDynFlags

49−import Data.Coerce

50import Data.Either.Extra

49import Data.Either.Extra

51import Data.Maybe

50import Data.Maybe

52import Data.Foldable

51import Data.Foldable

53import qualified Data.IntMap.Strict as IntMap

52import qualified Data.IntMap.Strict as IntMap

54import Data.IntMap.Strict (IntMap)

53import Data.IntMap.Strict (IntMap)

55−import qualified Data.IntSet as IntSet

56import Data.List

54import Data.List

57import Data.Ord

55import Data.Ord

58import qualified Data.Set as Set

56import qualified Data.Set as Set

@@ -61,20 +59,24 @@ import Development.IDE.GHC.Error

61import Development.Shake hiding (Diagnostic)

59import Development.Shake hiding (Diagnostic)

62import Development.IDE.Core.RuleTypes

60import Development.IDE.Core.RuleTypes

63import Development.IDE.Spans.Type

61import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

65import qualified GHC.LanguageExtensions as LangExt

64import qualified GHC.LanguageExtensions as LangExt

66import HscTypes

65import HscTypes

66+import PackageConfig

67import DynFlags (gopt_set, xopt)

68import GHC.Generics(Generic)

70import qualified Development.IDE.Spans.AtPoint as AtPoint

71import Development.IDE.Core.Service

72import Development.IDE.Core.Shake

73−import Development.Shake.Classes

73+import Development.Shake.Classes hiding (get, put)

74import Control.Monad.Trans.Except (runExceptT)

75import Data.ByteString (ByteString)

76import Control.Concurrent.Async (concurrently)

78+import Control.Monad.State

79+

78-- | This is useful for rules to convert rules that can only produce errors or

80-- | This is useful for rules to convert rules that can only produce errors or

79-- a result into the more general IdeResult type that supports producing

81-- a result into the more general IdeResult type that supports producing

80-- warnings while also producing a result.

82-- warnings while also producing a result.

@@ -141,7 +143,6 @@ getHomeHieFile f = do

141 hie_f = ml_hie_file $ ms_location ms

143 hie_f = ml_hie_file $ ms_location ms

142 mbHieTimestamp <- use GetModificationTime normal_hie_f

144 mbHieTimestamp <- use GetModificationTime normal_hie_f

143 srcTimestamp <- use_ GetModificationTime f

145 srcTimestamp <- use_ GetModificationTime f

144−

145 let isUpToDate

146 let isUpToDate

146 | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT

147 | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT

147 | otherwise = False

148 | otherwise = False

@@ -191,12 +192,16 @@ priorityFilesOfInterest = Priority (-2)

191

192

192getParsedModuleRule :: Rules ()

193getParsedModuleRule :: Rules ()

193getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

194getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

194− hsc <- hscEnv <$> use_ GhcSession file

195+ sess <- use_ GhcSession file

196+ let hsc = hscEnv sess

197+ -- These packages are used when removing PackageImports from a

198+ -- parsed module

199+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

195 opt <- getIdeOptions

200 opt <- getIdeOptions

196 (_, contents) <- getFileContents file

201 (_, contents) <- getFileContents file

197

202

198 let dflags = hsc_dflags hsc

203 let dflags = hsc_dflags hsc

199− mainParse = getParsedModuleDefinition hsc opt file contents

204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

200

205

201 -- Parse again (if necessary) to capture Haddock parse errors

206 -- Parse again (if necessary) to capture Haddock parse errors

202 if gopt Opt_Haddock dflags

207 if gopt Opt_Haddock dflags

@@ -206,7 +211,7 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

206 let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}

211 let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}

207 haddockParse = do

212 haddockParse = do

208 (_, (!diagsHaddock, _)) <-

213 (_, (!diagsHaddock, _)) <-

209− getParsedModuleDefinition hscHaddock opt file contents

214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

210 return diagsHaddock

215 return diagsHaddock

211

216

212 ((fingerPrint, (diags, res)), diagsHaddock) <-

217 ((fingerPrint, (diags, res)), diagsHaddock) <-

@@ -217,9 +222,9 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

217

222

218 return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))

223 return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))

219

224

220−getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))

225+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))

221−getParsedModuleDefinition packageState opt file contents = do

226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do

222− (diag, res) <- parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

223 case res of

228 case res of

224 Nothing -> pure (Nothing, (diag, Nothing))

229 Nothing -> pure (Nothing, (diag, Nothing))

225 Just (contents, modu) -> do

230 Just (contents, modu) -> do

@@ -233,11 +238,13 @@ getLocatedImportsRule =

233 define $ \GetLocatedImports file -> do

238 define $ \GetLocatedImports file -> do

234 ms <- use_ GetModSummary file

239 ms <- use_ GetModSummary file

235 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

236− env <- hscEnv <$> use_ GhcSession file

241+ env_eq <- use_ GhcSession file

242+ let env = hscEnv env_eq

243+ let import_dirs = deps env_eq

237 let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env

244 let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env

238 opt <- getIdeOptions

245 opt <- getIdeOptions

239 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

240− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource

241 case diagOrImp of

248 case diagOrImp of

242 Left diags -> pure (diags, Left (modName, Nothing))

249 Left diags -> pure (diags, Left (modName, Nothing))

243 Right (FileImport path) -> pure ([], Left (modName, Just path))

250 Right (FileImport path) -> pure ([], Left (modName, Just path))

@@ -251,53 +258,91 @@ getLocatedImportsRule =

251 Nothing -> pure (concat diags, Nothing)

258 Nothing -> pure (concat diags, Nothing)

252 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

253

260

261+type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a

262+

263+execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)

264+execRawDepM act =

265+ execStateT act

266+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty

267+ , IntMap.empty

268+ )

269+

254-- | Given a target file path, construct the raw dependency results by following

270-- | Given a target file path, construct the raw dependency results by following

255-- imports recursively.

271-- imports recursively.

256−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation

257−rawDependencyInformation f = do

273+rawDependencyInformation fs = do

258− let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False

274+ (rdi, ss) <- execRawDepM (mapM_ go fs)

259− (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap

260− (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)

261− (RawDependencyInformation IntMap.empty initialMap IntMap.empty, IntMap.empty)

262 let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss

275 let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss

263 return (rdi { rawBootMap = bm })

276 return (rdi { rawBootMap = bm })

264 where

277 where

265− go fs (rawDepInfo, ss) =

278+ go :: NormalizedFilePath -- ^ Current module being processed

266− case IntSet.minView fs of

279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId

267− -- Queue is empty

280+ go f = do

268− Nothing -> pure (rawDepInfo, ss)

281+ -- First check to see if we have already processed the FilePath

269− -- Pop f from the queue and process it

282+ -- If we have, just return its Id but don't update any of the state.

270− Just (f, fs) -> do

283+ -- Otherwise, we need to process its imports.

271− let fId = FilePathId f

284+ checkAlreadyProcessed f $ do

285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f

286+ -- Get a fresh FilePathId for the new file

287+ fId <- getFreshFid al

288+ -- Adding an edge to the bootmap so we can make sure to

289+ -- insert boot nodes before the real files.

290+ addBootMap al fId

291+ -- Try to parse the imports of the file

272− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId

292+ importsOrErr <- lift $ use GetLocatedImports f

273− case importsOrErr of

293+ case importsOrErr of

274− Nothing ->

294+ Nothing -> do

275− -- File doesn’t parse

295+ -- File doesn't parse so add the module as a failure into the

296+ -- dependency information, continue processing the other

297+ -- elements in the queue

276− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

277− in go fs (rawDepInfo', ss)

299+ return fId

278− Just (modImports, pkgImports) -> do

300+ Just (modImports, pkgImports) -> do

279− let f :: (PathIdMap, IntMap ArtifactsLocation)

301+ -- Get NFPs of the imports which have corresponding files

280− -> (a, Maybe ArtifactsLocation)

302+ -- Imports either come locally from a file or from a package.

281− -> ((PathIdMap, IntMap ArtifactsLocation), (a, Maybe FilePathId))

303+ let (no_file, with_file) = splitImports modImports

282− f (pathMap, ss) (imp, mbPath) = case mbPath of

304+ (mns, ls) = unzip with_file

283− Nothing -> ((pathMap, ss), (imp, Nothing))

305+ -- Recursively process all the imports we just learnt about

284− Just path ->

306+ -- and get back a list of their FilePathIds

285− let (pathId, pathMap') = getPathId path pathMap

307+ fids <- mapM (go . artifactFilePath) ls

308+ -- Associate together the ModuleName with the FilePathId

309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)

310+ -- Insert into the map the information about this modules

311+ -- imports.

312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)

313+ return fId

314+

315+

316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId

317+ checkAlreadyProcessed nfp k = do

318+ (rawDepInfo, _) <- get

319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)

320+

321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()

322+ modifyRawDepInfo f = modify (first f)

323+

324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()

325+ addBootMap al fId =

286− ss' = if isBootLocation path

326+ modify (\(rd, ss) -> (rd, if isBootLocation al

287− then IntMap.insert (getFilePathId pathId) path ss

327+ then IntMap.insert (getFilePathId fId) al ss

288− else ss

328+ else ss))

289− in ((pathMap', ss'), (imp, Just pathId))

329+

290− -- Convert paths in imports to ids and update the path map

330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331+ getFreshFid al = do

332+ (rawDepInfo, ss) <- get

291− let ((pathIdMap, ss'), modImports') = mapAccumL f (rawPathIdMap rawDepInfo, ss) modImports

333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)

292− -- Files that we haven’t seen before are added to the queue.

334+ -- Insert the File into the bootmap if it's a boot module

293− let newFiles =

335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }

294− IntSet.fromList (coerce $ mapMaybe snd modImports')

336+ put (rawDepInfo', ss)

295− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)

337+ return fId

296− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo

338+

297− go (newFiles `IntSet.union` fs)

339+ -- Split in (package imports, local imports)

298− (rawDepInfo' { rawPathIdMap = pathIdMap }, ss')

340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]

299−

341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])

300−

342+ splitImports = foldr splitImportsLoop ([],[])

343+

344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)

345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)

301

346

302 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

347 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

303 if not artifactIsSource

348 if not artifactIsSource

@@ -315,7 +360,7 @@ rawDependencyInformation f = do

315getDependencyInformationRule :: Rules ()

360getDependencyInformationRule :: Rules ()

316getDependencyInformationRule =

361getDependencyInformationRule =

317 define $ \GetDependencyInformation file -> do

362 define $ \GetDependencyInformation file -> do

318− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

319 pure ([], Just $ processDependencyInformation rawDepInfo)

364 pure ([], Just $ processDependencyInformation rawDepInfo)

320

365

321reportImportCyclesRule :: Rules ()

366reportImportCyclesRule :: Rules ()

@@ -426,7 +471,7 @@ typeCheckRuleDefinition file pm generateArtifacts = do

426 setPriority priorityTypeCheck

471 setPriority priorityTypeCheck

427 IdeOptions { optDefer = defer } <- getIdeOptions

472 IdeOptions { optDefer = defer } <- getIdeOptions

428

473

429− liftIO $ do

474+ addUsageDependencies $ liftIO $ do

430 res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm

475 res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm

431 case res of

476 case res of

432 (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do

477 (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do

@@ -440,6 +485,18 @@ typeCheckRuleDefinition file pm generateArtifacts = do

440 uses_th_qq dflags =

485 uses_th_qq dflags =

441 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

486 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

442

487

488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)

489+ addUsageDependencies a = do

490+ r@(_, mtc) <- a

491+ forM_ mtc $ \tc -> do

492+ let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))

493+ udep (UsageFile fp _h) = Just fp

494+ udep _ = Nothing

495+ -- Add a dependency on these files which are added by things like

496+ -- qAddDependentFile

497+ void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)

498+ return r

499+

443

500

444generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

501generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

445generateCore runSimplifier file = do

502generateCore runSimplifier file = do

@@ -472,7 +529,7 @@ instance Hashable GhcSessionIO

472instance NFData GhcSessionIO

529instance NFData GhcSessionIO

473instance Binary GhcSessionIO

530instance Binary GhcSessionIO

474

531

475−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))

476instance Show GhcSessionFun where show _ = "GhcSessionFun"

533instance Show GhcSessionFun where show _ = "GhcSessionFun"

477instance NFData GhcSessionFun where rnf !_ = ()

534instance NFData GhcSessionFun where rnf !_ = ()

478

535

@@ -482,11 +539,26 @@ loadGhcSession = do

482 defineNoFile $ \GhcSessionIO -> do

539 defineNoFile $ \GhcSessionIO -> do

483 opts <- getIdeOptions

540 opts <- getIdeOptions

484 GhcSessionFun <$> optGhcSession opts

541 GhcSessionFun <$> optGhcSession opts

542+ -- This function should always be rerun because it consults a cache to

543+ -- see what HscEnv needs to be used for the file, which can change.

544+ -- However, it should also cut-off early if it's the same HscEnv as

545+ -- last time

485 defineEarlyCutoff $ \GhcSession file -> do

546 defineEarlyCutoff $ \GhcSession file -> do

486 GhcSessionFun fun <- useNoFile_ GhcSessionIO

547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

487 val <- fun $ fromNormalizedFilePath file

549 val <- fun $ fromNormalizedFilePath file

550+

551+ -- TODO: What was this doing before?

488 opts <- getIdeOptions

552 opts <- getIdeOptions

489− return ("" <$ optShakeFiles opts, ([], Just val))

553+ let cutoffHash =

554+ case optShakeFiles opts of

555+ -- optShakeFiles is only set in the DAML case.

556+ -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915

557+ Just {} -> ""

558+ -- Hash the HscEnvEq returned so cutoff if it didn't change

559+ -- from last time

560+ Nothing -> BS.pack (show (hash (snd val)))

561+ return (Just cutoffHash, val)

490

562

491getHiFileRule :: Rules ()

563getHiFileRule :: Rules ()

492getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

564getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

@@ -500,36 +572,19 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

500 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

572 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

501 _ -> ml_hi_file $ ms_location ms

573 _ -> ml_hi_file $ ms_location ms

502

574

503− IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions

504−

505− let mkInterfaceFilesGenerationDiag f intro

506− | optInterfaceLoadingDiagnostics = mkDiag $ intro <> msg

507− | otherwise = []

508− where

509− msg =

510− ": additional resource use while generating interface files in the background."

511− mkDiag = pure

512− . ideErrorWithSource (Just "interface file loading") (Just DsInfo) f

513− . T.pack

514−

515 case sequence depHis of

575 case sequence depHis of

516− Nothing -> do

517− let d = mkInterfaceFilesGenerationDiag f "Missing interface file dependencies"

518− pure (Nothing, (d, Nothing))

576+ Nothing -> pure (Nothing, ([], Nothing))

519 Just deps -> do

577 Just deps -> do

520 gotHiFile <- getFileExists hiFile

578 gotHiFile <- getFileExists hiFile

521 if not gotHiFile

579 if not gotHiFile

522− then do

523− let d = mkInterfaceFilesGenerationDiag f "Missing interface file"

524− pure (Nothing, (d, Nothing))

580+ then pure (Nothing, ([], Nothing))

525 else do

581 else do

526 hiVersion <- use_ GetModificationTime hiFile

582 hiVersion <- use_ GetModificationTime hiFile

527 modVersion <- use_ GetModificationTime f

583 modVersion <- use_ GetModificationTime f

528 let sourceModified = modificationTime hiVersion < modificationTime modVersion

584 let sourceModified = modificationTime hiVersion < modificationTime modVersion

529 if sourceModified

585 if sourceModified

530 then do

586 then do

531− let d = mkInterfaceFilesGenerationDiag f "Stale interface file"

532− pure (Nothing, (d, Nothing))

587+ pure (Nothing, ([], Nothing))

533 else do

588 else do

534 session <- hscEnv <$> use_ GhcSession f

589 session <- hscEnv <$> use_ GhcSession f

535 r <- liftIO $ loadInterface session ms deps

590 r <- liftIO $ loadInterface session ms deps

@@ -568,12 +623,16 @@ getModIfaceRule = define $ \GetModIface f -> do

568 -- the interface file does not exist or is out of date.

623 -- the interface file does not exist or is out of date.

569 -- Invoke typechecking directly to update it without incurring a dependency

624 -- Invoke typechecking directly to update it without incurring a dependency

570 -- on the parsed module and the typecheck rules

625 -- on the parsed module and the typecheck rules

571− hsc <- hscEnv <$> use_ GhcSession f

626+ sess <- use_ GhcSession f

627+ let hsc = hscEnv sess

628+ -- After parsing the module remove all package imports referring to

629+ -- these packages as we have already dealt with what they map to.

630+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

572 opt <- getIdeOptions

631 opt <- getIdeOptions

573 (_, contents) <- getFileContents f

632 (_, contents) <- getFileContents f

574 -- Embed --haddocks in the interface file

633 -- Embed --haddocks in the interface file

575 hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

634 hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

576− (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f contents

635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents

577 case mb_pm of

636 case mb_pm of

578 Nothing -> return (diags, Nothing)

637 Nothing -> return (diags, Nothing)

579 Just pm -> do

638 Just pm -> do

src/Development/IDE/Core/Shake.hs+38−27

@@ -53,7 +53,7 @@ import qualified Data.ByteString.Char8 as BS

53import Data.Dynamic

54import Data.Maybe

55import Data.Map.Strict (Map)

56−import Data.List.Extra (foldl', partition, takeEnd)

56+import Data.List.Extra (partition, takeEnd)

57import qualified Data.Set as Set

58import qualified Data.Text as T

59import Data.Traversable (for)

@@ -69,7 +69,7 @@ import Development.IDE.Types.Location

69import Development.IDE.Types.Options

70import Control.Concurrent.Async

71import Control.Concurrent.Extra

72−import Control.Exception

72+import Control.Exception.Extra

73import Control.DeepSeq

74import System.Time.Extra

75import Data.Typeable

@@ -97,9 +97,11 @@ data ShakeExtras = ShakeExtras

97 ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

98 -- ^ This represents the set of diagnostics that we have published.

99 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

101 -- ^ Map from a text document version to a PositionMapping that describes how to map

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

103+ -- First mapping is delta from previous version and second one is an

104+ -- accumlation of all previous mappings.

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

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

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

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

105 }

107 }

@@ -124,14 +126,19 @@ addIdeGlobal x = do

124addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

126addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

125addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

127addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

126 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

127− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

128 Nothing -> return $! HMap.insert ty (toDyn x) mp

130 Nothing -> return $! HMap.insert ty (toDyn x) mp

129

131

130

132

131getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

132getIdeGlobalExtras ShakeExtras{globals} = do

134getIdeGlobalExtras ShakeExtras{globals} = do

135+ let typ = typeRep (Proxy :: Proxy a)

133− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

134− return $ fromDyn x $ error "Serious error, corrupt globals"

137+ case x of

138+ Just x

139+ | Just x <- fromDynamic x -> pure x

140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

135

142

136getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

137getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -154,7 +161,7 @@ instance Eq Key where

154 | otherwise = False

161 | otherwise = False

155

162

156instance Hashable Key where

163instance Hashable Key where

157− hashWithSalt salt (Key key) = hashWithSalt salt key

164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

158

165

159-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

160-- and a value is in the Maybe. For operations that throw an error you

167-- and a value is in the Maybe. For operations that throw an error you

@@ -164,9 +171,6 @@ instance Hashable Key where

164-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

165-- errors but still failed.

172-- errors but still failed.

166--

173--

167−-- A rule on a file should only return diagnostics for that given file. It should

168−-- not propagate diagnostic errors through multiple phases.

169−type IdeResult v = ([FileDiagnostic], Maybe v)

170

174

171data Value v

175data Value v

172 = Succeeded TextDocumentVersion v

176 = Succeeded TextDocumentVersion v

@@ -201,12 +205,12 @@ valueVersion = \case

201 Failed -> Nothing

205 Failed -> Nothing

202

206

203mappingForVersion

207mappingForVersion

204− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping)

208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

205 -> NormalizedFilePath

209 -> NormalizedFilePath

206 -> TextDocumentVersion

210 -> TextDocumentVersion

207 -> PositionMapping

211 -> PositionMapping

208mappingForVersion allMappings file ver =

212mappingForVersion allMappings file ver =

209− fromMaybe idMapping $

213+ maybe zeroMapping snd $

210 Map.lookup ver =<<

214 Map.lookup ver =<<

211 HMap.lookup (filePathToUri' file) allMappings

215 HMap.lookup (filePathToUri' file) allMappings

212

216

@@ -509,12 +513,10 @@ instance Show k => Show (Q k) where

509

513

510-- | Invariant: the 'v' must be in normal form (fully evaluated).

514-- | Invariant: the 'v' must be in normal form (fully evaluated).

511-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

512−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

513−-- can just remove it?

514−data A v = A (Value v) ShakeValue

516+newtype A v = A (Value v)

515 deriving Show

517 deriving Show

516

518

517−instance NFData (A v) where rnf (A v x) = v `seq` rnf x

519+instance NFData (A v) where rnf (A v) = v `seq` ()

518

520

519-- In the Shake database we only store one type of key/result pairs,

521-- In the Shake database we only store one type of key/result pairs,

520-- namely Q (question) / A (answer).

522-- namely Q (question) / A (answer).

@@ -524,19 +526,22 @@ type instance RuleResult (Q k) = A (RuleResult k)

524-- | Return up2date results. Stale results will be ignored.

526-- | Return up2date results. Stale results will be ignored.

525uses :: IdeRule k v

527uses :: IdeRule k v

526 => k -> [NormalizedFilePath] -> Action [Maybe v]

528 => k -> [NormalizedFilePath] -> Action [Maybe v]

527−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

528

530

529-- | Return the last computed result which might be stale.

531-- | Return the last computed result which might be stale.

530usesWithStale :: IdeRule k v

532usesWithStale :: IdeRule k v

531 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

532usesWithStale key files = do

534usesWithStale key files = do

533− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

534 zipWithM lastValue files values

536 zipWithM lastValue files values

535

537

536

538

537withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

539withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

538withProgress var file = actionBracket (f succ) (const $ f pred) . const

540withProgress var file = actionBracket (f succ) (const $ f pred) . const

541+ -- This functions are deliberately eta-expanded to avoid space leaks.

542+ -- Do not remove the eta-expansion without profiling a session with at

543+ -- least 1000 modifications.

539− where f shift = modifyVar_ var $ return . HMap.alter (Just . shift . fromMaybe 0) file

544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x

540

545

541

546

542defineEarlyCutoff

547defineEarlyCutoff

@@ -553,7 +558,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

553 case v of

558 case v of

554 -- No changes in the dependencies and we have

559 -- No changes in the dependencies and we have

555 -- an existing result.

560 -- an existing result.

556− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v

557 _ -> return Nothing

562 _ -> return Nothing

558 _ -> return Nothing

563 _ -> return Nothing

559 case val of

564 case val of

@@ -584,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

584 return $ RunResult

589 return $ RunResult

585 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

586 (encodeShakeValue bs) $

591 (encodeShakeValue bs) $

587− A res bs

592+ A res

588

593

589

594

590-- | Rule type, input file

595-- | Rule type, input file

@@ -738,7 +743,7 @@ publishDiagnosticsNotification uri diags =

738newtype Priority = Priority Double

743newtype Priority = Priority Double

739

744

740setPriority :: Priority -> Action ()

745setPriority :: Priority -> Action ()

741−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

742

747

743sendEvent :: LSP.FromServerMessage -> Action ()

748sendEvent :: LSP.FromServerMessage -> Action ()

744sendEvent e = do

749sendEvent e = do

@@ -764,7 +769,7 @@ instance Binary GetModificationTime

764type instance RuleResult GetModificationTime = FileVersion

769type instance RuleResult GetModificationTime = FileVersion

765

770

766data FileVersion

771data FileVersion

767− = VFSVersion Int

772+ = VFSVersion !Int

768 | ModificationTime

773 | ModificationTime

769 !Int -- ^ Large unit (platform dependent, do not make assumptions)

774 !Int -- ^ Large unit (platform dependent, do not make assumptions)

770 !Int -- ^ Small unit (platform dependent, do not make assumptions)

775 !Int -- ^ Small unit (platform dependent, do not make assumptions)

@@ -828,11 +833,17 @@ filterVersionMap =

828 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

833 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

829

834

830updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

831−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

832 modifyVar_ positionMapping $ \allMappings -> do

837 modifyVar_ positionMapping $ \allMappings -> do

833 let uri = toNormalizedUri _uri

838 let uri = toNormalizedUri _uri

834 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

839 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

835− let updatedMapping =

840+ let (_, updatedMapping) =

841+ -- Very important to use mapAccum here so that the tails of

842+ -- each mapping can be shared, otherwise quadratic space is

843+ -- used which is evident in long running sessions.

844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845+ zeroMapping

836− Map.insert _version idMapping $

846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)

837− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

838 pure $! HMap.insert uri updatedMapping allMappings

847 pure $! HMap.insert uri updatedMapping allMappings

848+ where

849+ shared_change = mkDelta changes

src/Development/IDE/GHC/Compat.hs+19−1

@@ -26,6 +26,7 @@ module Development.IDE.GHC.Compat(

26 includePathsQuote,

27 addIncludePathsQuote,

28 getModuleHash,

29+ getPackageName,

29 pattern DerivD,

30 pattern DerivD,

30 pattern ForD,

31 pattern ForD,

31 pattern InstD,

32 pattern InstD,

@@ -37,6 +38,7 @@ module Development.IDE.GHC.Compat(

37 GHC.ModLocation,

38 GHC.ModLocation,

38 Module.addBootSuffix,

39 Module.addBootSuffix,

39 pattern ModLocation,

40 pattern ModLocation,

41+ getConArgs,

41 module GHC

43 module GHC

42 ) where

44 ) where

@@ -46,9 +48,15 @@ import DynFlags

46import FieldLabel

48import FieldLabel

47import Fingerprint (Fingerprint)

49import Fingerprint (Fingerprint)

48import qualified Module

50import qualified Module

51+import Packages

50import qualified GHC

53import qualified GHC

54+import GHC hiding (

51−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)

55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation

56+#if MIN_GHC_API_VERSION(8,6,0)

57+ , getConArgs

58+#endif

59+ )

52import qualified HeaderInfo as Hdr

60import qualified HeaderInfo as Hdr

53import Avail

61import Avail

54import ErrUtils (ErrorMessages)

62import ErrUtils (ErrorMessages)

@@ -289,3 +297,13 @@ getModuleHash = mi_mod_hash . mi_final_exts

289#else

297#else

290getModuleHash = mi_mod_hash

298getModuleHash = mi_mod_hash

291#endif

299#endif

300+

301+getConArgs :: ConDecl pass -> HsConDeclDetails pass

302+#if MIN_GHC_API_VERSION(8,6,0)

303+getConArgs = GHC.getConArgs

304+#else

305+getConArgs = GHC.getConDetails

306+#endif

307+

308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+2−1

@@ -56,7 +56,8 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename

56-- | Produce a GHC-style error from a source span and a message.

57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

58diagFromErrMsg diagSource dflags e =

59− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

60 | Just sev <- [toDSeverity $ errMsgSeverity e]]

61 | Just sev <- [toDSeverity $ errMsgSeverity e]]

src/Development/IDE/GHC/Util.hs+16−8

@@ -8,6 +8,7 @@ module Development.IDE.GHC.Util(

8 modifyDynFlags,

9 evalGhcEnv,

10 runGhcEnv,

11+ deps,

11 -- * GHC wrappers

12 -- * GHC wrappers

12 prettyPrint,

13 prettyPrint,

13 printRdrName,

14 printRdrName,

@@ -64,7 +65,7 @@ import Packages (getPackageConfigMap, lookupPackage')

64import SrcLoc (mkRealSrcLoc)

65import SrcLoc (mkRealSrcLoc)

65import FastString (mkFastString)

66import FastString (mkFastString)

66import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

67import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

67−import Module (moduleNameSlashes)

68+import Module (moduleNameSlashes, InstalledUnitId)

68import OccName (parenSymOcc)

69import OccName (parenSymOcc)

69import RdrName (nameRdrName, rdrNameOcc)

70import RdrName (nameRdrName, rdrNameOcc)

@@ -166,6 +167,9 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

166-- if they are created with the same call to 'newHscEnvEq'.

167-- if they are created with the same call to 'newHscEnvEq'.

167data HscEnvEq

168data HscEnvEq

168 = HscEnvEq !Unique !HscEnv

169 = HscEnvEq !Unique !HscEnv

170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv

171+ -- This is only used at the moment for the import dirs in

172+ -- the DynFlags

169 | GhcVersionMismatch { compileTime :: !Version

173 | GhcVersionMismatch { compileTime :: !Version

170 , runTime :: !Version

174 , runTime :: !Version

171 }

175 }

@@ -175,7 +179,7 @@ hscEnv :: HscEnvEq -> HscEnv

175hscEnv = either error id . hscEnv'

179hscEnv = either error id . hscEnv'

176

180

177hscEnv' :: HscEnvEq -> Either String HscEnv

181hscEnv' :: HscEnvEq -> Either String HscEnv

178−hscEnv' (HscEnvEq _ x) = Right x

182+hscEnv' (HscEnvEq _ x _) = Right x

179hscEnv' GhcVersionMismatch{..} = Left $

183hscEnv' GhcVersionMismatch{..} = Left $

180 unwords

184 unwords

181 ["ghcide compiled against GHC"

185 ["ghcide compiled against GHC"

@@ -185,25 +189,29 @@ hscEnv' GhcVersionMismatch{..} = Left $

185 ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

189 ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

186 ]

190 ]

187

191

192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193+deps (HscEnvEq _ _ u) = u

194+deps GhcVersionMismatch{} = []

195+

188-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

189−newHscEnvEq :: HscEnv -> IO HscEnvEq

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

190−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

191

199

192instance Show HscEnvEq where

200instance Show HscEnvEq where

193− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

194 show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

202 show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

195

203

196instance Eq HscEnvEq where

204instance Eq HscEnvEq where

197− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

198 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

206 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

199 _ == _ = False

207 _ == _ = False

200

208

201instance NFData HscEnvEq where

209instance NFData HscEnvEq where

202− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

203 rnf GhcVersionMismatch{} = rnf runTime

211 rnf GhcVersionMismatch{} = rnf runTime

204

212

205instance Hashable HscEnvEq where

213instance Hashable HscEnvEq where

206− hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

207 hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

215 hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

208

216

209-- Fake instance needed to persuade Shake to accept this type as a key.

217-- Fake instance needed to persuade Shake to accept this type as a key.

src/Development/IDE/Import/DependencyInformation.hs+2−2

@@ -62,7 +62,7 @@ data ModuleImports = ModuleImports

62 -- that module on disk (if we found it)

63 , packageImports :: !(Set InstalledUnitId)

64 -- ^ Transitive package dependencies unioned for all imports.

65− }

65+ } deriving Show

67-- | For processing dependency information, we need lots of maps and sets of

68-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

@@ -128,7 +128,7 @@ data RawDependencyInformation = RawDependencyInformation

128 -- need to add edges between .hs-boot and .hs so that the .hs files

129 -- appear later in the sort.

130 , rawBootMap :: !BootIdMap

131− }

131+ } deriving Show

132

133pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

134pkgDependencies RawDependencyInformation{..} =

src/Development/IDE/Import/FindImports.hs+40−14

@@ -8,17 +8,18 @@ module Development.IDE.Import.FindImports

8 ( locateModule

9 , Import(..)

10 , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

11 , isBootLocation

12 , isBootLocation

13+ , mkImportDirs

12 ) where

14 ) where

14import Development.IDE.GHC.Error as ErrUtils

16import Development.IDE.GHC.Error as ErrUtils

15import Development.IDE.GHC.Orphans()

17import Development.IDE.GHC.Orphans()

16import Development.IDE.Types.Diagnostics

18import Development.IDE.Types.Diagnostics

17import Development.IDE.Types.Location

19import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

18-- GHC imports

21-- GHC imports

19−import DynFlags

20import FastString

22import FastString

21−import GHC

22import qualified Module as M

23import qualified Module as M

23import Packages

24import Packages

24import Outputable (showSDoc, ppr, pprPanic)

25import Outputable (showSDoc, ppr, pprPanic)

@@ -29,6 +30,8 @@ import Control.DeepSeq

29import Control.Monad.Extra

30import Control.Monad.Extra

30import Control.Monad.IO.Class

31import Control.Monad.IO.Class

31import System.FilePath

32import System.FilePath

33+import DriverPhases

34+import Data.Maybe

33data Import

36data Import

34 = FileImport !ArtifactsLocation

37 = FileImport !ArtifactsLocation

@@ -52,58 +55,81 @@ instance NFData Import where

52 rnf (FileImport x) = rnf x

55 rnf (FileImport x) = rnf x

53 rnf (PackageImport x) = rnf x

56 rnf (PackageImport x) = rnf x

58+modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation

59+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))

60+ where

61+ isSource HsSrcFile = True

62+ isSource _ = False

63+

56-- | locate a module in the file system. Where we go from *daml to Haskell

65-- | locate a module in the file system. Where we go from *daml to Haskell

57locateModuleFile :: MonadIO m

66locateModuleFile :: MonadIO m

58− => DynFlags

67+ => [[FilePath]]

59 -> [String]

68 -> [String]

60 -> (NormalizedFilePath -> m Bool)

69 -> (NormalizedFilePath -> m Bool)

61 -> Bool

70 -> Bool

62 -> ModuleName

71 -> ModuleName

63 -> m (Maybe NormalizedFilePath)

72 -> m (Maybe NormalizedFilePath)

64−locateModuleFile dflags exts doesExist isSource modName = do

73+locateModuleFile import_dirss exts doesExist isSource modName = do

65− let candidates =

74+ let candidates import_dirs =

66 [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

75 [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

67− | prefix <- importPaths dflags, ext <- exts]

76+ | prefix <- import_dirs , ext <- exts]

68− findM doesExist candidates

77+ findM doesExist (concatMap candidates import_dirss)

69 where

78 where

70 maybeBoot ext

79 maybeBoot ext

71 | isSource = ext ++ "-boot"

80 | isSource = ext ++ "-boot"

72 | otherwise = ext

81 | otherwise = ext

83+-- | This function is used to map a package name to a set of import paths.

84+-- It only returns Just for unit-ids which are possible to import into the

85+-- current module. In particular, it will return Nothing for 'main' components

86+-- as they can never be imported into another package.

87+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])

88+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i

89+

74-- | locate a module in either the file system or the package database. Where we go from *daml to

90-- | locate a module in either the file system or the package database. Where we go from *daml to

75-- Haskell

91-- Haskell

76locateModule

92locateModule

77 :: MonadIO m

93 :: MonadIO m

78 => DynFlags

94 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

79 -> [String]

96 -> [String]

80 -> (NormalizedFilePath -> m Bool)

97 -> (NormalizedFilePath -> m Bool)

81 -> Located ModuleName

98 -> Located ModuleName

82 -> Maybe FastString

99 -> Maybe FastString

83 -> Bool

100 -> Bool

84 -> m (Either [FileDiagnostic] Import)

101 -> m (Either [FileDiagnostic] Import)

85−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

86 case mbPkgName of

103 case mbPkgName of

87 -- "this" means that we should only look in the current package

104 -- "this" means that we should only look in the current package

88 Just "this" -> do

105 Just "this" -> do

89− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

106+ lookupLocal [importPaths dflags]

90− case mbFile of

91− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

92− Just file -> toModLocation file

93 -- if a package name is given we only go look for a package

107 -- if a package name is given we only go look for a package

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

94− Just _pkgName -> lookupInPackageDB dflags

111+ | otherwise -> lookupInPackageDB dflags

95 Nothing -> do

112 Nothing -> do

96 -- first try to find the module as a file. If we can't find it try to find it in the package

113 -- first try to find the module as a file. If we can't find it try to find it in the package

97 -- database.

114 -- database.

115+ -- Here the importPaths for the current modules are added to the front of the import paths from the other components.

116+ -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in

117+ -- each component will end up being found in the wrong place and cause a multi-cradle match failure.

98− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

99 case mbFile of

119 case mbFile of

100 Nothing -> lookupInPackageDB dflags

120 Nothing -> lookupInPackageDB dflags

101 Just file -> toModLocation file

121 Just file -> toModLocation file

102 where

122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

103 toModLocation file = liftIO $ do

124 toModLocation file = liftIO $ do

104 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

105 return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

126 return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

106

127

128+ lookupLocal dirs = do

129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

130+ case mbFile of

131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

132+ Just file -> toModLocation file

107

133

108 lookupInPackageDB dfs =

134 lookupInPackageDB dfs =

109 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

src/Development/IDE/LSP/LanguageServer.hs+8−8

@@ -144,14 +144,14 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

144 Response x@RequestMessage{_id, _params} wrap act ->

145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146 \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151 \(res, newReq) -> do

152 case res of

153− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

154− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155 whenJust newReq $ \(rm, newReqParams) -> do

156 reqId <- getNextReqId

157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175 Left () -> do

176 logDebug (ideLogger ide) $ T.pack $

177 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179− Just $ ResponseError RequestCancelled "" Nothing

179+ $ ResponseError RequestCancelled "" Nothing

180 Right res -> k res

181 ) $ \(e :: SomeException) -> do

182 logError (ideLogger ide) $ T.pack $

183 "Unexpected exception on request, please report!\n" ++

184 "Message: " ++ show msg ++ "\n" ++

185 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187− Just $ ResponseError InternalError (T.pack $ show e) Nothing

187+ $ ResponseError InternalError (T.pack $ show e) Nothing

188

189initializeRequestHandler :: PartialHandlers config

190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{

src/Development/IDE/LSP/Outline.hs+12

@@ -108,11 +108,23 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

108 { _name = showRdrName n

109 , _kind = SkConstructor

110 , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

111 }

112 }

112 | L l x <- dd_cons

113 | L l x <- dd_cons

113 , L l' n <- getConNames x

114 , L l' n <- getConNames x

114 ]

115 ]

115 }

116 }

117+ where

118+ -- | Extract the record fields of a constructor

119+ conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List

120+ [ (defDocumentSymbol l :: DocumentSymbol)

121+ { _name = showRdrName n

122+ , _kind = SkField

123+ }

124+ | L _ cdf <- lcdfs

125+ , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf

126+ ]

127+ conArgRecordFields _ = Nothing

116documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

117 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

118 , _kind = SkTypeParameter

130 , _kind = SkTypeParameter

src/Development/IDE/Types/Diagnostics.hs+4

@@ -6,6 +6,7 @@ module Development.IDE.Types.Diagnostics (

6 LSP.Diagnostic(..),

7 ShowDiagnostic(..),

8 FileDiagnostic,

9+ IdeResult,

9 LSP.DiagnosticSeverity(..),

10 LSP.DiagnosticSeverity(..),

10 DiagnosticStore,

11 DiagnosticStore,

11 List(..),

12 List(..),

@@ -31,6 +32,9 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

32import Development.IDE.Types.Location

33import Development.IDE.Types.Location

35+-- A rule on a file should only return diagnostics for that given file. It should

36+-- not propagate diagnostic errors through multiple phases.

37+type IdeResult v = ([FileDiagnostic], Maybe v)

35ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

36ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

40ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

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

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

12 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15+ , IdeResult

15 ) where

16 ) where

17import Development.Shake

18import Development.Shake

@@ -20,12 +21,13 @@ import GHC hiding (parseModule, typecheckModule)

20import GhcPlugins as GHC hiding (fst3, (<>))

21import GhcPlugins as GHC hiding (fst3, (<>))

21import qualified Language.Haskell.LSP.Types.Capabilities as LSP

22import qualified Language.Haskell.LSP.Types.Capabilities as LSP

22import qualified Data.Text as T

23import qualified Data.Text as T

24+import Development.IDE.Types.Diagnostics

24data IdeOptions = IdeOptions

26data IdeOptions = IdeOptions

25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

27 -- and a list of errors, along with a new parse tree.

29 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: Action (FilePath -> Action HscEnvEq)

30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

30 -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

32 -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

@@ -58,8 +60,6 @@ data IdeOptions = IdeOptions

58 -- features such as diagnostics and go-to-definition, in

60 -- features such as diagnostics and go-to-definition, in

59 -- situations in which they would become unavailable because of

61 -- situations in which they would become unavailable because of

60 -- the presence of type errors, holes or unbound variables.

62 -- the presence of type errors, holes or unbound variables.

61− , optInterfaceLoadingDiagnostics :: Bool

62− -- ^ Generate Info-level diagnostics to report interface loading actions

63 }

65data IdePreprocessedSource = IdePreprocessedSource

@@ -78,7 +78,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

78clientSupportsProgress caps = IdeReportProgress $ Just True ==

79 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

81−defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

82defaultIdeOptions session = IdeOptions

83 {optPreprocessor = IdePreprocessedSource [] []

84 ,optGhcSession = session

@@ -93,7 +93,6 @@ defaultIdeOptions session = IdeOptions

93 ,optKeywords = haskellKeywords

94 ,optDefer = IdeDefer True

95 ,optTesting = False

96− ,optInterfaceLoadingDiagnostics = False

97 }

96 }

stack-ghc-lib.yaml+4−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-16

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.10.3.0

8−- hie-bios-0.4.0

8+- hie-bios-0.5.0

9- ghc-lib-parser-8.8.1

10- ghc-lib-8.8.1

11- fuzzy-0.1.0.0

stack.yaml+4−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.11.0.1

8−- hie-bios-0.4.0

8+- hie-bios-0.5.0

9- fuzzy-0.1.0.0

10- regex-pcre-builtin-0.95.1.1.8.43

11- regex-base-0.94.0.0

stack810.yaml+4−3

@@ -4,10 +4,11 @@ allow-newer: true

4packages:

5- .

6extra-deps:

7−- haskell-lsp-0.21.0.0

7+- haskell-lsp-0.22.0.0

8−- haskell-lsp-types-0.21.0.0

8+- haskell-lsp-types-0.22.0.0

9−- lsp-test-0.10.2.0

9+- lsp-test-0.11.0.1

10- ghc-check-0.3.0.1

11+- hie-bios-0.5.0

12# for ghc-8.10

13# for ghc-8.10

13- Cabal-3.2.0.0

14- Cabal-3.2.0.0

stack84.yaml+4−4

@@ -5,13 +5,13 @@ packages:

5extra-deps:

6- aeson-1.4.6.0

7- base-orphans-0.8.2

8−- haskell-lsp-0.21.0.0

8+- haskell-lsp-0.22.0.0

9−- haskell-lsp-types-0.21.0.0

9+- haskell-lsp-types-0.22.0.0

10−- lsp-test-0.10.2.0

10+- lsp-test-0.11.0.1

11- rope-utf16-splay-0.3.1.0

12- filepattern-0.1.1

13- js-dgtable-0.5.2

14−- hie-bios-0.4.0

14+- hie-bios-0.5.0

15- fuzzy-0.1.0.0

16- shake-0.18.5

17- time-compat-1.9.2.2

stack88.yaml+4−3

@@ -2,9 +2,10 @@ resolver: nightly-2020-02-13

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.11.0.1

8- ghc-check-0.3.0.1

9+- hie-bios-0.5.0

9nix:

10nix:

10 packages: [zlib]

11 packages: [zlib]

test/data/Bar.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Bar (Bar) where

2−

3−data Bar = Bar

test/data/hover/Bar.hsnew file+3

@@ -0,0 +1,3 @@

1+module Bar (Bar(..)) where

3+data Bar = Bar

test/data/Foo.hs → test/data/hover/Foo.hsrenamed

The content is the same.

test/data/GotoHover.hs → test/data/hover/GotoHover.hsrenamed+1−1

@@ -1,10 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

1{- HLINT ignore -}

2{- HLINT ignore -}

2module Testing ( module Testing ) where

3module Testing ( module Testing ) where

3import Data.Text (Text, pack)

4import Data.Text (Text, pack)

4import Foo (Bar, foo)

5import Foo (Bar, foo)

7−

8data TypeConstructor = DataConstructor

9 { fff :: Text

10 , ggg :: Int }

test/data/multi/a/A.hsnew file+3

@@ -0,0 +1,3 @@

1+module A(foo) where

3+foo = ()

test/data/multi/a/a.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: a

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base

8+ exposed-modules: A

9+ hs-source-dirs: .

test/data/multi/b/B.hsnew file+3

@@ -0,0 +1,3 @@

1+module B(module B) where

2+import A

3+qux = foo

test/data/multi/b/b.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: b

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base, a

8+ exposed-modules: B

9+ hs-source-dirs: .

test/data/multi/cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: a b

test/data/multi/hie.yamlnew file+6

@@ -0,0 +1,6 @@

1+cradle:

2+ cabal:

3+ - path: "./a"

4+ component: "lib:a"

5+ - path: "./b"

6+ component: "lib:b"

test/exe/Main.hs+307−182

@@ -10,7 +10,8 @@

10module Main (main) where

12import Control.Applicative.Combinators

13−import Control.Exception (catch)

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

14import Control.Monad

15import Control.Monad

15import Control.Monad.IO.Class (liftIO)

16import Control.Monad.IO.Class (liftIO)

16import Data.Aeson (FromJSON, Value)

17import Data.Aeson (FromJSON, Value)

@@ -27,14 +28,14 @@ import Development.IDE.Test

27import Development.IDE.Test.Runfiles

28import Development.IDE.Test.Runfiles

28import Development.IDE.Types.Location

29import Development.IDE.Types.Location

29import Development.Shake (getDirectoryFilesIO)

30import Development.Shake (getDirectoryFilesIO)

30−import qualified Language.Haskell.LSP.Test as LSPTest

31+import Language.Haskell.LSP.Test

31−import Language.Haskell.LSP.Test hiding (openDoc')

32import Language.Haskell.LSP.Messages

33import Language.Haskell.LSP.Types

34import Language.Haskell.LSP.Types.Capabilities

35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

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

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

36import Network.URI

37import Network.URI

37−import System.Environment.Blank (setEnv)

38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)

38import System.FilePath

39import System.FilePath

39import System.IO.Extra

40import System.IO.Extra

40import System.Directory

41import System.Directory

@@ -48,31 +49,35 @@ import Test.Tasty.QuickCheck

48import Data.Maybe

49import Data.Maybe

50main :: IO ()

51main :: IO ()

52+main = do

53+ -- We mess with env vars so run single-threaded.

54+ setEnv "TASTY_NUM_THREADS" "1" True

51−main = defaultMainWithRerun $ testGroup "HIE"

55+ defaultMainWithRerun $ testGroup "HIE"

52− [ testSession "open close" $ do

56+ [ testSession "open close" $ do

53− doc <- openDoc' "Testing.hs" "haskell" ""

57+ doc <- createDoc "Testing.hs" "haskell" ""

54− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

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

55− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

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

56− closeDoc doc

60+ closeDoc doc

57− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

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

58− , initializeResponseTests

62+ , initializeResponseTests

59− , completionTests

63+ , completionTests

60− , cppTests

64+ , cppTests

61− , diagnosticTests

65+ , diagnosticTests

62− , codeActionTests

66+ , codeActionTests

63− , codeLensesTests

67+ , codeLensesTests

64− , outlineTests

68+ , outlineTests

65− , findDefinitionAndHoverTests

69+ , findDefinitionAndHoverTests

66− , pluginTests

70+ , pluginTests

67− , preprocessorTests

71+ , preprocessorTests

68− , thTests

72+ , thTests

69− , safeTests

73+ , safeTests

70− , unitTests

74+ , unitTests

71− , haddockTests

75+ , haddockTests

72− , positionMappingTests

76+ , positionMappingTests

73− , watchedFilesTests

77+ , watchedFilesTests

74− , cradleTests

78+ , cradleTests

79+ , dependentFileTest

75− ]

80+ ]

77initializeResponseTests :: TestTree

82initializeResponseTests :: TestTree

78initializeResponseTests = withResource acquire release tests where

83initializeResponseTests = withResource acquire release tests where

@@ -133,7 +138,7 @@ initializeResponseTests = withResource acquire release tests where

133

138

134

139

135 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

136− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

137 innerCaps _ = error "this test only expects inner capabilities"

142 innerCaps _ = error "this test only expects inner capabilities"

138

143

139 acquire :: IO InitializeResponse

144 acquire :: IO InitializeResponse

@@ -147,7 +152,7 @@ diagnosticTests :: TestTree

147diagnosticTests = testGroup "diagnostics"

152diagnosticTests = testGroup "diagnostics"

148 [ testSessionWait "fix syntax error" $ do

153 [ testSessionWait "fix syntax error" $ do

149 let content = T.unlines [ "module Testing wher" ]

154 let content = T.unlines [ "module Testing wher" ]

150− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

151 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

152 let change = TextDocumentContentChangeEvent

157 let change = TextDocumentContentChangeEvent

153 { _range = Just (Range (Position 0 15) (Position 0 19))

158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -158,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"

158 expectDiagnostics [("Testing.hs", [])]

163 expectDiagnostics [("Testing.hs", [])]

159 , testSessionWait "introduce syntax error" $ do

164 , testSessionWait "introduce syntax error" $ do

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

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

161− doc <- openDoc' "Testing.hs" "haskell" content

166+ doc <- createDoc "Testing.hs" "haskell" content

162 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

163 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

164 let change = TextDocumentContentChangeEvent

169 let change = TextDocumentContentChangeEvent

@@ -176,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

176 , "bar :: Int -> Int -> Int"

181 , "bar :: Int -> Int -> Int"

177 , "bar a b = cd + b"

182 , "bar a b = cd + b"

178 ]

183 ]

179− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

180 expectDiagnostics

185 expectDiagnostics

181 [ ( "Testing.hs"

186 [ ( "Testing.hs"

182 , [ (DsError, (2, 14), "Variable not in scope: ab")

187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -190,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

190 , "foo :: Int -> String -> Int"

195 , "foo :: Int -> String -> Int"

191 , "foo a b = a + b"

196 , "foo a b = a + b"

192 ]

197 ]

193− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

194 expectDiagnostics

199 expectDiagnostics

195 [ ( "Testing.hs"

200 [ ( "Testing.hs"

196 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -202,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

202 , "foo :: Int -> String"

207 , "foo :: Int -> String"

203 , "foo a = _ a"

208 , "foo a = _ a"

204 ]

209 ]

205− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

206 expectDiagnostics

211 expectDiagnostics

207 [ ( "Testing.hs"

212 [ ( "Testing.hs"

208 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -224,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

224 [ ("A.hs", [(DsError, (2,4), aMessage)])

229 [ ("A.hs", [(DsError, (2,4), aMessage)])

225 , ("B.hs", [(DsError, (3,4), bMessage)])]

230 , ("B.hs", [(DsError, (3,4), bMessage)])]

226 deferralTest title binding msg = testSessionWait title $ do

231 deferralTest title binding msg = testSessionWait title $ do

227− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

228− _ <- openDoc' "B.hs" "haskell" sourceB

233+ _ <- createDoc "B.hs" "haskell" sourceB

229 expectDiagnostics $ expectedDs msg

234 expectDiagnostics $ expectedDs msg

230 in

235 in

231 [ deferralTest "type error" "True" "Couldn't match expected type"

236 [ deferralTest "type error" "True" "Couldn't match expected type"

232 , deferralTest "typed hole" "_" "Found hole"

237 , deferralTest "typed hole" "_" "Found hole"

233 , deferralTest "out of scope var" "unbound" "Variable not in scope"

238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

234− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

235 ]

239 ]

236

240

237 , testSessionWait "remove required module" $ do

241 , testSessionWait "remove required module" $ do

238 let contentA = T.unlines [ "module ModuleA where" ]

242 let contentA = T.unlines [ "module ModuleA where" ]

239− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

240 let contentB = T.unlines

244 let contentB = T.unlines

241 [ "module ModuleB where"

245 [ "module ModuleB where"

242 , "import ModuleA"

246 , "import ModuleA"

243 ]

247 ]

244− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

245 let change = TextDocumentContentChangeEvent

249 let change = TextDocumentContentChangeEvent

246 { _range = Just (Range (Position 0 0) (Position 0 20))

250 { _range = Just (Range (Position 0 0) (Position 0 20))

247 , _rangeLength = Nothing

251 , _rangeLength = Nothing

@@ -254,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"

254 [ "module ModuleB where"

258 [ "module ModuleB where"

255 , "import ModuleA"

259 , "import ModuleA"

256 ]

260 ]

257− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

258 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

259 let contentA = T.unlines [ "module ModuleA where" ]

263 let contentA = T.unlines [ "module ModuleA where" ]

260− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

261 expectDiagnostics [("ModuleB.hs", [])]

265 expectDiagnostics [("ModuleB.hs", [])]

262 , testSessionWait "add missing module (non workspace)" $ do

266 , testSessionWait "add missing module (non workspace)" $ do

263 let contentB = T.unlines

267 let contentB = T.unlines

264 [ "module ModuleB where"

268 [ "module ModuleB where"

265 , "import ModuleA"

269 , "import ModuleA"

266 ]

270 ]

267− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

268 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

269 let contentA = T.unlines [ "module ModuleA where" ]

273 let contentA = T.unlines [ "module ModuleA where" ]

270− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

271 expectDiagnostics [("/tmp/ModuleB.hs", [])]

275 expectDiagnostics [("/tmp/ModuleB.hs", [])]

272 , testSessionWait "cyclic module dependency" $ do

276 , testSessionWait "cyclic module dependency" $ do

273 let contentA = T.unlines

277 let contentA = T.unlines

@@ -278,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

278 [ "module ModuleB where"

282 [ "module ModuleB where"

279 , "import ModuleA"

283 , "import ModuleA"

280 ]

284 ]

281− _ <- openDoc' "ModuleA.hs" "haskell" contentA

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

282− _ <- openDoc' "ModuleB.hs" "haskell" contentB

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

283 expectDiagnostics

287 expectDiagnostics

284 [ ( "ModuleA.hs"

288 [ ( "ModuleA.hs"

285 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -300,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

300 let contentBboot = T.unlines

304 let contentBboot = T.unlines

301 [ "module ModuleB where"

305 [ "module ModuleB where"

302 ]

306 ]

303− _ <- openDoc' "ModuleA.hs" "haskell" contentA

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

304− _ <- openDoc' "ModuleB.hs" "haskell" contentB

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

305− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

306 expectDiagnostics []

310 expectDiagnostics []

307 , testSessionWait "correct reference used with hs-boot" $ do

311 , testSessionWait "correct reference used with hs-boot" $ do

308 let contentB = T.unlines

312 let contentB = T.unlines

@@ -324,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

324 -- resolved to the hs-boot file

328 -- resolved to the hs-boot file

325 , "y = x"

329 , "y = x"

326 ]

330 ]

327− _ <- openDoc' "ModuleB.hs" "haskell" contentB

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

328− _ <- openDoc' "ModuleA.hs" "haskell" contentA

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

329− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

330− _ <- openDoc' "ModuleC.hs" "haskell" contentC

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

331 expectDiagnostics []

335 expectDiagnostics []

332 , testSessionWait "redundant import" $ do

336 , testSessionWait "redundant import" $ do

333 let contentA = T.unlines ["module ModuleA where"]

337 let contentA = T.unlines ["module ModuleA where"]

@@ -336,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

336 , "module ModuleB where"

340 , "module ModuleB where"

337 , "import ModuleA"

341 , "import ModuleA"

338 ]

342 ]

339− _ <- openDoc' "ModuleA.hs" "haskell" contentA

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

340− _ <- openDoc' "ModuleB.hs" "haskell" contentB

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

341 expectDiagnostics

345 expectDiagnostics

342 [ ( "ModuleB.hs"

346 [ ( "ModuleB.hs"

343 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -359,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

359 , "wrong1 = ThisList.map"

363 , "wrong1 = ThisList.map"

360 , "wrong2 = BaseList.x"

364 , "wrong2 = BaseList.x"

361 ]

365 ]

362− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

363− _ <- openDoc' "Main.hs" "haskell" mainContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

364 expectDiagnostics

368 expectDiagnostics

365 [ ( "Main.hs"

369 [ ( "Main.hs"

366 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -375,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

375 , "foo :: Ord a => a -> Int"

379 , "foo :: Ord a => a -> Int"

376 , "foo a = 1"

380 , "foo a = 1"

377 ]

381 ]

378− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

379 expectDiagnostics

383 expectDiagnostics

380 [ ( "Foo.hs"

384 [ ( "Foo.hs"

381 -- The test is to make sure that warnings contain unqualified names

385 -- The test is to make sure that warnings contain unqualified names

@@ -426,13 +430,32 @@ diagnosticTests = testGroup "diagnostics"

426 , "foo :: Int"

430 , "foo :: Int"

427 , "foo = 1 {-|-}"

431 , "foo = 1 {-|-}"

428 ]

432 ]

429− _ <- openDoc' "Foo.hs" "haskell" fooContent

433+ _ <- createDoc "Foo.hs" "haskell" fooContent

430 expectDiagnostics

434 expectDiagnostics

431 [ ( "Foo.hs"

435 [ ( "Foo.hs"

432 , [(DsError, (2, 8), "Parse error on input")

436 , [(DsError, (2, 8), "Parse error on input")

433 ]

437 ]

434 )

438 )

435 ]

439 ]

440+ , testSessionWait "strip file path" $ do

441+ let

442+ name = "Testing"

443+ content = T.unlines

444+ [ "module " <> name <> " where"

445+ , "value :: Maybe ()"

446+ , "value = [()]"

447+ ]

448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content

449+ notification <- skipManyTill anyMessage diagnostic

450+ let

451+ offenders =

452+ Lsp.params .

453+ Lsp.diagnostics .

454+ Lens.folded .

455+ Lsp.message .

456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))

457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg

458+ Lens.mapMOf_ offenders failure notification

436 ]

459 ]

437

460

438codeActionTests :: TestTree

461codeActionTests :: TestTree

@@ -459,29 +482,25 @@ watchedFilesTests :: TestTree

459watchedFilesTests = testGroup "watched files"

482watchedFilesTests = testGroup "watched files"

460 [ testSession' "workspace files" $ \sessionDir -> do

483 [ testSession' "workspace files" $ \sessionDir -> do

461 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

484 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

462− _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

463 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

486 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

464

487

465− -- Expect 6 subscriptions (A does not get any because it's VFS):

488+ -- Expect 4 subscriptions (A does not get any because it's VFS):

466 -- - /path-to-workspace/WatchedFilesMissingModule.hs

489 -- - /path-to-workspace/WatchedFilesMissingModule.hs

467 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

490 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

468− -- - WatchedFilesMissingModule.hs

469− -- - WatchedFilesMissingModule.lhs

470− -- - src/WatchedFilesMissingModule.hs

491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

471− -- - src/WatchedFilesMissingModule.lhs

492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

472− liftIO $ length watchedFileRegs @?= 6

493+ liftIO $ length watchedFileRegs @?= 4

473

494

474 , testSession' "non workspace file" $ \sessionDir -> do

495 , testSession' "non workspace file" $ \sessionDir -> do

475 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

496 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

476− _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

477 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

498 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

478

499

479− -- Expect 4 subscriptions (/tmp does not get any as it is out of the workspace):

500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

480 -- - /path-to-workspace/WatchedFilesMissingModule.hs

501 -- - /path-to-workspace/WatchedFilesMissingModule.hs

481 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

502 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

482− -- - WatchedFilesMissingModule.hs

483− -- - WatchedFilesMissingModule.lhs

484− liftIO $ length watchedFileRegs @?= 4

503+ liftIO $ length watchedFileRegs @?= 2

485

504

486 -- TODO add a test for didChangeWorkspaceFolder

505 -- TODO add a test for didChangeWorkspaceFolder

487 ]

506 ]

@@ -494,7 +513,7 @@ renameActionTests = testGroup "rename actions"

494 , "foo :: Int -> Int"

513 , "foo :: Int -> Int"

495 , "foo argName = argNme"

514 , "foo argName = argNme"

496 ]

515 ]

497− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

498 _ <- waitForDiagnostics

517 _ <- waitForDiagnostics

499 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

500 executeCodeAction action

519 executeCodeAction action

@@ -512,7 +531,7 @@ renameActionTests = testGroup "rename actions"

512 , "foo :: Maybe a -> [a]"

531 , "foo :: Maybe a -> [a]"

513 , "foo = maybToList"

532 , "foo = maybToList"

514 ]

533 ]

515− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

516 _ <- waitForDiagnostics

535 _ <- waitForDiagnostics

517 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

518 executeCodeAction action

537 executeCodeAction action

@@ -530,7 +549,7 @@ renameActionTests = testGroup "rename actions"

530 , "foo :: Char -> Char -> Char -> Char"

549 , "foo :: Char -> Char -> Char -> Char"

531 , "foo argument1 argument2 argument3 = argumentX"

550 , "foo argument1 argument2 argument3 = argumentX"

532 ]

551 ]

533− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

534 _ <- waitForDiagnostics

553 _ <- waitForDiagnostics

535 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

536 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -542,7 +561,7 @@ renameActionTests = testGroup "rename actions"

542 , "monus x y = max 0 (x - y)"

561 , "monus x y = max 0 (x - y)"

543 , "foo x y = x `monnus` y"

562 , "foo x y = x `monnus` y"

544 ]

563 ]

545− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

546 _ <- waitForDiagnostics

565 _ <- waitForDiagnostics

547 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

548 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -565,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

565 , "func :: _"

584 , "func :: _"

566 , "func x = x"

585 , "func x = x"

567 ]

586 ]

568− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

569 _ <- waitForDiagnostics

588 _ <- waitForDiagnostics

570 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

571 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -585,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

585 , "func :: _"

604 , "func :: _"

586 , "func x y = x + y"

605 , "func x y = x + y"

587 ]

606 ]

588− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

589 _ <- waitForDiagnostics

608 _ <- waitForDiagnostics

590 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

591 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -608,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

608 , " y = x * 2"

627 , " y = x * 2"

609 , " in y"

628 , " in y"

610 ]

629 ]

611− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

612 _ <- waitForDiagnostics

631 _ <- waitForDiagnostics

613 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

614 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -633,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

633 let contentA = T.unlines

652 let contentA = T.unlines

634 [ "module ModuleA where"

653 [ "module ModuleA where"

635 ]

654 ]

636− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

637 let contentB = T.unlines

656 let contentB = T.unlines

638 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

639 , "module ModuleB where"

658 , "module ModuleB where"

@@ -641,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

641 , "stuffB :: Integer"

660 , "stuffB :: Integer"

642 , "stuffB = 123"

661 , "stuffB = 123"

643 ]

662 ]

644− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

645 _ <- waitForDiagnostics

664 _ <- waitForDiagnostics

646 [CACodeAction action@CodeAction { _title = actionTitle }]

665 [CACodeAction action@CodeAction { _title = actionTitle }]

647 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -659,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

659 let contentA = T.unlines

678 let contentA = T.unlines

660 [ "module ModuleA where"

679 [ "module ModuleA where"

661 ]

680 ]

662− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

663 let contentB = T.unlines

682 let contentB = T.unlines

664 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

665 , "module ModuleB where"

684 , "module ModuleB where"

@@ -667,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

667 , "stuffB :: Integer"

686 , "stuffB :: Integer"

668 , "stuffB = 123"

687 , "stuffB = 123"

669 ]

688 ]

670− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

671 _ <- waitForDiagnostics

690 _ <- waitForDiagnostics

672 [CACodeAction action@CodeAction { _title = actionTitle }]

691 [CACodeAction action@CodeAction { _title = actionTitle }]

673 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -689,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

689 , "stuffB = 123"

708 , "stuffB = 123"

690 , "stuffC = ()"

709 , "stuffC = ()"

691 ]

710 ]

692− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

693 let contentB = T.unlines

712 let contentB = T.unlines

694 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

695 , "module ModuleB where"

714 , "module ModuleB where"

696 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

697 , "main = print stuffB"

716 , "main = print stuffB"

698 ]

717 ]

699− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

700 _ <- waitForDiagnostics

719 _ <- waitForDiagnostics

701 [CACodeAction action@CodeAction { _title = actionTitle }]

720 [CACodeAction action@CodeAction { _title = actionTitle }]

702 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -718,22 +737,18 @@ removeImportTests = testGroup "remove import actions"

718 , "stuffB :: Integer"

737 , "stuffB :: Integer"

719 , "stuffB = 123"

738 , "stuffB = 123"

720 ]

739 ]

721− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

722 let contentB = T.unlines

741 let contentB = T.unlines

723 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

724 , "module ModuleB where"

743 , "module ModuleB where"

725 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

726 , "main = print A.stuffB"

745 , "main = print A.stuffB"

727 ]

746 ]

728− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

729 _ <- waitForDiagnostics

748 _ <- waitForDiagnostics

730 [CACodeAction action@CodeAction { _title = actionTitle }]

749 [CACodeAction action@CodeAction { _title = actionTitle }]

731 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

732−#if MIN_GHC_API_VERSION(8,6,0)

733 liftIO $ "Remove !!, <?> from import" @=? actionTitle

751 liftIO $ "Remove !!, <?> from import" @=? actionTitle

734−#else

735− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle

736−#endif

737 executeCodeAction action

752 executeCodeAction action

738 contentAfterAction <- documentContents docB

753 contentAfterAction <- documentContents docB

739 let expectedContentAfterAction = T.unlines

754 let expectedContentAfterAction = T.unlines

@@ -750,14 +765,14 @@ removeImportTests = testGroup "remove import actions"

750 , "stuffB :: Integer"

765 , "stuffB :: Integer"

751 , "stuffB = 123"

766 , "stuffB = 123"

752 ]

767 ]

753− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

754 let contentB = T.unlines

769 let contentB = T.unlines

755 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

756 , "module ModuleB where"

771 , "module ModuleB where"

757 , "import ModuleA (A(..), stuffB)"

772 , "import ModuleA (A(..), stuffB)"

758 , "main = print stuffB"

773 , "main = print stuffB"

759 ]

774 ]

760− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

761 _ <- waitForDiagnostics

776 _ <- waitForDiagnostics

762 [CACodeAction action@CodeAction { _title = actionTitle }]

777 [CACodeAction action@CodeAction { _title = actionTitle }]

763 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -777,14 +792,14 @@ removeImportTests = testGroup "remove import actions"

777 , "data D = A | B"

792 , "data D = A | B"

778 , "data E = F"

793 , "data E = F"

779 ]

794 ]

780− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

781 let contentB = T.unlines

796 let contentB = T.unlines

782 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

783 , "module ModuleB where"

798 , "module ModuleB where"

784 , "import ModuleA (D(A,B), E(F))"

799 , "import ModuleA (D(A,B), E(F))"

785 , "main = B"

800 , "main = B"

786 ]

801 ]

787− docB <- openDoc' "ModuleB.hs" "haskell" contentB

802+ docB <- createDoc "ModuleB.hs" "haskell" contentB

788 _ <- waitForDiagnostics

803 _ <- waitForDiagnostics

789 [CACodeAction action@CodeAction { _title = actionTitle }]

804 [CACodeAction action@CodeAction { _title = actionTitle }]

790 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -925,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

925 ]

940 ]

926 where

941 where

927 template contentA contentB range expectedAction expectedContentB = do

942 template contentA contentB range expectedAction expectedContentB = do

928− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

929− docB <- openDoc' "ModuleB.hs" "haskell" contentB

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

930 _ <- waitForDiagnostics

945 _ <- waitForDiagnostics

931 CACodeAction action@CodeAction { _title = actionTitle } : _

946 CACodeAction action@CodeAction { _title = actionTitle } : _

932 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -976,7 +991,7 @@ suggestImportTests = testGroup "suggest import actions"

976 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

977 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

978 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

979− doc <- openDoc' "Test.hs" "haskell" before

994+ doc <- createDoc "Test.hs" "haskell" before

980 _diags <- waitForDiagnostics

995 _diags <- waitForDiagnostics

981 let defLine = length imps + 1

996 let defLine = length imps + 1

982 range = Range (Position defLine 0) (Position defLine maxBound)

997 range = Range (Position defLine 0) (Position defLine maxBound)

@@ -1036,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

1036 ]

1051 ]

1037 where

1052 where

1038 template initialContent range expectedAction expectedContents = do

1053 template initialContent range expectedAction expectedContents = do

1039− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

1040 _ <- waitForDiagnostics

1055 _ <- waitForDiagnostics

1041 CACodeAction action@CodeAction { _title = actionTitle } : _

1056 CACodeAction action@CodeAction { _title = actionTitle } : _

1042 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1059,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

1059 [""

1074 [""

1060 ,"someOtherCode = ()"

1075 ,"someOtherCode = ()"

1061 ]

1076 ]

1062− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1063 _ <- waitForDiagnostics

1078 _ <- waitForDiagnostics

1064 CACodeAction action@CodeAction { _title = actionTitle } : _

1079 CACodeAction action@CodeAction { _title = actionTitle } : _

1065 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1083,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

1083 [""

1098 [""

1084 ,"someOtherCode = ()"

1099 ,"someOtherCode = ()"

1085 ]

1100 ]

1086− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1087 _ <- waitForDiagnostics

1102 _ <- waitForDiagnostics

1088 CACodeAction action@CodeAction { _title = actionTitle } : _

1103 CACodeAction action@CodeAction { _title = actionTitle } : _

1089 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1122,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

1122 ]

1137 ]

1123 where

1138 where

1124 template contentA contentB range expectedAction expectedContentB = do

1139 template contentA contentB range expectedAction expectedContentB = do

1125− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1126− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

1127 _diags <- waitForDiagnostics

1142 _diags <- waitForDiagnostics

1128 CACodeAction action@CodeAction { _title = actionTitle } : _

1143 CACodeAction action@CodeAction { _title = actionTitle } : _

1129 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1142,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

1142 [ "module Testing where"

1157 [ "module Testing where"

1143 , "import Data.Mape"

1158 , "import Data.Mape"

1144 ]

1159 ]

1145− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

1146 _ <- waitForDiagnostics

1161 _ <- waitForDiagnostics

1147 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1148 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1179,7 +1194,7 @@ fillTypedHoleTests = let

1179 newA newB newC = testSession (T.unpack actionTitle) $ do

1194 newA newB newC = testSession (T.unpack actionTitle) $ do

1180 let originalCode = sourceCode oldA oldB oldC

1195 let originalCode = sourceCode oldA oldB oldC

1181 let expectedCode = sourceCode newA newB newC

1196 let expectedCode = sourceCode newA newB newC

1182− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

1183 _ <- waitForDiagnostics

1198 _ <- waitForDiagnostics

1184 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1185 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

1200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

@@ -1227,7 +1242,7 @@ addSigActionTests = let

1227 def >:: sig = testSession (T.unpack def) $ do

1242 def >:: sig = testSession (T.unpack def) $ do

1228 let originalCode = before def

1243 let originalCode = before def

1229 let expectedCode = after' def sig

1244 let expectedCode = after' def sig

1230− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1231 _ <- waitForDiagnostics

1246 _ <- waitForDiagnostics

1232 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1233 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

@@ -1259,7 +1274,7 @@ addSigLensesTests = let

1259 sigSession withMissing def sig = testSession (T.unpack def) $ do

1274 sigSession withMissing def sig = testSession (T.unpack def) $ do

1260 let originalCode = before withMissing def

1275 let originalCode = before withMissing def

1261 let expectedCode = after' withMissing def sig

1276 let expectedCode = after' withMissing def sig

1262− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1263 [CodeLens {_command = Just c}] <- getCodeLenses doc

1278 [CodeLens {_command = Just c}] <- getCodeLenses doc

1264 executeCommand c

1279 executeCommand c

1265 modifiedCode <- getDocumentEdit doc

1280 modifiedCode <- getDocumentEdit doc

@@ -1281,27 +1296,19 @@ addSigLensesTests = let

1281 ]

1296 ]

1282 ]

1297 ]

1283

1298

1284−findDefinitionAndHoverTests :: TestTree

1285−findDefinitionAndHoverTests = let

1286−

1287− tst (get, check) pos targetRange title = testSession title $ do

1288− doc <- openTestDataDoc sourceFilePath

1289− found <- get doc pos

1290− check found targetRange

1291−

1292− checkDefs :: [Location] -> Session [Expect] -> Session ()

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1293− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1294

1301

1295− check (ExpectRange expectedRange) = do

1302+ check (ExpectRange expectedRange) = do

1296− assertNDefinitionsFound 1 defs

1303+ assertNDefinitionsFound 1 defs

1297− assertRangeCorrect (head defs) expectedRange

1304+ assertRangeCorrect (head defs) expectedRange

1298− check (ExpectLocation expectedLocation) = do

1305+ check (ExpectLocation expectedLocation) = do

1299− assertNDefinitionsFound 1 defs

1306+ assertNDefinitionsFound 1 defs

1300− liftIO $ head defs @?= expectedLocation

1307+ liftIO $ head defs @?= expectedLocation

1301− check ExpectNoDefinitions = do

1308+ check ExpectNoDefinitions = do

1302− assertNDefinitionsFound 0 defs

1309+ assertNDefinitionsFound 0 defs

1303− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1304− check _ = pure () -- all other expectations not relevant to getDefinition

1311+ check _ = pure () -- all other expectations not relevant to getDefinition

1305

1312

1306 assertNDefinitionsFound :: Int -> [a] -> Session ()

1313 assertNDefinitionsFound :: Int -> [a] -> Session ()

1307 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1309,6 +1316,17 @@ findDefinitionAndHoverTests = let

1309 assertRangeCorrect Location{_range = foundRange} expectedRange =

1316 assertRangeCorrect Location{_range = foundRange} expectedRange =

1310 liftIO $ expectedRange @=? foundRange

1317 liftIO $ expectedRange @=? foundRange

1311

1318

1319+

1320+findDefinitionAndHoverTests :: TestTree

1321+findDefinitionAndHoverTests = let

1322+

1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324+ doc <- openTestDataDoc (dir </> sourceFilePath)

1325+ found <- get doc pos

1326+ check found targetRange

1327+

1328+

1329+

1312 checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1313 checkHover hover expectations = traverse_ check =<< expectations where

1331 checkHover hover expectations = traverse_ check =<< expectations where

1314

1332

@@ -1353,7 +1371,8 @@ findDefinitionAndHoverTests = let

1353

1371

1354 mkFindTests tests = testGroup "get"

1372 mkFindTests tests = testGroup "get"

1355 [ testGroup "definition" $ mapMaybe fst tests

1373 [ testGroup "definition" $ mapMaybe fst tests

1356− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

1357

1376

1358 test runDef runHover look expect = testM runDef runHover look (return expect)

1377 test runDef runHover look expect = testM runDef runHover look (return expect)

1359

1378

@@ -1448,6 +1467,14 @@ findDefinitionAndHoverTests = let

1448 broken = Just . (`xfail` "known broken")

1467 broken = Just . (`xfail` "known broken")

1449 no = const Nothing -- don't run this test at all

1468 no = const Nothing -- don't run this test at all

1450

1469

1470+checkFileCompiles :: FilePath -> TestTree

1471+checkFileCompiles fp =

1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do

1473+ void (openTestDataDoc (dir </> fp))

1474+ expectNoMoreDiagnostics 0.5

1475+

1476+

1477+

1451pluginTests :: TestTree

1478pluginTests :: TestTree

1452pluginTests = (`xfail8101` "known broken (#556)")

1479pluginTests = (`xfail8101` "known broken (#556)")

1453 $ testSessionWait "plugins" $ do

1480 $ testSessionWait "plugins" $ do

@@ -1464,7 +1491,7 @@ pluginTests = (`xfail8101` "known broken (#556)")

1464 , "foo :: Int -> Int -> Int"

1491 , "foo :: Int -> Int -> Int"

1465 , "foo a b = a + c"

1492 , "foo a b = a + c"

1466 ]

1493 ]

1467− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

1468 expectDiagnostics

1495 expectDiagnostics

1469 [ ( "Testing.hs",

1496 [ ( "Testing.hs",

1470 [(DsError, (8, 14), "Variable not in scope: c")]

1497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1491,7 +1518,7 @@ cppTests =

1491 run $ expectError content (2, 1)

1518 run $ expectError content (2, 1)

1492 )

1519 )

1493 , testSessionWait "cpp-ghcide" $ do

1520 , testSessionWait "cpp-ghcide" $ do

1494− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

1495 ["{-# LANGUAGE CPP #-}"

1522 ["{-# LANGUAGE CPP #-}"

1496 ,"main ="

1523 ,"main ="

1497 ,"#ifdef __GHCIDE__"

1524 ,"#ifdef __GHCIDE__"

@@ -1505,7 +1532,7 @@ cppTests =

1505 where

1532 where

1506 expectError :: T.Text -> Cursor -> Session ()

1533 expectError :: T.Text -> Cursor -> Session ()

1507 expectError content cursor = do

1534 expectError content cursor = do

1508− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

1509 expectDiagnostics

1536 expectDiagnostics

1510 [ ( "Testing.hs",

1537 [ ( "Testing.hs",

1511 [(DsError, cursor, "error: unterminated")]

1538 [(DsError, cursor, "error: unterminated")]

@@ -1521,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do

1521 , "module Testing where"

1548 , "module Testing where"

1522 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1523 ]

1550 ]

1524− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

1525 expectDiagnostics

1552 expectDiagnostics

1526 [ ( "Testing.hs",

1553 [ ( "Testing.hs",

1527 [(DsError, (2, 8), "Variable not in scope: z")]

1554 [(DsError, (2, 8), "Variable not in scope: z")]

@@ -1554,8 +1581,8 @@ safeTests =

1554 ,"safeId = trustWorthyId"

1581 ,"safeId = trustWorthyId"

1555 ]

1582 ]

1556

1583

1557− _ <- openDoc' "A.hs" "haskell" sourceA

1584+ _ <- createDoc "A.hs" "haskell" sourceA

1558− _ <- openDoc' "B.hs" "haskell" sourceB

1585+ _ <- createDoc "B.hs" "haskell" sourceB

1559 expectNoMoreDiagnostics 1 ]

1586 expectNoMoreDiagnostics 1 ]

1560

1587

1561thTests :: TestTree

1588thTests :: TestTree

@@ -1583,8 +1610,8 @@ thTests =

1583 "b :: Integer",

1610 "b :: Integer",

1584 "b = $(litE $ IntegerL $ a) + n"

1611 "b = $(litE $ IntegerL $ a) + n"

1585 ]

1612 ]

1586− _ <- openDoc' "A.hs" "haskell" sourceA

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1587− _ <- openDoc' "B.hs" "haskell" sourceB

1614+ _ <- createDoc "B.hs" "haskell" sourceB

1588 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1589 , testSessionWait "newtype-closure" $ do

1616 , testSessionWait "newtype-closure" $ do

1590 let sourceA =

1617 let sourceA =

@@ -1604,8 +1631,8 @@ thTests =

1604 ,"import A"

1631 ,"import A"

1605 ,"b :: Int"

1632 ,"b :: Int"

1606 ,"b = $( a )" ]

1633 ,"b = $( a )" ]

1607− _ <- openDoc' "A.hs" "haskell" sourceA

1634+ _ <- createDoc "A.hs" "haskell" sourceA

1608− _ <- openDoc' "B.hs" "haskell" sourceB

1635+ _ <- createDoc "B.hs" "haskell" sourceB

1609 return ()

1636 return ()

1610 ]

1637 ]

1611

1638

@@ -1614,7 +1641,7 @@ completionTests

1614 = testGroup "completion"

1641 = testGroup "completion"

1615 [ testSessionWait "variable" $ do

1642 [ testSessionWait "variable" $ do

1616 let source = T.unlines ["module A where", "f = hea"]

1643 let source = T.unlines ["module A where", "f = hea"]

1617− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

1618 compls <- getCompletions docId (Position 1 7)

1645 compls <- getCompletions docId (Position 1 7)

1619 liftIO $ map dropDocs compls @?=

1646 liftIO $ map dropDocs compls @?=

1620 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1626,7 +1653,7 @@ completionTests

1626 ]

1653 ]

1627 , testSessionWait "constructor" $ do

1654 , testSessionWait "constructor" $ do

1628 let source = T.unlines ["module A where", "f = Tru"]

1655 let source = T.unlines ["module A where", "f = Tru"]

1629− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

1630 compls <- getCompletions docId (Position 1 7)

1657 compls <- getCompletions docId (Position 1 7)

1631 liftIO $ map dropDocs compls @?=

1658 liftIO $ map dropDocs compls @?=

1632 [ complItem "True" (Just CiConstructor) (Just "Bool")

1659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1638,7 +1665,7 @@ completionTests

1638 ]

1665 ]

1639 , testSessionWait "type" $ do

1666 , testSessionWait "type" $ do

1640 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1641− docId <- openDoc' "A.hs" "haskell" source

1668+ docId <- createDoc "A.hs" "haskell" source

1642 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1643 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1644 compls <- getCompletions docId (Position 2 7)

1671 compls <- getCompletions docId (Position 2 7)

@@ -1655,7 +1682,7 @@ completionTests

1655 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1656 , testSessionWait "qualified" $ do

1683 , testSessionWait "qualified" $ do

1657 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1658− docId <- openDoc' "A.hs" "haskell" source

1685+ docId <- createDoc "A.hs" "haskell" source

1659 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1660 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1661 compls <- getCompletions docId (Position 2 15)

1688 compls <- getCompletions docId (Position 2 15)

@@ -1669,7 +1696,7 @@ completionTests

1669 ]

1696 ]

1670 , testSessionWait "keyword" $ do

1697 , testSessionWait "keyword" $ do

1671 let source = T.unlines ["module A where", "f = newty"]

1698 let source = T.unlines ["module A where", "f = newty"]

1672− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

1673 compls <- getCompletions docId (Position 1 9)

1700 compls <- getCompletions docId (Position 1 9)

1674 liftIO $ compls @?= [keywordItem "newtype"]

1701 liftIO $ compls @?= [keywordItem "newtype"]

1675 , testSessionWait "type context" $ do

1702 , testSessionWait "type context" $ do

@@ -1678,7 +1705,7 @@ completionTests

1678 , "module A () where"

1705 , "module A () where"

1679 , "f = f"

1706 , "f = f"

1680 ]

1707 ]

1681− docId <- openDoc' "A.hs" "haskell" source

1708+ docId <- createDoc "A.hs" "haskell" source

1682 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

1709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

1683 changeDoc docId

1710 changeDoc docId

1684 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

1711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

@@ -1746,7 +1773,7 @@ outlineTests = testGroup

1746 "outline"

1773 "outline"

1747 [ testSessionWait "type class" $ do

1774 [ testSessionWait "type class" $ do

1748 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1749− docId <- openDoc' "A.hs" "haskell" source

1776+ docId <- createDoc "A.hs" "haskell" source

1750 symbols <- getDocumentSymbols docId

1777 symbols <- getDocumentSymbols docId

1751 liftIO $ symbols @?= Left

1778 liftIO $ symbols @?= Left

1752 [ moduleSymbol

1779 [ moduleSymbol

@@ -1759,7 +1786,7 @@ outlineTests = testGroup

1759 ]

1786 ]

1760 , testSessionWait "type class instance " $ do

1787 , testSessionWait "type class instance " $ do

1761 let source = T.unlines ["class A a where", "instance A () where"]

1788 let source = T.unlines ["class A a where", "instance A () where"]

1762− docId <- openDoc' "A.hs" "haskell" source

1789+ docId <- createDoc "A.hs" "haskell" source

1763 symbols <- getDocumentSymbols docId

1790 symbols <- getDocumentSymbols docId

1764 liftIO $ symbols @?= Left

1791 liftIO $ symbols @?= Left

1765 [ classSymbol "A a" (R 0 0 0 15) []

1792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1767,7 +1794,7 @@ outlineTests = testGroup

1767 ]

1794 ]

1768 , testSessionWait "type family" $ do

1795 , testSessionWait "type family" $ do

1769 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1770− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

1771 symbols <- getDocumentSymbols docId

1798 symbols <- getDocumentSymbols docId

1772 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1773 , testSessionWait "type family instance " $ do

1800 , testSessionWait "type family instance " $ do

@@ -1776,7 +1803,7 @@ outlineTests = testGroup

1776 , "type family A a"

1803 , "type family A a"

1777 , "type instance A () = ()"

1804 , "type instance A () = ()"

1778 ]

1805 ]

1779− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

1780 symbols <- getDocumentSymbols docId

1807 symbols <- getDocumentSymbols docId

1781 liftIO $ symbols @?= Left

1808 liftIO $ symbols @?= Left

1782 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1784,7 +1811,7 @@ outlineTests = testGroup

1784 ]

1811 ]

1785 , testSessionWait "data family" $ do

1812 , testSessionWait "data family" $ do

1786 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1787− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

1788 symbols <- getDocumentSymbols docId

1815 symbols <- getDocumentSymbols docId

1789 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1790 , testSessionWait "data family instance " $ do

1817 , testSessionWait "data family instance " $ do

@@ -1793,7 +1820,7 @@ outlineTests = testGroup

1793 , "data family A a"

1820 , "data family A a"

1794 , "data instance A () = A ()"

1821 , "data instance A () = A ()"

1795 ]

1822 ]

1796− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

1797 symbols <- getDocumentSymbols docId

1824 symbols <- getDocumentSymbols docId

1798 liftIO $ symbols @?= Left

1825 liftIO $ symbols @?= Left

1799 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1801,36 +1828,36 @@ outlineTests = testGroup

1801 ]

1828 ]

1802 , testSessionWait "constant" $ do

1829 , testSessionWait "constant" $ do

1803 let source = T.unlines ["a = ()"]

1830 let source = T.unlines ["a = ()"]

1804− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

1805 symbols <- getDocumentSymbols docId

1832 symbols <- getDocumentSymbols docId

1806 liftIO $ symbols @?= Left

1833 liftIO $ symbols @?= Left

1807 [docSymbol "a" SkFunction (R 0 0 0 6)]

1834 [docSymbol "a" SkFunction (R 0 0 0 6)]

1808 , testSessionWait "pattern" $ do

1835 , testSessionWait "pattern" $ do

1809 let source = T.unlines ["Just foo = Just 21"]

1836 let source = T.unlines ["Just foo = Just 21"]

1810− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

1811 symbols <- getDocumentSymbols docId

1838 symbols <- getDocumentSymbols docId

1812 liftIO $ symbols @?= Left

1839 liftIO $ symbols @?= Left

1813 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1814 , testSessionWait "pattern with type signature" $ do

1841 , testSessionWait "pattern with type signature" $ do

1815 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1816− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

1817 symbols <- getDocumentSymbols docId

1844 symbols <- getDocumentSymbols docId

1818 liftIO $ symbols @?= Left

1845 liftIO $ symbols @?= Left

1819 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1820 , testSessionWait "function" $ do

1847 , testSessionWait "function" $ do

1821 let source = T.unlines ["a x = ()"]

1848 let source = T.unlines ["a x = ()"]

1822− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

1823 symbols <- getDocumentSymbols docId

1850 symbols <- getDocumentSymbols docId

1824 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1825 , testSessionWait "type synonym" $ do

1852 , testSessionWait "type synonym" $ do

1826 let source = T.unlines ["type A = Bool"]

1853 let source = T.unlines ["type A = Bool"]

1827− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

1828 symbols <- getDocumentSymbols docId

1855 symbols <- getDocumentSymbols docId

1829 liftIO $ symbols @?= Left

1856 liftIO $ symbols @?= Left

1830 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1831 , testSessionWait "datatype" $ do

1858 , testSessionWait "datatype" $ do

1832 let source = T.unlines ["data A = C"]

1859 let source = T.unlines ["data A = C"]

1833− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

1834 symbols <- getDocumentSymbols docId

1861 symbols <- getDocumentSymbols docId

1835 liftIO $ symbols @?= Left

1862 liftIO $ symbols @?= Left

1836 [ docSymbolWithChildren "A"

1863 [ docSymbolWithChildren "A"

@@ -1838,9 +1865,21 @@ outlineTests = testGroup

1838 (R 0 0 0 10)

1865 (R 0 0 0 10)

1839 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1840 ]

1867 ]

1868+ , testSessionWait "record fields" $ do

1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]

1870+ docId <- createDoc "A.hs" "haskell" source

1871+ symbols <- getDocumentSymbols docId

1872+ liftIO $ symbols @=? Left

1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)

1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)

1875+ [ docSymbol "x" SkField (R 1 2 1 3)

1876+ , docSymbol "y" SkField (R 2 4 2 5)

1877+ ]

1878+ ]

1879+ ]

1841 , testSessionWait "import" $ do

1880 , testSessionWait "import" $ do

1842 let source = T.unlines ["import Data.Maybe"]

1881 let source = T.unlines ["import Data.Maybe"]

1843− docId <- openDoc' "A.hs" "haskell" source

1882+ docId <- createDoc "A.hs" "haskell" source

1844 symbols <- getDocumentSymbols docId

1883 symbols <- getDocumentSymbols docId

1845 liftIO $ symbols @?= Left

1884 liftIO $ symbols @?= Left

1846 [docSymbolWithChildren "imports"

1885 [docSymbolWithChildren "imports"

@@ -1851,7 +1890,7 @@ outlineTests = testGroup

1851 ]

1890 ]

1852 , testSessionWait "multiple import" $ do

1891 , testSessionWait "multiple import" $ do

1853 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1854− docId <- openDoc' "A.hs" "haskell" source

1893+ docId <- createDoc "A.hs" "haskell" source

1855 symbols <- getDocumentSymbols docId

1894 symbols <- getDocumentSymbols docId

1856 liftIO $ symbols @?= Left

1895 liftIO $ symbols @?= Left

1857 [docSymbolWithChildren "imports"

1896 [docSymbolWithChildren "imports"

@@ -1866,7 +1905,7 @@ outlineTests = testGroup

1866 [ "{-# language ForeignFunctionInterface #-}"

1905 [ "{-# language ForeignFunctionInterface #-}"

1867 , "foreign import ccall \"a\" a :: Int"

1906 , "foreign import ccall \"a\" a :: Int"

1868 ]

1907 ]

1869− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

1870 symbols <- getDocumentSymbols docId

1909 symbols <- getDocumentSymbols docId

1871 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1872 , testSessionWait "foreign export" $ do

1911 , testSessionWait "foreign export" $ do

@@ -1874,7 +1913,7 @@ outlineTests = testGroup

1874 [ "{-# language ForeignFunctionInterface #-}"

1913 [ "{-# language ForeignFunctionInterface #-}"

1875 , "foreign export ccall odd :: Int -> Bool"

1914 , "foreign export ccall odd :: Int -> Bool"

1876 ]

1915 ]

1877− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

1878 symbols <- getDocumentSymbols docId

1917 symbols <- getDocumentSymbols docId

1879 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1880 ]

1919 ]

@@ -1887,6 +1926,8 @@ outlineTests = testGroup

1887 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1888 docSymbolWithChildren name kind loc cc =

1927 docSymbolWithChildren name kind loc cc =

1889 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1928 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1929+ docSymbolWithChildren' name kind loc selectionLoc cc =

1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)

1890 moduleSymbol name loc cc = DocumentSymbol name

1931 moduleSymbol name loc cc = DocumentSymbol name

1891 Nothing

1932 Nothing

1892 SkFile

1933 SkFile

@@ -1992,6 +2033,7 @@ cradleTests :: TestTree

1992cradleTests = testGroup "cradle"

2033cradleTests = testGroup "cradle"

1993 [testGroup "dependencies" [sessionDepsArePickedUp]

2034 [testGroup "dependencies" [sessionDepsArePickedUp]

1994 ,testGroup "loading" [loadCradleOnlyonce]

2035 ,testGroup "loading" [loadCradleOnlyonce]

2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

1995 ]

2037 ]

1996

2038

1997loadCradleOnlyonce :: TestTree

2039loadCradleOnlyonce :: TestTree

@@ -2006,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"

2006 test dir

2048 test dir

2007 implicit dir = test dir

2049 implicit dir = test dir

2008 test _dir = do

2050 test _dir = do

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

2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

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

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

2011 liftIO $ length msgs @?= 1

2053 liftIO $ length msgs @?= 1

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

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

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

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

2014 liftIO $ length msgs @?= 0

2056 liftIO $ length msgs @?= 0

2015− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

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

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

2017 liftIO $ length msgs @?= 0

2059 liftIO $ length msgs @?= 0

2018

2060

2019

2061

2062+dependentFileTest :: TestTree

2063+dependentFileTest = testGroup "addDependentFile"

2064+ [testGroup "file-changed" [testSession' "test" test]

2065+ ]

2066+ where

2067+ test dir = do

2068+ -- If the file contains B then no type error

2069+ -- otherwise type error

2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"

2071+ let fooContent = T.unlines

2072+ [ "{-# LANGUAGE TemplateHaskell #-}"

2073+ , "module Foo where"

2074+ , "import Language.Haskell.TH.Syntax"

2075+ , "foo :: Int"

2076+ , "foo = 1 + $(do"

2077+ , " qAddDependentFile \"dep-file.txt\""

2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"

2079+ , " if f == \"B\" then [| 1 |] else lift f)"

2080+ ]

2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]

2082+ _ <-createDoc "Foo.hs" "haskell" fooContent

2083+ doc <- createDoc "Baz.hs" "haskell" bazContent

2084+ expectDiagnostics

2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]

2086+ -- Now modify the dependent file

2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"

2088+ let change = TextDocumentContentChangeEvent

2089+ { _range = Just (Range (Position 2 0) (Position 2 6))

2090+ , _rangeLength = Nothing

2091+ , _text = "f = ()"

2092+ }

2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well

2094+ changeDoc doc [change]

2095+ expectDiagnostics [("Foo.hs", [])]

2096+

2097+

2020cradleLoadedMessage :: Session FromServerMessage

2098cradleLoadedMessage :: Session FromServerMessage

2021cradleLoadedMessage = satisfy $ \case

2099cradleLoadedMessage = satisfy $ \case

2022 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

2100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

@@ -2025,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case

2025cradleLoadedMethod :: T.Text

2103cradleLoadedMethod :: T.Text

2026cradleLoadedMethod = "ghcide/cradle/loaded"

2104cradleLoadedMethod = "ghcide/cradle/loaded"

2027

2105

2106+-- Stack sets this which trips up cabal in the multi-component tests.

2107+-- However, our plugin tests rely on those env vars so we unset it locally.

2108+withoutStackEnv :: IO a -> IO a

2109+withoutStackEnv s =

2110+ bracket

2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)

2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))

2113+ (const s)

2114+ where vars =

2115+ [ "GHC_PACKAGE_PATH"

2116+ , "GHC_ENVIRONMENT"

2117+ , "HASKELL_DIST_DIR"

2118+ , "HASKELL_PACKAGE_SANDBOX"

2119+ , "HASKELL_PACKAGE_SANDBOXES"

2120+ ]

2121+ restore var Nothing = unsetEnv var

2122+ restore var (Just val) = setEnv var val True

2123+

2124+simpleMultiTest :: TestTree

2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2126+ let aPath = dir </> "a/A.hs"

2127+ bPath = dir </> "b/B.hs"

2128+ aSource <- liftIO $ readFileUtf8 aPath

2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2130+ expectNoMoreDiagnostics 0.5

2131+ bSource <- liftIO $ readFileUtf8 bPath

2132+ bdoc <- createDoc bPath "haskell" bSource

2133+ expectNoMoreDiagnostics 0.5

2134+ locs <- getDefinitions bdoc (Position 2 7)

2135+ let fooL = mkL adoc 2 0 2 3

2136+ checkDefs locs (pure [fooL])

2137+ expectNoMoreDiagnostics 0.5

2138+

2139+-- Like simpleMultiTest but open the files in the other order

2140+simpleMultiTest2 :: TestTree

2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2142+ let aPath = dir </> "a/A.hs"

2143+ bPath = dir </> "b/B.hs"

2144+ bSource <- liftIO $ readFileUtf8 bPath

2145+ bdoc <- createDoc bPath "haskell" bSource

2146+ expectNoMoreDiagnostics 5

2147+ aSource <- liftIO $ readFileUtf8 aPath

2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2149+ -- Need to have some delay here or the test fails

2150+ expectNoMoreDiagnostics 5

2151+ locs <- getDefinitions bdoc (Position 2 7)

2152+ let fooL = mkL adoc 2 0 2 3

2153+ checkDefs locs (pure [fooL])

2154+ expectNoMoreDiagnostics 0.5

2155+

2028sessionDepsArePickedUp :: TestTree

2156sessionDepsArePickedUp :: TestTree

2029sessionDepsArePickedUp = testSession'

2157sessionDepsArePickedUp = testSession'

2030 "session-deps-are-picked-up"

2158 "session-deps-are-picked-up"

@@ -2034,7 +2162,7 @@ sessionDepsArePickedUp = testSession'

2034 (dir </> "hie.yaml")

2162 (dir </> "hie.yaml")

2035 "cradle: {direct: {arguments: []}}"

2163 "cradle: {direct: {arguments: []}}"

2036 -- Open without OverloadedStrings and expect an error.

2164 -- Open without OverloadedStrings and expect an error.

2037− doc <- openDoc' "Foo.hs" "haskell" fooContent

2165+ doc <- createDoc "Foo.hs" "haskell" fooContent

2038 expectDiagnostics

2166 expectDiagnostics

2039 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2040 -- Update hie.yaml to enable OverloadedStrings.

2168 -- Update hie.yaml to enable OverloadedStrings.

@@ -2069,6 +2197,9 @@ sessionDepsArePickedUp = testSession'

2069testSession :: String -> Session () -> TestTree

2197testSession :: String -> Session () -> TestTree

2070testSession name = testCase name . run

2198testSession name = testCase name . run

2071

2199

2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202+

2072testSession' :: String -> (FilePath -> Session ()) -> TestTree

2203testSession' :: String -> (FilePath -> Session ()) -> TestTree

2073testSession' name = testCase name . run'

2204testSession' name = testCase name . run'

2074

2205

@@ -2103,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)

2103run :: Session a -> IO a

2234run :: Session a -> IO a

2104run s = withTempDir $ \dir -> runInDir dir s

2235run s = withTempDir $ \dir -> runInDir dir s

2105

2236

2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a

2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do

2239+ copyTestDataFiles dir prefix

2240+ runInDir dir (s dir)

2241+

2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()

2243+copyTestDataFiles dir prefix = do

2244+ -- Copy all the test data files to the temporary workspace

2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]

2246+ for_ testDataFiles $ \f -> do

2247+ createDirectoryIfMissing True $ dir </> takeDirectory f

2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)

2249+

2106run' :: (FilePath -> Session a) -> IO a

2250run' :: (FilePath -> Session a) -> IO a

2107run' s = withTempDir $ \dir -> runInDir dir (s dir)

2251run' s = withTempDir $ \dir -> runInDir dir (s dir)

2108

2252

@@ -2114,11 +2258,6 @@ runInDir dir s = do

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

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

2115 createDirectoryIfMissing True $ dir ++ "/Data"

2259 createDirectoryIfMissing True $ dir ++ "/Data"

2116

2260

2117− -- Copy all the test data files to the temporary workspace

2118− testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]

2119− for_ testDataFiles $ \f -> do

2120− createDirectoryIfMissing True $ dir </> takeDirectory f

2121− copyFile ("test/data" </> f) (dir </> f)

2122

2261

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

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

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

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

@@ -2137,7 +2276,7 @@ runInDir dir s = do

2137openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2138openTestDataDoc path = do

2277openTestDataDoc path = do

2139 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2140− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

2141

2280

2142findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2143findCodeActions doc range expectedTitles = do

2282findCodeActions doc range expectedTitles = do

@@ -2178,20 +2317,6 @@ unitTests = do

2178 uriToFilePath' uri @?= Just ""

2317 uriToFilePath' uri @?= Just ""

2179 ]

2318 ]

2180

2319

2181−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

2182−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2183−openDoc' fp name contents = do

2184− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

2185− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

2186− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

2187− return res

2188−

2189−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

2190−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2191−-- At the moment this is just LSPTest.openDoc' but it may change in the future

2192−-- when/if lsp-test implements WatchedFiles

2193−openDoc'' = LSPTest.openDoc'

2194−

2195positionMappingTests :: TestTree

2320positionMappingTests :: TestTree

2196positionMappingTests =

2321positionMappingTests =

2197 testGroup "position mapping"

2322 testGroup "position mapping"

test/src/Development/IDE/Test.hs+4−21

@@ -16,10 +16,9 @@ import Control.Applicative.Combinators

16import Control.Lens hiding (List)

17import Control.Monad

18import Control.Monad.IO.Class

19−import Data.Foldable

20import qualified Data.Map.Strict as Map

19import qualified Data.Map.Strict as Map

21import qualified Data.Text as T

20import qualified Data.Text as T

22−import Language.Haskell.LSP.Test hiding (message, openDoc')

21+import Language.Haskell.LSP.Test hiding (message)

23import qualified Language.Haskell.LSP.Test as LspTest

22import qualified Language.Haskell.LSP.Test as LspTest

24import Language.Haskell.LSP.Types

23import Language.Haskell.LSP.Types

25import Language.Haskell.LSP.Types.Lens as Lsp

24import Language.Haskell.LSP.Types.Lens as Lsp

@@ -74,17 +73,14 @@ expectNoMoreDiagnostics timeout = do

74 ignoreOthers = void anyMessage >> handleMessages

73 ignoreOthers = void anyMessage >> handleMessages

76expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

75expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

77−expectDiagnostics = expectDiagnostics' diagnostic

76+expectDiagnostics expected = do

78−

79−expectDiagnostics' :: Session PublishDiagnosticsNotification -> [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

80−expectDiagnostics' messageParser expected = do

81 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

77 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

82 go expected'

78 go expected'

83 where

79 where

84 go m

80 go m

85 | Map.null m = pure ()

81 | Map.null m = pure ()

86 | otherwise = do

82 | otherwise = do

87− diagsNot <- skipManyTill anyMessage messageParser

83+ diagsNot <- skipManyTill anyMessage diagnostic

88 let fileUri = diagsNot ^. params . uri

84 let fileUri = diagsNot ^. params . uri

89 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

90 Nothing -> do

86 Nothing -> do

@@ -103,21 +99,8 @@ expectDiagnostics' messageParser expected = do

103 " but got " <> show actual

99 " but got " <> show actual

104 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

105

101

106−-- | Matches all diagnostic messages expect those from interface loading files

107diagnostic :: Session PublishDiagnosticsNotification

102diagnostic :: Session PublishDiagnosticsNotification

108−diagnostic = do

109− m <- LspTest.message

103+diagnostic = LspTest.message

110− let PublishDiagnosticsParams uri diags = _params (m :: PublishDiagnosticsNotification)

111− let diags' = filter (\d -> _source (d:: Diagnostic) /= Just "interface file loading") (toList diags)

112− -- interface loading warnings get sent on a first message,

113− -- followed up by a second message including all other warnings.

114− -- unless the debouncer merges them.

115− -- This can lead to a test matching on the first message and missing

116− -- the interesting warnings.

117− -- Therefore we do not match messages containing only interface loading warnings,

118− -- but, importantly, do match messages containing no warnings.

119− guard (null diags || not (null diags'))

120− return $ (m :: PublishDiagnosticsNotification){_params = PublishDiagnosticsParams uri (List diags')}

121

104

122standardizeQuotes :: T.Text -> T.Text

105standardizeQuotes :: T.Text -> T.Text

123standardizeQuotes msg = let

106standardizeQuotes msg = let