07cf929...master · ghcide

git.iko.soy/ghcide

46 files changed+1694−740

since splitsnapshots

unifiedsplit

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

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

3232 ./fmt.sh

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

3434 - bash: |

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

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

36+ sudo apt-get update

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

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

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

3840 fi

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

4143 displayName: 'stack setup'

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

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

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

46+ - bash: |

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

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

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

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

4751 - bash: |

.azure/windows-stack.yml+1

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

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

4747 stack install happy --stack-yaml $STACK_YAML

4848 stack install alex --stack-yaml $STACK_YAML

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

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

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

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

77/.tasty-rerun-log

88.vscode

99/.hlint-*

10+bench/example

.hlint.yaml−1

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

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

7474

7575 # Shady extensions

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

7776 - name: CPP

7877 within:

7978 - Development.IDE.Compat

CHANGELOG.md+20

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

11### 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+

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

424

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

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

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

2727

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+

2845## Using it

2946

3047### Install `ghcide`

3148

3249#### With Nix

3350

34−[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-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+

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.

3562

3663#### With Cabal or Stack

3764

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

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

257284using `stack install ghcide` within a project.

258285

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+

259300## Hacking on ghcide

260301

261302To 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`.

284325

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

286327

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

288329

289330The 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).

290331

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

88module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

1015import Arguments

11−import Data.Maybe

12−import Data.List.Extra

13−import System.FilePath

16+import Control.Concurrent.Async

1417import Control.Concurrent.Extra

1518import Control.Exception

1619import Control.Monad.Extra

1720import Control.Monad.IO.Class

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

2030import Development.IDE.Core.Debouncer

2131import Development.IDE.Core.FileStore

2232import Development.IDE.Core.OfInterest

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

3343import Development.IDE.Plugin

3444import Development.IDE.Plugin.Completions as Completions

3545import Development.IDE.Plugin.CodeAction as CodeAction

36−import qualified Data.Text as T

37−import qualified Data.Text.IO as T

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

3947import Language.Haskell.LSP.Messages

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

41−import Data.Version

48+import Language.Haskell.LSP.Types

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

4250import Development.IDE.LSP.LanguageServer

4351import qualified System.Directory.Extra as IO

4452import System.Environment

4553import System.IO

4654import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

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

4759import Paths_ghcide

4860import Development.GitRev

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

61+import Development.Shake (Action, action)

5062import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

5164import qualified Data.Map.Strict as Map

52−import HIE.Bios

53−import Rules

54−import RuleTypes

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+

75+import HIE.Bios.Cradle

76+import HIE.Bios.Types

77+

78+import Utils

5579

5680ghcideVersion :: IO String

5781ghcideVersion = do

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

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

98122 t <- t

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

100− let options = (defaultIdeOptions $ loadSession dir)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

101125 { optReportProgress = clientSupportsProgress caps

102126 , optShakeProfiling = argsShakeProfiling

103127 , optTesting = argsTesting

104128 , optThreads = argsThreads

105− , optInterfaceLoadingDiagnostics = argsTesting

106129 }

107130 debouncer <- newAsyncDebouncer

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

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

109132 getLspId event (logger minBound) debouncer options vfs

110133 else do

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

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

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

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

117140

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

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

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

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

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

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

123146

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"

125148 cradles <- mapM findCradle files

126149 let ucradles = nubOrd cradles

127150 let n = length ucradles

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

139153 vfs <- makeVFSHandle

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

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

150−

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

154+ debouncer <- newAsyncDebouncer

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

156+

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

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

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

155161 when (failed /= []) $

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

157163

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

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

160−

161− unless (null failed) exitFailure

162−

163−cradleRules :: Rules ()

164−cradleRules = do

165− loadGhcSession

166− cradleToSession

166+ return ()

167167

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

169169expandFiles = concatMapM $ \x -> do

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

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

191191showEvent lock e = withLock lock $ print e

192192

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

194−loadSession dir = liftIO $ do

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

196− res <- findCradle v

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

198− -- try and normalise that

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

200− res' <- traverse IO.makeAbsolute res

201− return $ normalise <$> res'

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

203− session file = do

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

205− let cradle = toNormalizedFilePath' $ fromMaybe dir file

206− use_ LoadCradle cradle

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

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+

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

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

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

249+ res <- findCradle v

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

251+ -- try and normalise that

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

253+ res' <- traverse IO.makeAbsolute res

254+ return $ normalise <$> res'

255+

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

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

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

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)

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)

208403

209404

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+

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

211593--

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

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

223605 res <- onceFork $ op k

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

225607 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

22build-type: Simple

33category: Development

44name: ghcide

5−version: 0.1.0

5+version: 0.2.0

66license: Apache-2.0

77license-file: LICENSE

88author: Digital Asset

99maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

1111synopsis: The core of an IDE

1212description:

1313 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

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

1616tested-with: GHC==8.6.5

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

1925

2026source-repository head

2127 type: git

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

4450 filepath,

4551 haddock-library >= 1.8,

4652 hashable,

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

48− haskell-lsp == 0.21.*,

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

54+ haskell-lsp == 0.22.*,

4955 mtl,

5056 network-uri,

5157 prettyprinter-ansi-terminal,

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

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

185191 main-is: Main.hs

186192 build-depends:

193+ time,

194+ async,

187195 hslogger,

188196 aeson,

189197 base == 4.*,

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

197205 directory,

198206 extra,

199207 filepath,

200− ghc-check >= 0.3.0.1,

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

201209 ghc-paths,

202210 ghc,

203211 gitrev,

204212 hashable,

205213 haskell-lsp,

206214 haskell-lsp-types,

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

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

208216 ghcide,

209217 optparse-applicative,

210218 shake,

211219 text,

212220 unordered-containers

213221 other-modules:

222+ Utils

214223 Arguments

215224 Paths_ghcide

216− Rules

217− RuleTypes

218− Util

219225

220226 default-extensions:

221227 BangPatterns

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

263269 haskell-lsp-types,

264270 network-uri,

265271 lens,

266− lsp-test >= 0.8,

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

267273 parser-combinators,

268274 QuickCheck,

269275 quickcheck-instances,

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

296302 TupleSections

297303 TypeApplications

298304 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: {stack: {component: "ghcide:lib"}}

1+cradle:

2+ cabal:

3+ - path: "./src"

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)

9090parseModule

9191 :: IdeOptions

9292 -> HscEnv

93+ -> [PackageName]

9394 -> FilePath

9495 -> Maybe SB.StringBuffer

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

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

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

9798 fmap (either (, Nothing) id) $

9899 evalGhcEnv env $ runExceptT $ do

99100 (contents, dflags) <- preprocessor filename mbContents

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

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

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

102103

103104

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

499500 :: GhcMonad m

500501 => (GHC.ParsedSource -> IdePreprocessedSource)

501502 -> DynFlags -- ^ flags to use

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

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

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

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

505−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

506508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

508510#if MIN_GHC_API_VERSION(8,10,0)

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

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

535537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539+ let parsed' = removePackageImports comp_pkgs parsed

537540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

538− ms <- getModSummaryFromBuffer filename dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

539542 let pm =

540543 ParsedModule {

541544 pm_mod_summary = ms

542− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

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

544547 , pm_annotations = hpm_annotations

545548 }

546549 warnings = diagFromErrMsgs "parser" dflags warns

547550 pure (warnings ++ preproc_warnings, pm)

548551

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+

549567loadHieFile :: FilePath -> IO GHC.HieFile

550568loadHieFile f = do

551569 u <- mkSplitUniqSupply 'a'

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

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

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs

95− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

96− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

97− , Just True <- _dynamicRegistration

98− = fileExistsRulesFast getLspId vfs

99− | otherwise = do

100− logger <- logger <$> getShakeExtrasRules

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

102− fileExistsRulesSlow 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

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

101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

102+ , Just True <- _dynamicRegistration

103+ -> fileExistsRulesFast getLspId vfs

104+ | otherwise -> do

105+ logger <- logger <$> getShakeExtrasRules

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

107+ fileExistsRulesSlow vfs

103108

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

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

106−fileExistsRulesFast getLspId vfs = do

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

111+fileExistsRulesFast getLspId vfs =

108112 defineEarlyCutoff $ \GetFileExists file -> do

109113 isWf <- isWorkspaceFile file

110114 if isWf

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

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

22-- SPDX-License-Identifier: Apache-2.0

33module Development.IDE.Core.PositionMapping

44 ( PositionMapping(..)

5+ , fromCurrentPosition

6+ , toCurrentPosition

7+ , PositionDelta(..)

8+ , addDelta

9+ , mkDelta

510 , toCurrentRange

611 , fromCurrentRange

712 , applyChange

8− , idMapping

13+ , zeroMapping

914 -- toCurrent and fromCurrent are mainly exposed for testing

1015 , toCurrent

1116 , fromCurrent

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

1419import Control.Monad

1520import qualified Data.Text as T

1621import Language.Haskell.LSP.Types

22+import Data.List

1723

18−data PositionMapping = PositionMapping

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

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

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

25+data PositionDelta = PositionDelta

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

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

2128 }

2229

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+

2341toCurrentRange :: PositionMapping -> Range -> Maybe Range

2442toCurrentRange mapping (Range a b) =

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

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

2846fromCurrentRange mapping (Range a b) =

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

3048

31−idMapping :: PositionMapping

32−idMapping = PositionMapping Just Just

49+zeroMapping :: PositionMapping

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)

3371

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

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

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

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

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

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

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

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

3876 }

3977applyChange posMapping _ = posMapping

4078

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

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

2828

2929import Fingerprint

3030

31−import Data.Binary

32−import Data.Bifunctor (second)

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

32+import Data.Bifunctor (first, second)

3333import Control.Monad.Extra

3434import Control.Monad.Trans.Class

3535import Control.Monad.Trans.Maybe

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

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

4747import Development.IDE.GHC.Util

4848import Development.IDE.GHC.WithDynFlags

49−import Data.Coerce

5049import Data.Either.Extra

5150import Data.Maybe

5251import Data.Foldable

5352import qualified Data.IntMap.Strict as IntMap

5453import Data.IntMap.Strict (IntMap)

55−import qualified Data.IntSet as IntSet

5654import Data.List

5755import Data.Ord

5856import qualified Data.Set as Set

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

6159import Development.Shake hiding (Diagnostic)

6260import Development.IDE.Core.RuleTypes

6361import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

6463

6564import qualified GHC.LanguageExtensions as LangExt

6665import HscTypes

66+import PackageConfig

6767import DynFlags (gopt_set, xopt)

6868import GHC.Generics(Generic)

6969

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

7171import Development.IDE.Core.Service

7272import Development.IDE.Core.Shake

73−import Development.Shake.Classes

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

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

7575import Data.ByteString (ByteString)

7676import Control.Concurrent.Async (concurrently)

7777

78+import Control.Monad.State

79+

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

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

8082-- warnings while also producing a result.

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

141143 hie_f = ml_hie_file $ ms_location ms

142144 mbHieTimestamp <- use GetModificationTime normal_hie_f

143145 srcTimestamp <- use_ GetModificationTime f

144−

145146 let isUpToDate

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

147148 | otherwise = False

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

191192

192193getParsedModuleRule :: Rules ()

193194getParsedModuleRule = 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)

195200 opt <- getIdeOptions

196201 (_, contents) <- getFileContents file

197202

198203 let dflags = hsc_dflags hsc

199− mainParse = getParsedModuleDefinition hsc opt file contents

204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

200205

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

202207 if gopt Opt_Haddock dflags

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

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

207212 haddockParse = do

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

209− getParsedModuleDefinition hscHaddock opt file contents

214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

210215 return diagsHaddock

211216

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

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

217222

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

219224

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

221−getParsedModuleDefinition packageState opt file contents = do

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

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

226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do

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

223228 case res of

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

225230 Just (contents, modu) -> do

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

233238 define $ \GetLocatedImports file -> do

234239 ms <- use_ GetModSummary file

235240 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

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

238245 opt <- getIdeOptions

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

241248 case diagOrImp of

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

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

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

251258 Nothing -> pure (concat diags, Nothing)

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

253260

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+

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

255271-- imports recursively.

256−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

257−rawDependencyInformation f = do

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

259− (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap

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

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

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

273+rawDependencyInformation fs = do

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

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

263276 return (rdi { rawBootMap = bm })

264277 where

265− go fs (rawDepInfo, ss) =

266− case IntSet.minView fs of

267− -- Queue is empty

268− Nothing -> pure (rawDepInfo, ss)

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

270− Just (f, fs) -> do

271− let fId = FilePathId f

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

273− case importsOrErr of

274− Nothing ->

275− -- File doesn’t parse

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

277− in go fs (rawDepInfo', ss)

278− Just (modImports, pkgImports) -> do

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

280− -> (a, Maybe ArtifactsLocation)

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

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

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

284− Just path ->

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

286− ss' = if isBootLocation path

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

288− else ss

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

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

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

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

293− let newFiles =

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

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

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

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

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

299−

300−

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

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

280+ go f = do

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

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

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

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

292+ importsOrErr <- lift $ use GetLocatedImports f

293+ case importsOrErr of

294+ Nothing -> do

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

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

299+ return fId

300+ Just (modImports, pkgImports) -> do

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

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

303+ let (no_file, with_file) = splitImports modImports

304+ (mns, ls) = unzip with_file

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

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

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 =

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

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

328+ else ss))

329+

330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331+ getFreshFid al = do

332+ (rawDepInfo, ss) <- get

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

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

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

336+ put (rawDepInfo', ss)

337+ return fId

338+

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

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

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

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)

301346

302347 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

303348 if not artifactIsSource

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

315360getDependencyInformationRule :: Rules ()

316361getDependencyInformationRule =

317362 define $ \GetDependencyInformation file -> do

318− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

319364 pure ([], Just $ processDependencyInformation rawDepInfo)

320365

321366reportImportCyclesRule :: Rules ()

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

426471 setPriority priorityTypeCheck

427472 IdeOptions { optDefer = defer } <- getIdeOptions

428473

429− liftIO $ do

474+ addUsageDependencies $ liftIO $ do

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

431476 case res of

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

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

440485 uses_th_qq dflags =

441486 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

442487

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+

443500

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

445502generateCore runSimplifier file = do

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

472529instance NFData GhcSessionIO

473530instance Binary GhcSessionIO

474531

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

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

476533instance Show GhcSessionFun where show _ = "GhcSessionFun"

477534instance NFData GhcSessionFun where rnf !_ = ()

478535

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

482539 defineNoFile $ \GhcSessionIO -> do

483540 opts <- getIdeOptions

484541 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

485546 defineEarlyCutoff $ \GhcSession file -> do

486547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

487549 val <- fun $ fromNormalizedFilePath file

550+

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

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

490562

491563getHiFileRule :: Rules ()

492564getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

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

500572 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

501573 _ -> ml_hi_file $ ms_location ms

502574

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−

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

519577 Just deps -> do

520578 gotHiFile <- getFileExists hiFile

521579 if not gotHiFile

522− then do

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

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

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

525581 else do

526582 hiVersion <- use_ GetModificationTime hiFile

527583 modVersion <- use_ GetModificationTime f

528584 let sourceModified = modificationTime hiVersion < modificationTime modVersion

529585 if sourceModified

530586 then do

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

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

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

533588 else do

534589 session <- hscEnv <$> use_ GhcSession f

535590 r <- liftIO $ loadInterface session ms deps

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

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

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

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

572631 opt <- getIdeOptions

573632 (_, contents) <- getFileContents f

574633 -- Embed --haddocks in the interface file

575634 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

577636 case mb_pm of

578637 Nothing -> return (diags, Nothing)

579638 Just pm -> do

src/Development/IDE/Core/Shake.hs+38−27

@@ -53,7 +53,7 @@ import qualified Data.ByteString.Char8 as BS

5353import Data.Dynamic

5454import Data.Maybe

5555import Data.Map.Strict (Map)

56−import Data.List.Extra (foldl', partition, takeEnd)

56+import Data.List.Extra (partition, takeEnd)

5757import qualified Data.Set as Set

5858import qualified Data.Text as T

5959import Data.Traversable (for)

@@ -69,7 +69,7 @@ import Development.IDE.Types.Location

6969import Development.IDE.Types.Options

7070import Control.Concurrent.Async

7171import Control.Concurrent.Extra

72−import Control.Exception

72+import Control.Exception.Extra

7373import Control.DeepSeq

7474import System.Time.Extra

7575import Data.Typeable

@@ -97,9 +97,11 @@ data ShakeExtras = ShakeExtras

9797 ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

9898 -- ^ This represents the set of diagnostics that we have published.

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

101101 -- ^ Map from a text document version to a PositionMapping that describes how to map

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

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

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

105107 }

@@ -124,14 +126,19 @@ addIdeGlobal x = do

124126addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

125127addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

126128 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

128130 Nothing -> return $! HMap.insert ty (toDyn x) mp

129131

130132

131133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

132134getIdeGlobalExtras ShakeExtras{globals} = do

133− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

134− return $ fromDyn x $ error "Serious error, corrupt globals"

135+ let typ = typeRep (Proxy :: Proxy a)

136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar 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

135142

136143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

137144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -154,7 +161,7 @@ instance Eq Key where

154161 | otherwise = False

155162

156163instance Hashable Key where

157− hashWithSalt salt (Key key) = hashWithSalt salt key

164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

158165

159166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

160167-- and a value is in the Maybe. For operations that throw an error you

@@ -164,9 +171,6 @@ instance Hashable Key where

164171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

165172-- errors but still failed.

166173--

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)

170174

171175data Value v

172176 = Succeeded TextDocumentVersion v

@@ -201,12 +205,12 @@ valueVersion = \case

201205 Failed -> Nothing

202206

203207mappingForVersion

204− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping)

208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

205209 -> NormalizedFilePath

206210 -> TextDocumentVersion

207211 -> PositionMapping

208212mappingForVersion allMappings file ver =

209− fromMaybe idMapping $

213+ maybe zeroMapping snd $

210214 Map.lookup ver =<<

211215 HMap.lookup (filePathToUri' file) allMappings

212216

@@ -509,12 +513,10 @@ instance Show k => Show (Q k) where

509513

510514-- | Invariant: the 'v' must be in normal form (fully evaluated).

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

515517 deriving Show

516518

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` ()

518520

519521-- In the Shake database we only store one type of key/result pairs,

520522-- namely Q (question) / A (answer).

@@ -524,19 +526,22 @@ type instance RuleResult (Q k) = A (RuleResult k)

524526-- | Return up2date results. Stale results will be ignored.

525527uses :: IdeRule k v

526528 => 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)

528530

529531-- | Return the last computed result which might be stale.

530532usesWithStale :: IdeRule k v

531533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

532534usesWithStale 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)

534536 zipWithM lastValue files values

535537

536538

537539withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

538540withProgress var file = actionBracket (f succ) (const $ f pred) . const

539− where f shift = modifyVar_ var $ return . HMap.alter (Just . shift . fromMaybe 0) file

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.

544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x

540545

541546

542547defineEarlyCutoff

@@ -553,7 +558,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

553558 case v of

554559 -- No changes in the dependencies and we have

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

557562 _ -> return Nothing

558563 _ -> return Nothing

559564 case val of

@@ -584,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

584589 return $ RunResult

585590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

586591 (encodeShakeValue bs) $

587− A res bs

592+ A res

588593

589594

590595-- | Rule type, input file

@@ -738,7 +743,7 @@ publishDiagnosticsNotification uri diags =

738743newtype Priority = Priority Double

739744

740745setPriority :: Priority -> Action ()

741−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

742747

743748sendEvent :: LSP.FromServerMessage -> Action ()

744749sendEvent e = do

@@ -764,7 +769,7 @@ instance Binary GetModificationTime

764769type instance RuleResult GetModificationTime = FileVersion

765770

766771data FileVersion

767− = VFSVersion Int

772+ = VFSVersion !Int

768773 | ModificationTime

769774 !Int -- ^ Large unit (platform dependent, do not make assumptions)

770775 !Int -- ^ Small unit (platform dependent, do not make assumptions)

@@ -828,11 +833,17 @@ filterVersionMap =

828833 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

829834

830835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

831−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

832837 modifyVar_ positionMapping $ \allMappings -> do

833838 let uri = toNormalizedUri _uri

834839 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

835− let updatedMapping =

836− Map.insert _version idMapping $

837− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

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

846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)

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

2626 includePathsQuote,

2727 addIncludePathsQuote,

2828 getModuleHash,

29+ getPackageName,

2930 pattern DerivD,

3031 pattern ForD,

3132 pattern InstD,

@@ -37,6 +38,7 @@ module Development.IDE.GHC.Compat(

3738 GHC.ModLocation,

3839 Module.addBootSuffix,

3940 pattern ModLocation,

41+ getConArgs,

4042

4143 module GHC

4244 ) where

@@ -46,9 +48,15 @@ import DynFlags

4648import FieldLabel

4749import Fingerprint (Fingerprint)

4850import qualified Module

51+import Packages

4952

5053import qualified GHC

51−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)

54+import GHC hiding (

55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation

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

57+ , getConArgs

58+#endif

59+ )

5260import qualified HeaderInfo as Hdr

5361import Avail

5462import ErrUtils (ErrorMessages)

@@ -289,3 +297,13 @@ getModuleHash = mi_mod_hash . mi_final_exts

289297#else

290298getModuleHash = mi_mod_hash

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

5656-- | Produce a GHC-style error from a source span and a message.

5757diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

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

6061 | Just sev <- [toDSeverity $ errMsgSeverity e]]

6162

6263

src/Development/IDE/GHC/Util.hs+16−8

@@ -8,6 +8,7 @@ module Development.IDE.GHC.Util(

88 modifyDynFlags,

99 evalGhcEnv,

1010 runGhcEnv,

11+ deps,

1112 -- * GHC wrappers

1213 prettyPrint,

1314 printRdrName,

@@ -64,7 +65,7 @@ import Packages (getPackageConfigMap, lookupPackage')

6465import SrcLoc (mkRealSrcLoc)

6566import FastString (mkFastString)

6667import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

67−import Module (moduleNameSlashes)

68+import Module (moduleNameSlashes, InstalledUnitId)

6869import OccName (parenSymOcc)

6970import RdrName (nameRdrName, rdrNameOcc)

7071

@@ -166,6 +167,9 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

166167-- if they are created with the same call to 'newHscEnvEq'.

167168data HscEnvEq

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

169173 | GhcVersionMismatch { compileTime :: !Version

170174 , runTime :: !Version

171175 }

@@ -175,7 +179,7 @@ hscEnv :: HscEnvEq -> HscEnv

175179hscEnv = either error id . hscEnv'

176180

177181hscEnv' :: HscEnvEq -> Either String HscEnv

178−hscEnv' (HscEnvEq _ x) = Right x

182+hscEnv' (HscEnvEq _ x _) = Right x

179183hscEnv' GhcVersionMismatch{..} = Left $

180184 unwords

181185 ["ghcide compiled against GHC"

@@ -185,25 +189,29 @@ hscEnv' GhcVersionMismatch{..} = Left $

185189 ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

186190 ]

187191

192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193+deps (HscEnvEq _ _ u) = u

194+deps GhcVersionMismatch{} = []

195+

188196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

189−newHscEnvEq :: HscEnv -> IO HscEnvEq

190−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

191199

192200instance Show HscEnvEq where

193− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

194202 show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

195203

196204instance Eq HscEnvEq where

197− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

198206 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

199207 _ == _ = False

200208

201209instance 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` ()

203211 rnf GhcVersionMismatch{} = rnf runTime

204212

205213instance Hashable HscEnvEq where

206− hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

207215 hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

208216

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

6262 -- that module on disk (if we found it)

6363 , packageImports :: !(Set InstalledUnitId)

6464 -- ^ Transitive package dependencies unioned for all imports.

65− }

65+ } deriving Show

6666

6767-- | For processing dependency information, we need lots of maps and sets of

6868-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

@@ -128,7 +128,7 @@ data RawDependencyInformation = RawDependencyInformation

128128 -- need to add edges between .hs-boot and .hs so that the .hs files

129129 -- appear later in the sort.

130130 , rawBootMap :: !BootIdMap

131− }

131+ } deriving Show

132132

133133pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

134134pkgDependencies RawDependencyInformation{..} =

src/Development/IDE/Import/FindImports.hs+40−14

@@ -8,17 +8,18 @@ module Development.IDE.Import.FindImports

88 ( locateModule

99 , Import(..)

1010 , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

1112 , isBootLocation

13+ , mkImportDirs

1214 ) where

1315

1416import Development.IDE.GHC.Error as ErrUtils

1517import Development.IDE.GHC.Orphans()

1618import Development.IDE.Types.Diagnostics

1719import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

1821-- GHC imports

19−import DynFlags

2022import FastString

21−import GHC

2223import qualified Module as M

2324import Packages

2425import Outputable (showSDoc, ppr, pprPanic)

@@ -29,6 +30,8 @@ import Control.DeepSeq

2930import Control.Monad.Extra

3031import Control.Monad.IO.Class

3132import System.FilePath

33+import DriverPhases

34+import Data.Maybe

3235

3336data Import

3437 = FileImport !ArtifactsLocation

@@ -52,58 +55,81 @@ instance NFData Import where

5255 rnf (FileImport x) = rnf x

5356 rnf (PackageImport x) = rnf x

5457

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+

5564

5665-- | locate a module in the file system. Where we go from *daml to Haskell

5766locateModuleFile :: MonadIO m

58− => DynFlags

67+ => [[FilePath]]

5968 -> [String]

6069 -> (NormalizedFilePath -> m Bool)

6170 -> Bool

6271 -> ModuleName

6372 -> m (Maybe NormalizedFilePath)

64−locateModuleFile dflags exts doesExist isSource modName = do

65− let candidates =

73+locateModuleFile import_dirss exts doesExist isSource modName = do

74+ let candidates import_dirs =

6675 [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

67− | prefix <- importPaths dflags, ext <- exts]

68− findM doesExist candidates

76+ | prefix <- import_dirs , ext <- exts]

77+ findM doesExist (concatMap candidates import_dirss)

6978 where

7079 maybeBoot ext

7180 | isSource = ext ++ "-boot"

7281 | otherwise = ext

7382

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+

7490-- | locate a module in either the file system or the package database. Where we go from *daml to

7591-- Haskell

7692locateModule

7793 :: MonadIO m

7894 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

7996 -> [String]

8097 -> (NormalizedFilePath -> m Bool)

8198 -> Located ModuleName

8299 -> Maybe FastString

83100 -> Bool

84101 -> m (Either [FileDiagnostic] Import)

85−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

86103 case mbPkgName of

87104 -- "this" means that we should only look in the current package

88105 Just "this" -> do

89− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

90− case mbFile of

91− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

92− Just file -> toModLocation file

106+ lookupLocal [importPaths dflags]

93107 -- if a package name is given we only go look for a package

94− Just _pkgName -> lookupInPackageDB dflags

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

111+ | otherwise -> lookupInPackageDB dflags

95112 Nothing -> do

96113 -- first try to find the module as a file. If we can't find it try to find it in the package

97114 -- database.

98− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

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.

118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

99119 case mbFile of

100120 Nothing -> lookupInPackageDB dflags

101121 Just file -> toModLocation file

102122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

103124 toModLocation file = liftIO $ do

104125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

105126 return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

106127

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

107133

108134 lookupInPackageDB dfs =

109135 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

144144 Response x@RequestMessage{_id, _params} wrap act ->

145145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146146 \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

149149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151151 \(res, newReq) -> do

152152 case res of

153− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

154− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155155 whenJust newReq $ \(rm, newReqParams) -> do

156156 reqId <- getNextReqId

157157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175175 Left () -> do

176176 logDebug (ideLogger ide) $ T.pack $

177177 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

179− Just $ ResponseError RequestCancelled "" Nothing

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179+ $ ResponseError RequestCancelled "" Nothing

180180 Right res -> k res

181181 ) $ \(e :: SomeException) -> do

182182 logError (ideLogger ide) $ T.pack $

183183 "Unexpected exception on request, please report!\n" ++

184184 "Message: " ++ show msg ++ "\n" ++

185185 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

187− Just $ ResponseError InternalError (T.pack $ show e) Nothing

186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187+ $ ResponseError InternalError (T.pack $ show e) Nothing

188188

189189initializeRequestHandler :: PartialHandlers config

190190initializeRequestHandler = 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 =

108108 { _name = showRdrName n

109109 , _kind = SkConstructor

110110 , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

111112 }

112113 | L l x <- dd_cons

113114 , L l' n <- getConNames x

114115 ]

115116 }

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

116128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

117129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

118130 , _kind = SkTypeParameter

src/Development/IDE/Types/Diagnostics.hs+4

@@ -6,6 +6,7 @@ module Development.IDE.Types.Diagnostics (

66 LSP.Diagnostic(..),

77 ShowDiagnostic(..),

88 FileDiagnostic,

9+ IdeResult,

910 LSP.DiagnosticSeverity(..),

1011 DiagnosticStore,

1112 List(..),

@@ -31,6 +32,9 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

3132

3233import Development.IDE.Types.Location

3334

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)

3438

3539ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

3640ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

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

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

1212 , clientSupportsProgress

1313 , IdePkgLocationOptions(..)

1414 , defaultIdeOptions

15+ , IdeResult

1516 ) where

1617

1718import Development.Shake

@@ -20,12 +21,13 @@ import GHC hiding (parseModule, typecheckModule)

2021import GhcPlugins as GHC hiding (fst3, (<>))

2122import qualified Language.Haskell.LSP.Types.Capabilities as LSP

2223import qualified Data.Text as T

24+import Development.IDE.Types.Diagnostics

2325

2426data IdeOptions = IdeOptions

2527 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

2628 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

2729 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: Action (FilePath -> Action HscEnvEq)

30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

2931 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

3032 -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

3133 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

@@ -58,8 +60,6 @@ data IdeOptions = IdeOptions

5860 -- features such as diagnostics and go-to-definition, in

5961 -- situations in which they would become unavailable because of

6062 -- the presence of type errors, holes or unbound variables.

61− , optInterfaceLoadingDiagnostics :: Bool

62− -- ^ Generate Info-level diagnostics to report interface loading actions

6363 }

6464

6565data IdePreprocessedSource = IdePreprocessedSource

@@ -78,7 +78,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

7878clientSupportsProgress caps = IdeReportProgress $ Just True ==

7979 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

8080

81−defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

8282defaultIdeOptions session = IdeOptions

8383 {optPreprocessor = IdePreprocessedSource [] []

8484 ,optGhcSession = session

@@ -93,7 +93,6 @@ defaultIdeOptions session = IdeOptions

9393 ,optKeywords = haskellKeywords

9494 ,optDefer = IdeDefer True

9595 ,optTesting = False

96− ,optInterfaceLoadingDiagnostics = False

9796 }

9897

9998

stack-ghc-lib.yaml+4−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-16

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.21.0.0

6−- haskell-lsp-types-0.21.0.0

7−- lsp-test-0.10.2.0

8−- hie-bios-0.4.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.10.3.0

8+- hie-bios-0.5.0

99- ghc-lib-parser-8.8.1

1010- ghc-lib-8.8.1

1111- fuzzy-0.1.0.0

stack.yaml+4−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.21.0.0

6−- haskell-lsp-types-0.21.0.0

7−- lsp-test-0.10.2.0

8−- hie-bios-0.4.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.11.0.1

8+- hie-bios-0.5.0

99- fuzzy-0.1.0.0

1010- regex-pcre-builtin-0.95.1.1.8.43

1111- regex-base-0.94.0.0

stack810.yaml+4−3

@@ -4,10 +4,11 @@ allow-newer: true

44packages:

55- .

66extra-deps:

7−- haskell-lsp-0.21.0.0

8−- haskell-lsp-types-0.21.0.0

9−- lsp-test-0.10.2.0

7+- haskell-lsp-0.22.0.0

8+- haskell-lsp-types-0.22.0.0

9+- lsp-test-0.11.0.1

1010- ghc-check-0.3.0.1

11+- hie-bios-0.5.0

1112

1213# for ghc-8.10

1314- Cabal-3.2.0.0

stack84.yaml+4−4

@@ -5,13 +5,13 @@ packages:

55extra-deps:

66- aeson-1.4.6.0

77- base-orphans-0.8.2

8−- haskell-lsp-0.21.0.0

9−- haskell-lsp-types-0.21.0.0

10−- lsp-test-0.10.2.0

8+- haskell-lsp-0.22.0.0

9+- haskell-lsp-types-0.22.0.0

10+- lsp-test-0.11.0.1

1111- rope-utf16-splay-0.3.1.0

1212- filepattern-0.1.1

1313- js-dgtable-0.5.2

14−- hie-bios-0.4.0

14+- hie-bios-0.5.0

1515- fuzzy-0.1.0.0

1616- shake-0.18.5

1717- time-compat-1.9.2.2

stack88.yaml+4−3

@@ -2,9 +2,10 @@ resolver: nightly-2020-02-13

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.21.0.0

6−- haskell-lsp-types-0.21.0.0

7−- lsp-test-0.10.2.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.11.0.1

88- ghc-check-0.3.0.1

9+- hie-bios-0.5.0

910nix:

1011 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 #-}

12{- HLINT ignore -}

23module Testing ( module Testing ) where

34import Data.Text (Text, pack)

45import Foo (Bar, foo)

7−

88data TypeConstructor = DataConstructor

99 { fff :: Text

1010 , 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 @@

1010module Main (main) where

1111

1212import Control.Applicative.Combinators

13−import Control.Exception (catch)

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

1415import Control.Monad

1516import Control.Monad.IO.Class (liftIO)

1617import Data.Aeson (FromJSON, Value)

@@ -27,14 +28,14 @@ import Development.IDE.Test

2728import Development.IDE.Test.Runfiles

2829import Development.IDE.Types.Location

2930import Development.Shake (getDirectoryFilesIO)

30−import qualified Language.Haskell.LSP.Test as LSPTest

31−import Language.Haskell.LSP.Test hiding (openDoc')

31+import Language.Haskell.LSP.Test

3232import Language.Haskell.LSP.Messages

3333import Language.Haskell.LSP.Types

3434import Language.Haskell.LSP.Types.Capabilities

35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

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

3637import Network.URI

37−import System.Environment.Blank (setEnv)

38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)

3839import System.FilePath

3940import System.IO.Extra

4041import System.Directory

@@ -48,31 +49,35 @@ import Test.Tasty.QuickCheck

4849import Data.Maybe

4950

5051main :: IO ()

51−main = defaultMainWithRerun $ testGroup "HIE"

52− [ testSession "open close" $ do

53− doc <- openDoc' "Testing.hs" "haskell" ""

54− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

55− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

56− closeDoc doc

57− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

58− , initializeResponseTests

59− , completionTests

60− , cppTests

61− , diagnosticTests

62− , codeActionTests

63− , codeLensesTests

64− , outlineTests

65− , findDefinitionAndHoverTests

66− , pluginTests

67− , preprocessorTests

68− , thTests

69− , safeTests

70− , unitTests

71− , haddockTests

72− , positionMappingTests

73− , watchedFilesTests

74− , cradleTests

75− ]

52+main = do

53+ -- We mess with env vars so run single-threaded.

54+ setEnv "TASTY_NUM_THREADS" "1" True

55+ defaultMainWithRerun $ testGroup "HIE"

56+ [ testSession "open close" $ do

57+ doc <- createDoc "Testing.hs" "haskell" ""

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

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

60+ closeDoc doc

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

62+ , initializeResponseTests

63+ , completionTests

64+ , cppTests

65+ , diagnosticTests

66+ , codeActionTests

67+ , codeLensesTests

68+ , outlineTests

69+ , findDefinitionAndHoverTests

70+ , pluginTests

71+ , preprocessorTests

72+ , thTests

73+ , safeTests

74+ , unitTests

75+ , haddockTests

76+ , positionMappingTests

77+ , watchedFilesTests

78+ , cradleTests

79+ , dependentFileTest

80+ ]

7681

7782initializeResponseTests :: TestTree

7883initializeResponseTests = withResource acquire release tests where

@@ -133,7 +138,7 @@ initializeResponseTests = withResource acquire release tests where

133138

134139

135140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

136− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

137142 innerCaps _ = error "this test only expects inner capabilities"

138143

139144 acquire :: IO InitializeResponse

@@ -147,7 +152,7 @@ diagnosticTests :: TestTree

147152diagnosticTests = testGroup "diagnostics"

148153 [ testSessionWait "fix syntax error" $ do

149154 let content = T.unlines [ "module Testing wher" ]

150− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

151156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

152157 let change = TextDocumentContentChangeEvent

153158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -158,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"

158163 expectDiagnostics [("Testing.hs", [])]

159164 , testSessionWait "introduce syntax error" $ do

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

161− doc <- openDoc' "Testing.hs" "haskell" content

166+ doc <- createDoc "Testing.hs" "haskell" content

162167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

163168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

164169 let change = TextDocumentContentChangeEvent

@@ -176,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

176181 , "bar :: Int -> Int -> Int"

177182 , "bar a b = cd + b"

178183 ]

179− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

180185 expectDiagnostics

181186 [ ( "Testing.hs"

182187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -190,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

190195 , "foo :: Int -> String -> Int"

191196 , "foo a b = a + b"

192197 ]

193− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

194199 expectDiagnostics

195200 [ ( "Testing.hs"

196201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -202,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

202207 , "foo :: Int -> String"

203208 , "foo a = _ a"

204209 ]

205− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

206211 expectDiagnostics

207212 [ ( "Testing.hs"

208213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -224,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

224229 [ ("A.hs", [(DsError, (2,4), aMessage)])

225230 , ("B.hs", [(DsError, (3,4), bMessage)])]

226231 deferralTest title binding msg = testSessionWait title $ do

227− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

228− _ <- openDoc' "B.hs" "haskell" sourceB

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

233+ _ <- createDoc "B.hs" "haskell" sourceB

229234 expectDiagnostics $ expectedDs msg

230235 in

231236 [ deferralTest "type error" "True" "Couldn't match expected type"

232237 , deferralTest "typed hole" "_" "Found hole"

233238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

234− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

235239 ]

236240

237241 , testSessionWait "remove required module" $ do

238242 let contentA = T.unlines [ "module ModuleA where" ]

239− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

240244 let contentB = T.unlines

241245 [ "module ModuleB where"

242246 , "import ModuleA"

243247 ]

244− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

245249 let change = TextDocumentContentChangeEvent

246250 { _range = Just (Range (Position 0 0) (Position 0 20))

247251 , _rangeLength = Nothing

@@ -254,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"

254258 [ "module ModuleB where"

255259 , "import ModuleA"

256260 ]

257− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

258262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

259263 let contentA = T.unlines [ "module ModuleA where" ]

260− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

261265 expectDiagnostics [("ModuleB.hs", [])]

262266 , testSessionWait "add missing module (non workspace)" $ do

263267 let contentB = T.unlines

264268 [ "module ModuleB where"

265269 , "import ModuleA"

266270 ]

267− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

268272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

269273 let contentA = T.unlines [ "module ModuleA where" ]

270− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

271275 expectDiagnostics [("/tmp/ModuleB.hs", [])]

272276 , testSessionWait "cyclic module dependency" $ do

273277 let contentA = T.unlines

@@ -278,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

278282 [ "module ModuleB where"

279283 , "import ModuleA"

280284 ]

281− _ <- openDoc' "ModuleA.hs" "haskell" contentA

282− _ <- openDoc' "ModuleB.hs" "haskell" contentB

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

283287 expectDiagnostics

284288 [ ( "ModuleA.hs"

285289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -300,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

300304 let contentBboot = T.unlines

301305 [ "module ModuleB where"

302306 ]

303− _ <- openDoc' "ModuleA.hs" "haskell" contentA

304− _ <- openDoc' "ModuleB.hs" "haskell" contentB

305− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

306310 expectDiagnostics []

307311 , testSessionWait "correct reference used with hs-boot" $ do

308312 let contentB = T.unlines

@@ -324,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

324328 -- resolved to the hs-boot file

325329 , "y = x"

326330 ]

327− _ <- openDoc' "ModuleB.hs" "haskell" contentB

328− _ <- openDoc' "ModuleA.hs" "haskell" contentA

329− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

330− _ <- openDoc' "ModuleC.hs" "haskell" contentC

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

331335 expectDiagnostics []

332336 , testSessionWait "redundant import" $ do

333337 let contentA = T.unlines ["module ModuleA where"]

@@ -336,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

336340 , "module ModuleB where"

337341 , "import ModuleA"

338342 ]

339− _ <- openDoc' "ModuleA.hs" "haskell" contentA

340− _ <- openDoc' "ModuleB.hs" "haskell" contentB

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

341345 expectDiagnostics

342346 [ ( "ModuleB.hs"

343347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -359,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

359363 , "wrong1 = ThisList.map"

360364 , "wrong2 = BaseList.x"

361365 ]

362− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

363− _ <- openDoc' "Main.hs" "haskell" mainContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

364368 expectDiagnostics

365369 [ ( "Main.hs"

366370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -375,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

375379 , "foo :: Ord a => a -> Int"

376380 , "foo a = 1"

377381 ]

378− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

379383 expectDiagnostics

380384 [ ( "Foo.hs"

381385 -- The test is to make sure that warnings contain unqualified names

@@ -426,13 +430,32 @@ diagnosticTests = testGroup "diagnostics"

426430 , "foo :: Int"

427431 , "foo = 1 {-|-}"

428432 ]

429− _ <- openDoc' "Foo.hs" "haskell" fooContent

433+ _ <- createDoc "Foo.hs" "haskell" fooContent

430434 expectDiagnostics

431435 [ ( "Foo.hs"

432436 , [(DsError, (2, 8), "Parse error on input")

433437 ]

434438 )

435439 ]

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

436459 ]

437460

438461codeActionTests :: TestTree

@@ -459,29 +482,25 @@ watchedFilesTests :: TestTree

459482watchedFilesTests = testGroup "watched files"

460483 [ testSession' "workspace files" $ \sessionDir -> do

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

463486 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

464487

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

466489 -- - /path-to-workspace/WatchedFilesMissingModule.hs

467490 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

468− -- - WatchedFilesMissingModule.hs

469− -- - WatchedFilesMissingModule.lhs

470− -- - src/WatchedFilesMissingModule.hs

471− -- - src/WatchedFilesMissingModule.lhs

472− liftIO $ length watchedFileRegs @?= 6

491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

493+ liftIO $ length watchedFileRegs @?= 4

473494

474495 , testSession' "non workspace file" $ \sessionDir -> do

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

477498 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

478499

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

480501 -- - /path-to-workspace/WatchedFilesMissingModule.hs

481502 -- - /path-to-workspace/WatchedFilesMissingModule.lhs

482− -- - WatchedFilesMissingModule.hs

483− -- - WatchedFilesMissingModule.lhs

484− liftIO $ length watchedFileRegs @?= 4

503+ liftIO $ length watchedFileRegs @?= 2

485504

486505 -- TODO add a test for didChangeWorkspaceFolder

487506 ]

@@ -494,7 +513,7 @@ renameActionTests = testGroup "rename actions"

494513 , "foo :: Int -> Int"

495514 , "foo argName = argNme"

496515 ]

497− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

498517 _ <- waitForDiagnostics

499518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

500519 executeCodeAction action

@@ -512,7 +531,7 @@ renameActionTests = testGroup "rename actions"

512531 , "foo :: Maybe a -> [a]"

513532 , "foo = maybToList"

514533 ]

515− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

516535 _ <- waitForDiagnostics

517536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

518537 executeCodeAction action

@@ -530,7 +549,7 @@ renameActionTests = testGroup "rename actions"

530549 , "foo :: Char -> Char -> Char -> Char"

531550 , "foo argument1 argument2 argument3 = argumentX"

532551 ]

533− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

534553 _ <- waitForDiagnostics

535554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

536555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -542,7 +561,7 @@ renameActionTests = testGroup "rename actions"

542561 , "monus x y = max 0 (x - y)"

543562 , "foo x y = x `monnus` y"

544563 ]

545− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

546565 _ <- waitForDiagnostics

547566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

548567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -565,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

565584 , "func :: _"

566585 , "func x = x"

567586 ]

568− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

569588 _ <- waitForDiagnostics

570589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

571590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -585,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

585604 , "func :: _"

586605 , "func x y = x + y"

587606 ]

588− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

589608 _ <- waitForDiagnostics

590609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

591610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -608,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

608627 , " y = x * 2"

609628 , " in y"

610629 ]

611− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

612631 _ <- waitForDiagnostics

613632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

614633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -633,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

633652 let contentA = T.unlines

634653 [ "module ModuleA where"

635654 ]

636− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

637656 let contentB = T.unlines

638657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

639658 , "module ModuleB where"

@@ -641,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

641660 , "stuffB :: Integer"

642661 , "stuffB = 123"

643662 ]

644− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

645664 _ <- waitForDiagnostics

646665 [CACodeAction action@CodeAction { _title = actionTitle }]

647666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -659,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

659678 let contentA = T.unlines

660679 [ "module ModuleA where"

661680 ]

662− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

663682 let contentB = T.unlines

664683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

665684 , "module ModuleB where"

@@ -667,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

667686 , "stuffB :: Integer"

668687 , "stuffB = 123"

669688 ]

670− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

671690 _ <- waitForDiagnostics

672691 [CACodeAction action@CodeAction { _title = actionTitle }]

673692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -689,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

689708 , "stuffB = 123"

690709 , "stuffC = ()"

691710 ]

692− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

693712 let contentB = T.unlines

694713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

695714 , "module ModuleB where"

696715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

697716 , "main = print stuffB"

698717 ]

699− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

700719 _ <- waitForDiagnostics

701720 [CACodeAction action@CodeAction { _title = actionTitle }]

702721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -718,22 +737,18 @@ removeImportTests = testGroup "remove import actions"

718737 , "stuffB :: Integer"

719738 , "stuffB = 123"

720739 ]

721− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

722741 let contentB = T.unlines

723742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

724743 , "module ModuleB where"

725744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

726745 , "main = print A.stuffB"

727746 ]

728− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

729748 _ <- waitForDiagnostics

730749 [CACodeAction action@CodeAction { _title = actionTitle }]

731750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

732−#if MIN_GHC_API_VERSION(8,6,0)

733751 liftIO $ "Remove !!, <?> from import" @=? actionTitle

734−#else

735− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle

736−#endif

737752 executeCodeAction action

738753 contentAfterAction <- documentContents docB

739754 let expectedContentAfterAction = T.unlines

@@ -750,14 +765,14 @@ removeImportTests = testGroup "remove import actions"

750765 , "stuffB :: Integer"

751766 , "stuffB = 123"

752767 ]

753− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

754769 let contentB = T.unlines

755770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

756771 , "module ModuleB where"

757772 , "import ModuleA (A(..), stuffB)"

758773 , "main = print stuffB"

759774 ]

760− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

761776 _ <- waitForDiagnostics

762777 [CACodeAction action@CodeAction { _title = actionTitle }]

763778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -777,14 +792,14 @@ removeImportTests = testGroup "remove import actions"

777792 , "data D = A | B"

778793 , "data E = F"

779794 ]

780− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

781796 let contentB = T.unlines

782797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

783798 , "module ModuleB where"

784799 , "import ModuleA (D(A,B), E(F))"

785800 , "main = B"

786801 ]

787− docB <- openDoc' "ModuleB.hs" "haskell" contentB

802+ docB <- createDoc "ModuleB.hs" "haskell" contentB

788803 _ <- waitForDiagnostics

789804 [CACodeAction action@CodeAction { _title = actionTitle }]

790805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -925,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

925940 ]

926941 where

927942 template contentA contentB range expectedAction expectedContentB = do

928− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

929− docB <- openDoc' "ModuleB.hs" "haskell" contentB

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

930945 _ <- waitForDiagnostics

931946 CACodeAction action@CodeAction { _title = actionTitle } : _

932947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -976,7 +991,7 @@ suggestImportTests = testGroup "suggest import actions"

976991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

977992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

978993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

979− doc <- openDoc' "Test.hs" "haskell" before

994+ doc <- createDoc "Test.hs" "haskell" before

980995 _diags <- waitForDiagnostics

981996 let defLine = length imps + 1

982997 range = Range (Position defLine 0) (Position defLine maxBound)

@@ -1036,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

10361051 ]

10371052 where

10381053 template initialContent range expectedAction expectedContents = do

1039− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

10401055 _ <- waitForDiagnostics

10411056 CACodeAction action@CodeAction { _title = actionTitle } : _

10421057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1059,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

10591074 [""

10601075 ,"someOtherCode = ()"

10611076 ]

1062− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

10631078 _ <- waitForDiagnostics

10641079 CACodeAction action@CodeAction { _title = actionTitle } : _

10651080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1083,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

10831098 [""

10841099 ,"someOtherCode = ()"

10851100 ]

1086− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

10871102 _ <- waitForDiagnostics

10881103 CACodeAction action@CodeAction { _title = actionTitle } : _

10891104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1122,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

11221137 ]

11231138 where

11241139 template contentA contentB range expectedAction expectedContentB = do

1125− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1126− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

11271142 _diags <- waitForDiagnostics

11281143 CACodeAction action@CodeAction { _title = actionTitle } : _

11291144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1142,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

11421157 [ "module Testing where"

11431158 , "import Data.Mape"

11441159 ]

1145− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

11461161 _ <- waitForDiagnostics

11471162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

11481163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1179,7 +1194,7 @@ fillTypedHoleTests = let

11791194 newA newB newC = testSession (T.unpack actionTitle) $ do

11801195 let originalCode = sourceCode oldA oldB oldC

11811196 let expectedCode = sourceCode newA newB newC

1182− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

11831198 _ <- waitForDiagnostics

11841199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

11851200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

@@ -1227,7 +1242,7 @@ addSigActionTests = let

12271242 def >:: sig = testSession (T.unpack def) $ do

12281243 let originalCode = before def

12291244 let expectedCode = after' def sig

1230− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

12311246 _ <- waitForDiagnostics

12321247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

12331248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

@@ -1259,7 +1274,7 @@ addSigLensesTests = let

12591274 sigSession withMissing def sig = testSession (T.unpack def) $ do

12601275 let originalCode = before withMissing def

12611276 let expectedCode = after' withMissing def sig

1262− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

12631278 [CodeLens {_command = Just c}] <- getCodeLenses doc

12641279 executeCommand c

12651280 modifiedCode <- getDocumentEdit doc

@@ -1281,27 +1296,19 @@ addSigLensesTests = let

12811296 ]

12821297 ]

12831298

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

1293− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

12941301

1295− check (ExpectRange expectedRange) = do

1296− assertNDefinitionsFound 1 defs

1297− assertRangeCorrect (head defs) expectedRange

1298− check (ExpectLocation expectedLocation) = do

1299− assertNDefinitionsFound 1 defs

1300− liftIO $ head defs @?= expectedLocation

1301− check ExpectNoDefinitions = do

1302− assertNDefinitionsFound 0 defs

1303− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1304− check _ = pure () -- all other expectations not relevant to getDefinition

1302+ check (ExpectRange expectedRange) = do

1303+ assertNDefinitionsFound 1 defs

1304+ assertRangeCorrect (head defs) expectedRange

1305+ check (ExpectLocation expectedLocation) = do

1306+ assertNDefinitionsFound 1 defs

1307+ liftIO $ head defs @?= expectedLocation

1308+ check ExpectNoDefinitions = do

1309+ assertNDefinitionsFound 0 defs

1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1311+ check _ = pure () -- all other expectations not relevant to getDefinition

13051312

13061313 assertNDefinitionsFound :: Int -> [a] -> Session ()

13071314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1309,6 +1316,17 @@ findDefinitionAndHoverTests = let

13091316 assertRangeCorrect Location{_range = foundRange} expectedRange =

13101317 liftIO $ expectedRange @=? foundRange

13111318

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+

13121330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()

13131331 checkHover hover expectations = traverse_ check =<< expectations where

13141332

@@ -1353,7 +1371,8 @@ findDefinitionAndHoverTests = let

13531371

13541372 mkFindTests tests = testGroup "get"

13551373 [ testGroup "definition" $ mapMaybe fst tests

1356− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

13571376

13581377 test runDef runHover look expect = testM runDef runHover look (return expect)

13591378

@@ -1448,6 +1467,14 @@ findDefinitionAndHoverTests = let

14481467 broken = Just . (`xfail` "known broken")

14491468 no = const Nothing -- don't run this test at all

14501469

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+

14511478pluginTests :: TestTree

14521479pluginTests = (`xfail8101` "known broken (#556)")

14531480 $ testSessionWait "plugins" $ do

@@ -1464,7 +1491,7 @@ pluginTests = (`xfail8101` "known broken (#556)")

14641491 , "foo :: Int -> Int -> Int"

14651492 , "foo a b = a + c"

14661493 ]

1467− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

14681495 expectDiagnostics

14691496 [ ( "Testing.hs",

14701497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1491,7 +1518,7 @@ cppTests =

14911518 run $ expectError content (2, 1)

14921519 )

14931520 , testSessionWait "cpp-ghcide" $ do

1494− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

14951522 ["{-# LANGUAGE CPP #-}"

14961523 ,"main ="

14971524 ,"#ifdef __GHCIDE__"

@@ -1505,7 +1532,7 @@ cppTests =

15051532 where

15061533 expectError :: T.Text -> Cursor -> Session ()

15071534 expectError content cursor = do

1508− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

15091536 expectDiagnostics

15101537 [ ( "Testing.hs",

15111538 [(DsError, cursor, "error: unterminated")]

@@ -1521,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do

15211548 , "module Testing where"

15221549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

15231550 ]

1524− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

15251552 expectDiagnostics

15261553 [ ( "Testing.hs",

15271554 [(DsError, (2, 8), "Variable not in scope: z")]

@@ -1554,8 +1581,8 @@ safeTests =

15541581 ,"safeId = trustWorthyId"

15551582 ]

15561583

1557− _ <- openDoc' "A.hs" "haskell" sourceA

1558− _ <- openDoc' "B.hs" "haskell" sourceB

1584+ _ <- createDoc "A.hs" "haskell" sourceA

1585+ _ <- createDoc "B.hs" "haskell" sourceB

15591586 expectNoMoreDiagnostics 1 ]

15601587

15611588thTests :: TestTree

@@ -1583,8 +1610,8 @@ thTests =

15831610 "b :: Integer",

15841611 "b = $(litE $ IntegerL $ a) + n"

15851612 ]

1586− _ <- openDoc' "A.hs" "haskell" sourceA

1587− _ <- openDoc' "B.hs" "haskell" sourceB

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1614+ _ <- createDoc "B.hs" "haskell" sourceB

15881615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

15891616 , testSessionWait "newtype-closure" $ do

15901617 let sourceA =

@@ -1604,8 +1631,8 @@ thTests =

16041631 ,"import A"

16051632 ,"b :: Int"

16061633 ,"b = $( a )" ]

1607− _ <- openDoc' "A.hs" "haskell" sourceA

1608− _ <- openDoc' "B.hs" "haskell" sourceB

1634+ _ <- createDoc "A.hs" "haskell" sourceA

1635+ _ <- createDoc "B.hs" "haskell" sourceB

16091636 return ()

16101637 ]

16111638

@@ -1614,7 +1641,7 @@ completionTests

16141641 = testGroup "completion"

16151642 [ testSessionWait "variable" $ do

16161643 let source = T.unlines ["module A where", "f = hea"]

1617− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

16181645 compls <- getCompletions docId (Position 1 7)

16191646 liftIO $ map dropDocs compls @?=

16201647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1626,7 +1653,7 @@ completionTests

16261653 ]

16271654 , testSessionWait "constructor" $ do

16281655 let source = T.unlines ["module A where", "f = Tru"]

1629− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

16301657 compls <- getCompletions docId (Position 1 7)

16311658 liftIO $ map dropDocs compls @?=

16321659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1638,7 +1665,7 @@ completionTests

16381665 ]

16391666 , testSessionWait "type" $ do

16401667 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

16421669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

16431670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

16441671 compls <- getCompletions docId (Position 2 7)

@@ -1655,7 +1682,7 @@ completionTests

16551682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

16561683 , testSessionWait "qualified" $ do

16571684 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

16591686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

16601687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

16611688 compls <- getCompletions docId (Position 2 15)

@@ -1669,7 +1696,7 @@ completionTests

16691696 ]

16701697 , testSessionWait "keyword" $ do

16711698 let source = T.unlines ["module A where", "f = newty"]

1672− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

16731700 compls <- getCompletions docId (Position 1 9)

16741701 liftIO $ compls @?= [keywordItem "newtype"]

16751702 , testSessionWait "type context" $ do

@@ -1678,7 +1705,7 @@ completionTests

16781705 , "module A () where"

16791706 , "f = f"

16801707 ]

1681− docId <- openDoc' "A.hs" "haskell" source

1708+ docId <- createDoc "A.hs" "haskell" source

16821709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

16831710 changeDoc docId

16841711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

@@ -1746,7 +1773,7 @@ outlineTests = testGroup

17461773 "outline"

17471774 [ testSessionWait "type class" $ do

17481775 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

17501777 symbols <- getDocumentSymbols docId

17511778 liftIO $ symbols @?= Left

17521779 [ moduleSymbol

@@ -1759,7 +1786,7 @@ outlineTests = testGroup

17591786 ]

17601787 , testSessionWait "type class instance " $ do

17611788 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

17631790 symbols <- getDocumentSymbols docId

17641791 liftIO $ symbols @?= Left

17651792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1767,7 +1794,7 @@ outlineTests = testGroup

17671794 ]

17681795 , testSessionWait "type family" $ do

17691796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1770− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

17711798 symbols <- getDocumentSymbols docId

17721799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

17731800 , testSessionWait "type family instance " $ do

@@ -1776,7 +1803,7 @@ outlineTests = testGroup

17761803 , "type family A a"

17771804 , "type instance A () = ()"

17781805 ]

1779− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

17801807 symbols <- getDocumentSymbols docId

17811808 liftIO $ symbols @?= Left

17821809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1784,7 +1811,7 @@ outlineTests = testGroup

17841811 ]

17851812 , testSessionWait "data family" $ do

17861813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1787− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

17881815 symbols <- getDocumentSymbols docId

17891816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

17901817 , testSessionWait "data family instance " $ do

@@ -1793,7 +1820,7 @@ outlineTests = testGroup

17931820 , "data family A a"

17941821 , "data instance A () = A ()"

17951822 ]

1796− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

17971824 symbols <- getDocumentSymbols docId

17981825 liftIO $ symbols @?= Left

17991826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1801,36 +1828,36 @@ outlineTests = testGroup

18011828 ]

18021829 , testSessionWait "constant" $ do

18031830 let source = T.unlines ["a = ()"]

1804− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

18051832 symbols <- getDocumentSymbols docId

18061833 liftIO $ symbols @?= Left

18071834 [docSymbol "a" SkFunction (R 0 0 0 6)]

18081835 , testSessionWait "pattern" $ do

18091836 let source = T.unlines ["Just foo = Just 21"]

1810− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

18111838 symbols <- getDocumentSymbols docId

18121839 liftIO $ symbols @?= Left

18131840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

18141841 , testSessionWait "pattern with type signature" $ do

18151842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1816− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

18171844 symbols <- getDocumentSymbols docId

18181845 liftIO $ symbols @?= Left

18191846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

18201847 , testSessionWait "function" $ do

18211848 let source = T.unlines ["a x = ()"]

1822− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

18231850 symbols <- getDocumentSymbols docId

18241851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

18251852 , testSessionWait "type synonym" $ do

18261853 let source = T.unlines ["type A = Bool"]

1827− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

18281855 symbols <- getDocumentSymbols docId

18291856 liftIO $ symbols @?= Left

18301857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

18311858 , testSessionWait "datatype" $ do

18321859 let source = T.unlines ["data A = C"]

1833− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

18341861 symbols <- getDocumentSymbols docId

18351862 liftIO $ symbols @?= Left

18361863 [ docSymbolWithChildren "A"

@@ -1838,9 +1865,21 @@ outlineTests = testGroup

18381865 (R 0 0 0 10)

18391866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

18401867 ]

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

18411880 , testSessionWait "import" $ do

18421881 let source = T.unlines ["import Data.Maybe"]

1843− docId <- openDoc' "A.hs" "haskell" source

1882+ docId <- createDoc "A.hs" "haskell" source

18441883 symbols <- getDocumentSymbols docId

18451884 liftIO $ symbols @?= Left

18461885 [docSymbolWithChildren "imports"

@@ -1851,7 +1890,7 @@ outlineTests = testGroup

18511890 ]

18521891 , testSessionWait "multiple import" $ do

18531892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1854− docId <- openDoc' "A.hs" "haskell" source

1893+ docId <- createDoc "A.hs" "haskell" source

18551894 symbols <- getDocumentSymbols docId

18561895 liftIO $ symbols @?= Left

18571896 [docSymbolWithChildren "imports"

@@ -1866,7 +1905,7 @@ outlineTests = testGroup

18661905 [ "{-# language ForeignFunctionInterface #-}"

18671906 , "foreign import ccall \"a\" a :: Int"

18681907 ]

1869− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

18701909 symbols <- getDocumentSymbols docId

18711910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

18721911 , testSessionWait "foreign export" $ do

@@ -1874,7 +1913,7 @@ outlineTests = testGroup

18741913 [ "{-# language ForeignFunctionInterface #-}"

18751914 , "foreign export ccall odd :: Int -> Bool"

18761915 ]

1877− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

18781917 symbols <- getDocumentSymbols docId

18791918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

18801919 ]

@@ -1887,6 +1926,8 @@ outlineTests = testGroup

18871926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

18881927 docSymbolWithChildren name kind loc cc =

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

18901931 moduleSymbol name loc cc = DocumentSymbol name

18911932 Nothing

18921933 SkFile

@@ -1992,6 +2033,7 @@ cradleTests :: TestTree

19922033cradleTests = testGroup "cradle"

19932034 [testGroup "dependencies" [sessionDepsArePickedUp]

19942035 ,testGroup "loading" [loadCradleOnlyonce]

2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

19952037 ]

19962038

19972039loadCradleOnlyonce :: TestTree

@@ -2006,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"

20062048 test dir

20072049 implicit dir = test dir

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

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

20112053 liftIO $ length msgs @?= 1

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

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

20142056 liftIO $ length msgs @?= 0

2015− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

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

20172059 liftIO $ length msgs @?= 0

20182060

20192061

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+

20202098cradleLoadedMessage :: Session FromServerMessage

20212099cradleLoadedMessage = satisfy $ \case

20222100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

@@ -2025,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case

20252103cradleLoadedMethod :: T.Text

20262104cradleLoadedMethod = "ghcide/cradle/loaded"

20272105

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+

20282156sessionDepsArePickedUp :: TestTree

20292157sessionDepsArePickedUp = testSession'

20302158 "session-deps-are-picked-up"

@@ -2034,7 +2162,7 @@ sessionDepsArePickedUp = testSession'

20342162 (dir </> "hie.yaml")

20352163 "cradle: {direct: {arguments: []}}"

20362164 -- Open without OverloadedStrings and expect an error.

2037− doc <- openDoc' "Foo.hs" "haskell" fooContent

2165+ doc <- createDoc "Foo.hs" "haskell" fooContent

20382166 expectDiagnostics

20392167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

20402168 -- Update hie.yaml to enable OverloadedStrings.

@@ -2069,6 +2197,9 @@ sessionDepsArePickedUp = testSession'

20692197testSession :: String -> Session () -> TestTree

20702198testSession name = testCase name . run

20712199

2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202+

20722203testSession' :: String -> (FilePath -> Session ()) -> TestTree

20732204testSession' name = testCase name . run'

20742205

@@ -2103,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)

21032234run :: Session a -> IO a

21042235run s = withTempDir $ \dir -> runInDir dir s

21052236

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+

21062250run' :: (FilePath -> Session a) -> IO a

21072251run' s = withTempDir $ \dir -> runInDir dir (s dir)

21082252

@@ -2114,11 +2258,6 @@ runInDir dir s = do

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

21152259 createDirectoryIfMissing True $ dir ++ "/Data"

21162260

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)

21222261

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

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

@@ -2137,7 +2276,7 @@ runInDir dir s = do

21372276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

21382277openTestDataDoc path = do

21392278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2140− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

21412280

21422281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

21432282findCodeActions doc range expectedTitles = do

@@ -2178,20 +2317,6 @@ unitTests = do

21782317 uriToFilePath' uri @?= Just ""

21792318 ]

21802319

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−

21952320positionMappingTests :: TestTree

21962321positionMappingTests =

21972322 testGroup "position mapping"

test/src/Development/IDE/Test.hs+4−21

@@ -16,10 +16,9 @@ import Control.Applicative.Combinators

1616import Control.Lens hiding (List)

1717import Control.Monad

1818import Control.Monad.IO.Class

19−import Data.Foldable

2019import qualified Data.Map.Strict as Map

2120import qualified Data.Text as T

22−import Language.Haskell.LSP.Test hiding (message, openDoc')

21+import Language.Haskell.LSP.Test hiding (message)

2322import qualified Language.Haskell.LSP.Test as LspTest

2423import Language.Haskell.LSP.Types

2524import Language.Haskell.LSP.Types.Lens as Lsp

@@ -74,17 +73,14 @@ expectNoMoreDiagnostics timeout = do

7473 ignoreOthers = void anyMessage >> handleMessages

7574

7675expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

77−expectDiagnostics = expectDiagnostics' diagnostic

78−

79−expectDiagnostics' :: Session PublishDiagnosticsNotification -> [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

80−expectDiagnostics' messageParser expected = do

76+expectDiagnostics expected = do

8177 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

8278 go expected'

8379 where

8480 go m

8581 | Map.null m = pure ()

8682 | otherwise = do

87− diagsNot <- skipManyTill anyMessage messageParser

83+ diagsNot <- skipManyTill anyMessage diagnostic

8884 let fileUri = diagsNot ^. params . uri

8985 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

9086 Nothing -> do

@@ -103,21 +99,8 @@ expectDiagnostics' messageParser expected = do

10399 " but got " <> show actual

104100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

105101

106−-- | Matches all diagnostic messages expect those from interface loading files

107102diagnostic :: Session PublishDiagnosticsNotification

108−diagnostic = do

109− m <- 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')}

103+diagnostic = LspTest.message

121104

122105standardizeQuotes :: T.Text -> T.Text

123106standardizeQuotes msg = let