3973238...master · ghcide

git.iko.soy/ghcide

on master help sign in

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

since splitsnapshots

unifiedsplit

@@ -5,6 +5,8 @@ jobs:

5 vmImage: 'ubuntu-latest'

6 strategy:

7 matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

8 stack_88:

10 stack_88:

9 STACK_YAML: "stack88.yaml"

11 STACK_YAML: "stack88.yaml"

10 stack_86:

12 stack_86:

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

30 ./fmt.sh

32 ./fmt.sh

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

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

32 - bash: |

34 - bash: |

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

36+ sudo apt-get update

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

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

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

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

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

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

36 fi

40 fi

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

39 displayName: 'stack setup'

43 displayName: 'stack setup'

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

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

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

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

46+ - bash: |

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

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

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

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

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

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

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

45 - bash: |

51 - bash: |

.azure/windows-stack.yml+3

@@ -5,6 +5,8 @@ jobs:

5 vmImage: 'windows-2019'

6 strategy:

7 matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

8 stack_88:

10 stack_88:

9 STACK_YAML: "stack88.yaml"

11 STACK_YAML: "stack88.yaml"

10 stack_86:

12 stack_86:

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

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

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

45 stack install happy --stack-yaml $STACK_YAML

47 stack install happy --stack-yaml $STACK_YAML

46 stack install alex --stack-yaml $STACK_YAML

48 stack install alex --stack-yaml $STACK_YAML

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

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

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

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

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

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

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

.ghcideleted−25

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

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

2−

3−:set -XBangPatterns

4−:set -XDeriveFunctor

5−:set -XDeriveGeneric

6−:set -XGeneralizedNewtypeDeriving

7−:set -XLambdaCase

8−:set -XNamedFieldPuns

9−:set -XOverloadedStrings

10−:set -XRecordWildCards

11−:set -XScopedTypeVariables

12−:set -XStandaloneDeriving

13−:set -XTupleSections

14−:set -XTypeApplications

15−:set -XViewPatterns

16−

17−:set -package=ghc

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

19−:set -DGHC_STABLE

20−:set -Iinclude

21−:set -idist/build/autogen

22−:set -isrc

23−:set -iexe

24−

25−:load Main

.gitignore+2

@@ -6,3 +6,5 @@ cabal.project.local

6*.lock

7/.tasty-rerun-log

8.vscode

9+/.hlint-*

10+bench/example

.hlint.yaml+5−1

@@ -73,18 +73,22 @@

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

75 # Shady extensions

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

77 - name: CPP

76 - name: CPP

78 within:

77 within:

78+ - Development.IDE.Compat

79 - Development.IDE.Core.FileStore

80 - Development.IDE.Core.Compile

81+ - Development.IDE.Core.Rules

81 - Development.IDE.GHC.Compat

82 - Development.IDE.GHC.Compat

83+ - Development.IDE.GHC.Orphans

82 - Development.IDE.GHC.Util

84 - Development.IDE.GHC.Util

83 - Development.IDE.Import.FindImports

85 - Development.IDE.Import.FindImports

86+ - Development.IDE.LSP.Outline

84 - Development.IDE.Spans.Calculate

87 - Development.IDE.Spans.Calculate

85 - Development.IDE.Spans.Documentation

88 - Development.IDE.Spans.Documentation

86 - Development.IDE.Spans.Common

89 - Development.IDE.Spans.Common

87 - Development.IDE.Plugin.CodeAction

90 - Development.IDE.Plugin.CodeAction

91+ - Development.IDE.Plugin.Completions

88 - Development.IDE.Plugin.Completions.Logic

92 - Development.IDE.Plugin.Completions.Logic

89 - Main

93 - Main

CHANGELOG.md+20

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

1### unreleased

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

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

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

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

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

9+ files) (thanks @jinwoo)

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

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

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

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

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

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

16+ @pepeiborra)

17+* Minor improvements to completions

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

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

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

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

22+

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

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

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

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

README.md+48−3

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

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

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

28+

29+## Limitations to Multi-Component support

30+

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

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

33+some limitations to this.

34+

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

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

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

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

39+from each component.

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

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

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

43+a simple reproduction of the bug.

44+

28## Using it

45## Using it

30### Install `ghcide`

47### Install `ghcide`

32#### With Nix

49#### With Nix

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

52+

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

54+ ```

55+ nix-env -iA haskellPackages.ghcide

56+ ```

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

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

59+

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

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

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

36#### With Cabal or Stack

63#### With Cabal or Stack

@@ -207,7 +234,11 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):

207```

234```

208

235

209Here's a nice article on setting up neovim and coc: [Vim and Haskell in

236Here's a nice article on setting up neovim and coc: [Vim and Haskell in

210−2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)

237+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)

238+

239+Here is a Docker container that pins down the build and configuration for

240+Neovim and ghcide on a minimal Debian 10 base system:

241+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).

211

242

212### SpaceVim

243### SpaceVim

213

244

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

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

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

253using `stack install ghcide` within a project.

284using `stack install ghcide` within a project.

254

285

286+### Using with Kakoune

287+

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

289+

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

291+

292+```toml

293+[language.haskell]

294+filetypes = ["haskell"]

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

296+command = "ghcide"

297+args = ["--lsp"]

298+```

299+

255## Hacking on ghcide

300## Hacking on ghcide

256

301

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

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

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

280

325

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

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

282

327

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

284

329

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

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

286

331

bench/Main.hsnew file+287

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

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE ImplicitParams #-}

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

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

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

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

11+

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

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

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

15+

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

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

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

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

20+

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

22+

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

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

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

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

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

28+

29+ How to run:

30+ 1. `cabal bench`

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

32+

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

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

35+ produce the same results.

36+

37+ -}

38+

39+import Control.Applicative.Combinators

40+import Control.Concurrent

41+import Control.Exception.Safe

42+import Control.Monad.Extra

43+import Control.Monad.IO.Class

44+import Data.Aeson

45+import Data.List

46+import Data.Maybe

47+import Data.Version

48+import Language.Haskell.LSP.Test

49+import Language.Haskell.LSP.Types

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

51+import Numeric.Natural

52+import Options.Applicative

53+import System.Directory

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

55+import System.Process

56+import System.Time.Extra

57+

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

59+-- convenient for hygienic edits

60+hygienicP :: Position

61+hygienicP = Position 854 23

62+

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

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

65+identifierP :: Position

66+identifierP = Position 853 12

67+

68+main :: IO ()

69+main = do

70+ config <- execParser $ info configP fullDesc

71+ let ?config = config

72+

73+ output "starting test"

74+

75+ cleanUp <- setup

76+

77+ runBenchmarks

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

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

80+ isJust <$> getHover doc identifierP,

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

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

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

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

85+ bench "documentSymbols" 100 $

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

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

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

89+ let change =

90+ TextDocumentContentChangeEvent

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

92+ _rangeLength = Nothing,

93+ _text = " "

94+ }

95+ changeDoc doc [change]

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

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

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

99+ let change =

100+ TextDocumentContentChangeEvent

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

102+ _rangeLength = Nothing,

103+ _text = " "

104+ }

105+ changeDoc doc [change]

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

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

108+ benchWithSetup

109+ "code actions"

110+ 10

111+ ( \doc -> do

112+ let p = identifierP

113+ let change =

114+ TextDocumentContentChangeEvent

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

116+ _rangeLength = Nothing,

117+ _text = "a"

118+ }

119+ changeDoc doc [change]

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

121+ return p

122+ )

123+ ( \p doc -> do

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

125+ ),

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

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

128+ let p = identifierP

129+ let change =

130+ TextDocumentContentChangeEvent

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

132+ _rangeLength = Nothing,

133+ _text = "a"

134+ }

135+ changeDoc doc [change]

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

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

138+ ]

139+ `finally` cleanUp

140+

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

142+

143+examplePackageName :: String

144+examplePackageName = "Cabal"

145+

146+examplePackageVersion :: Version

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

148+

149+examplePackage :: String

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

151+

152+exampleModulePath :: FilePath

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

154+

155+examplesPath :: FilePath

156+examplesPath = "bench/example"

157+

158+data Config = Config

159+ { verbose :: !Bool,

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

161+ shakeProfiling :: !(Maybe FilePath),

162+ outputCSV :: !Bool

163+ }

164+

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

166+

167+configP :: Parser Config

168+configP = Config

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

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

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

172+

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

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

175+

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

177+

178+type Experiment = TextDocumentIdentifier -> Session Bool

179+

180+data Bench = forall setup.

181+ Bench

182+ { name :: !String,

183+ samples :: !Natural,

184+ benchSetup :: TextDocumentIdentifier -> Session setup,

185+ experiment :: setup -> Experiment

186+ }

187+

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

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

190+ where

191+ experiment () = userExperiment

192+ benchSetup _ = return ()

193+

194+benchWithSetup ::

195+ String ->

196+ Natural ->

197+ (TextDocumentIdentifier -> Session p) ->

198+ (p -> Experiment) ->

199+ Bench

200+benchWithSetup = Bench

201+

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

203+runBenchmarks benchmarks = do

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

205+

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

207+ output $

208+ "TOTAL "

209+ <> name

210+ <> " = "

211+ <> showDuration duration

212+ <> " ("

213+ <> show samples

214+ <> " repetitions)"

215+

216+ when (outputCSV ?config) $ do

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

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

219+

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

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

222+ $ runSessionWithConfig conf cmd lspTestCaps dir

223+ $ do

224+ doc <- openDoc exampleModulePath "haskell"

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

226+

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

228+ userState <- benchSetup doc

229+ let loop 0 = return True

230+ loop n = do

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

232+ if not res

233+ then return False

234+ else do

235+ output (showDuration t)

236+ loop (n -1)

237+

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

239+

240+ exitServer

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

242+ liftIO $ threadDelay 50000

243+

244+ return $ if res then t else -1

245+ where

246+ cmd =

247+ unwords $

248+ [ "ghcide",

249+ "--lsp",

250+ "--cwd",

251+ dir,

252+ "+RTS",

253+ "-S",

254+ "-RTS"

255+ ]

256+ ++ concat

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

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

259+ ]

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

261+ lspTestCaps =

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

263+ conf =

264+ defaultConfig

265+ { logStdErr = verbose ?config,

266+ logMessages = False,

267+ logColor = False

268+ }

269+

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

271+setup = do

272+ alreadyExists <- doesDirectoryExist examplesPath

273+ when alreadyExists $ removeDirectoryRecursive examplesPath

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

275+ writeFile

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

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

278+

279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280+

281+ return $ removeDirectoryRecursive examplesPath

282+

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

284+exitServer :: Session ()

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

286+

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

exe/Main.hs+522−63

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

8module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

10import Arguments

15import Arguments

11−import Data.Maybe

16+import Control.Concurrent.Async

12−import Data.List.Extra

13−import System.FilePath

14import Control.Concurrent.Extra

17import Control.Concurrent.Extra

15import Control.Exception

18import Control.Exception

16import Control.Monad.Extra

19import Control.Monad.Extra

17import Control.Monad.IO.Class

20import Control.Monad.IO.Class

18import Data.Default

21import Data.Default

19−import System.Time.Extra

22+import Data.Either

23+import Data.Function

24+import Data.List.Extra

25+import Data.Maybe

26+import qualified Data.Text as T

27+import qualified Data.Text.IO as T

28+import Data.Time.Clock (UTCTime)

29+import Data.Version

20import Development.IDE.Core.Debouncer

30import Development.IDE.Core.Debouncer

21import Development.IDE.Core.FileStore

31import Development.IDE.Core.FileStore

22import Development.IDE.Core.OfInterest

32import Development.IDE.Core.OfInterest

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

33import Development.IDE.Plugin

43import Development.IDE.Plugin

34import Development.IDE.Plugin.Completions as Completions

44import Development.IDE.Plugin.Completions as Completions

35import Development.IDE.Plugin.CodeAction as CodeAction

45import Development.IDE.Plugin.CodeAction as CodeAction

36−import qualified Data.Text as T

37−import qualified Data.Text.IO as T

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

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

39import Language.Haskell.LSP.Messages

47import Language.Haskell.LSP.Messages

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

48+import Language.Haskell.LSP.Types

41−import Data.Version

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

42import Development.IDE.LSP.LanguageServer

50import Development.IDE.LSP.LanguageServer

43import qualified System.Directory.Extra as IO

51import qualified System.Directory.Extra as IO

44import System.Environment

52import System.Environment

45import System.IO

53import System.IO

46import System.Exit

54import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

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

47import Paths_ghcide

59import Paths_ghcide

48import Development.GitRev

60import Development.GitRev

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

61+import Development.Shake (Action, action)

50import qualified Data.HashSet as HashSet

62import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

51import qualified Data.Map.Strict as Map

64import qualified Data.Map.Strict as Map

65+import qualified Crypto.Hash.SHA1 as H

66+import qualified Data.ByteString.Char8 as B

67+import Data.ByteString.Base16 (encode)

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

69+import GhcMonad

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

71+import GHC hiding (def)

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

73+import Data.Either.Extra

74+

52−import HIE.Bios

75+import HIE.Bios.Cradle

53−import Rules

76+import HIE.Bios.Types

77+

54−import RuleTypes

78+import Utils

56ghcideVersion :: IO String

80ghcideVersion :: IO String

57ghcideVersion = do

81ghcideVersion = do

@@ -81,11 +105,12 @@ main = do

81 whenJust argsCwd IO.setCurrentDirectory

105 whenJust argsCwd IO.setCurrentDirectory

106

83 dir <- IO.getCurrentDirectory

107 dir <- IO.getCurrentDirectory

108+ command <- makeLspCommandId "typesignature.add"

109

85 let plugins = Completions.plugin <> CodeAction.plugin

110 let plugins = Completions.plugin <> CodeAction.plugin

86 onInitialConfiguration = const $ Right ()

111 onInitialConfiguration = const $ Right ()

87 onConfigurationChange = const $ Right ()

112 onConfigurationChange = const $ Right ()

88− options = def { LSP.executeCommandCommands = Just ["typesignature.add"]

113+ options = def { LSP.executeCommandCommands = Just [command]

89 , LSP.completionTriggerCharacters = Just "."

114 , LSP.completionTriggerCharacters = Just "."

90 }

115 }

116

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

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

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

97 t <- t

122 t <- t

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

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

99− let options = (defaultIdeOptions $ loadSession dir)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

100 { optReportProgress = clientSupportsProgress caps

125 { optReportProgress = clientSupportsProgress caps

101 , optShakeProfiling = argsShakeProfiling

126 , optShakeProfiling = argsShakeProfiling

102 , optTesting = argsTesting

127 , optTesting = argsTesting

103 , optThreads = argsThreads

128 , optThreads = argsThreads

104− , optInterfaceLoadingDiagnostics = argsTesting

105 }

129 }

106 debouncer <- newAsyncDebouncer

130 debouncer <- newAsyncDebouncer

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

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

108 getLspId event (logger minBound) debouncer options vfs

132 getLspId event (logger minBound) debouncer options vfs

109 else do

133 else do

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

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

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

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

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

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

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

116

140

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

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

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

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

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

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

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

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

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

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

122

146

123− 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"

124 cradles <- mapM findCradle files

148 cradles <- mapM findCradle files

125 let ucradles = nubOrd cradles

149 let ucradles = nubOrd cradles

126 let n = length ucradles

150 let n = length ucradles

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

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

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

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

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

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

132− when (isNothing x) $ print cradle

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

134− opts <- getComponentOptions cradle

135− createSession opts

136−

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

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

138 vfs <- makeVFSHandle

153 vfs <- makeVFSHandle

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

154+ debouncer <- newAsyncDebouncer

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

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

142− cradle <- Map.lookup file filesToCradles

143− Map.lookup cradle cradlesToSessions

144−

145− let options =

146− (defaultIdeOptions $ return $ return . grab)

147− { optShakeProfiling = argsShakeProfiling }

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

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

149−

156+

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

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

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

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

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

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

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

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

154 when (failed /= []) $

161 when (failed /= []) $

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

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

156

163

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

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

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

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

159−

166+ return ()

160− unless (null failed) exitFailure

161−

162−cradleRules :: Rules ()

163−cradleRules = do

164− loadGhcSession

165− cradleToSession

166

167

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

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

168expandFiles = concatMapM $ \x -> do

169expandFiles = concatMapM $ \x -> do

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

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

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

190showEvent lock e = withLock lock $ print e

191showEvent lock e = withLock lock $ print e

191

192

193+

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

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

196+cradleToSessionOpts cradle file = do

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

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

199+ case cradleRes of

200+ CradleSuccess r -> pure (Right r)

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

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

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

204+ CradleNone -> return (Left [])

205+

206+emptyHscEnv :: IO HscEnv

207+emptyHscEnv = do

208+ libdir <- getLibdir

209+ env <- runGhc (Just libdir) getSession

210+ initDynLinker env

211+ pure env

212+

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

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

215+-- directories

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

217+-- to canonicalise it.

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

219+targetToFile is (TargetModule mod) = do

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

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

222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223+targetToFile _ (TargetFile f _) = do

224+ f' <- canonicalizePath f

225+ return [toNormalizedFilePath' f']

226+

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

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

229+

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

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

193−loadSession dir = liftIO $ do

231+loadSessionShake fp = do

232+ se <- getShakeExtras

233+ IdeOptions{optTesting} <- getIdeOptions

234+ res <- liftIO $ loadSession optTesting se fp

235+ return (fmap liftIO res)

236+

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

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

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

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

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

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

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

244+ -- Mapping from a Filepath to HscEnv

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

246+

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

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

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

195− res <- findCradle v

249+ res <- findCradle v

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

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

197− -- try and normalise that

251+ -- try and normalise that

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

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

199− res' <- traverse IO.makeAbsolute res

253+ res' <- traverse IO.makeAbsolute res

200− return $ normalise <$> res'

254+ return $ normalise <$> res'

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

255+

202− session file = do

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

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

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

204− let cradle = toNormalizedFilePath' $ fromMaybe dir file

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

205− use_ LoadCradle cradle

259+ -- which contains the union.

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

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

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

263+ -- Parse DynFlags for the newly discovered component

264+ hscEnv <- emptyHscEnv

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

266+ setOptions opts (hsc_dflags hscEnv)

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

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

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

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

271+ -- (unitId, DynFlag, Targets)

272+ modifyVar hscEnvs $ \m -> do

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

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

275+ let oldDeps = Map.lookup hieYaml m

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

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

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

279+ -- information.

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

281+ : maybe [] snd oldDeps

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

283+ inplace = map rawComponentUnitId new_deps

284+

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

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

287+ -- components in this HscEnv

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

289+ let prefix = show rawComponentUnitId

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

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

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

293+ -- contain any packages which are also loaded

294+ -- into the same component.

295+ pure $ ComponentInfo rawComponentUnitId

296+ processed_df

297+ uids

298+ rawComponentTargets

299+ rawComponentFP

300+ rawComponentCOptions

301+ rawComponentDependencyInfo

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

303+ -- scratch again (for now)

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

305+ -- that I do not fully understand

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

307+ hscEnv <- case oldDeps of

308+ Nothing -> emptyHscEnv

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

310+ newHscEnv <-

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

312+ evalGhcEnv hscEnv $ do

313+ _ <- setSessionDynFlags df

314+ getSession

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

316+ -- HscEnv

317+ -- Returns

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

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

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

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

322+ -- existing packages

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

324+

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

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

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

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

329+ -- resolve imports. (especially PackageImports)

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

331+

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

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

334+

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

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

337+ let new_cache = newComponentCache logger hscEnv uids

338+ (cs, res) <- new_cache new

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

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

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

342+ modifyVar_ fileToFlags $ \var -> do

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

344+

345+ return (fst res)

346+

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

348+ consultCradle hieYaml cfp = do

349+ when optTesting $ eventer $ notifyCradleLoaded cfp

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

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

352+ eopts <- cradleToSessionOpts cradle cfp

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

354+ case eopts of

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

356+ -- into and HscEnv.

357+ Right opts -> do

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

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

360+ Left err -> do

361+ dep_info <- getDependencyInfo (maybeToList hieYaml)

362+ let ncfp = toNormalizedFilePath' cfp

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

364+ modifyVar_ fileToFlags $ \var -> do

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

366+ return res

367+

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

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

370+ sessionOpts (hieYaml, file) = do

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

372+ cfp <- canonicalizePath file

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

374+ Just (opts, old_di) -> do

375+ deps_ok <- checkDependencyInfo old_di

376+ if not deps_ok

377+ then do

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

379+ -- again.

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

381+ -- Keep the same name cache

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

383+ consultCradle hieYaml cfp

384+ else return opts

385+ Nothing -> consultCradle hieYaml cfp

386+

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

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

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

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

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

392+ -- before attempting to do so.

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

394+ getOptions file = do

395+ hieYaml <- cradleLoc file

396+ sessionOpts (hieYaml, file)

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

397+ return $ \file -> do

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

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

400+ void $ wait as

401+ as <- async $ getOptions file

402+ return (as, wait as)

207

403

208

404

405+

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

407+newComponentCache

408+ :: Logger

409+ -> HscEnv

410+ -> [(InstalledUnitId, DynFlags)]

411+ -> ComponentInfo

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

413+newComponentCache logger hsc_env uids ci = do

414+ let df = componentDynFlags ci

415+ let hscEnv' = hsc_env { hsc_dflags = df

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

417+

418+ versionMismatch <- checkGhcVersion

419+ henv <- case versionMismatch of

420+ Just mismatch -> return mismatch

421+ Nothing -> newHscEnvEq hscEnv' uids

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

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

424+

425+ let is = importPaths df

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

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

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

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

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

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

432+ let special_target = (componentFP ci, res)

433+ let xs = map (,res) ctargets

434+ return (special_target:xs, res)

435+

436+{- Note [Avoiding bad interface files]

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

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

439+on the first occurrence of the component.

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

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

442+updated for each component.

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

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

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

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

447+```

448+typecheckIface

449+Declaration for Rep_ClientRunFlags

450+Axiom branches Rep_ClientRunFlags:

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

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

453+```

454+and

455+```

456+expectJust checkFamInstConsistency

457+CallStack (from HasCallStack):

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

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

460+```

461+

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

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

464+of the respective components.

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

466+respective components are co1, co2.

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

468+each component in this way:

469+

470+ * Load component c2

471+ * (Cache Directory State)

472+ - name of c2 + co2

473+ * Load component c1

474+ * (Cache Directory State)

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

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

477+

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

479+create a fourth cache directory.

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

481+

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

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

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

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

486+-}

487+

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

489+-- internal packages.

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

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

492+setCacheDir logger prefix hscComponents comps dflags = do

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

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

495+ pure $ dflags

496+ & setHiDir cacheDir

497+ & setDefaultHieDir cacheDir

498+

499+

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

501+renderCradleError nfp (CradleError _ec t) =

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

503+

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

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

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

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

508+

509+-- This is pristine information about a component

510+data RawComponentInfo = RawComponentInfo

511+ { rawComponentUnitId :: InstalledUnitId

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

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

514+ , rawComponentDynFlags :: DynFlags

515+ -- | All targets of this components.

516+ , rawComponentTargets :: [Target]

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

518+ , rawComponentFP :: NormalizedFilePath

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

520+ , rawComponentCOptions :: ComponentOptions

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

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

523+ , rawComponentDependencyInfo :: DependencyInfo

524+ }

525+

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

527+data ComponentInfo = ComponentInfo

528+ { componentUnitId :: InstalledUnitId

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

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

531+ , componentDynFlags :: DynFlags

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

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

534+ -- ComponentOptions.

535+ , componentInternalUnits :: [InstalledUnitId]

536+ -- | All targets of this components.

537+ , componentTargets :: [Target]

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

539+ , componentFP :: NormalizedFilePath

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

541+ , componentCOptions :: ComponentOptions

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

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

544+ , componentDependencyInfo :: DependencyInfo

545+ }

546+

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

548+checkDependencyInfo :: DependencyInfo -> IO Bool

549+checkDependencyInfo old_di = do

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

551+ return (di == old_di)

552+

553+-- Note [Multi Cradle Dependency Info]

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

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

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

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

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

559+

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

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

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

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

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

565+

566+ where

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

568+ tryIO = try

569+

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

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

572+

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

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

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

576+-- from the package flags for the executable

577+--

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

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

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

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

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

583+ , thisInstalledUnitId = fake_uid }, uids)

584+ where

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

586+ fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")

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

588+ then Left (toInstalledUnitId u)

589+ else Right p

590+ go p = Right p

591+

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

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

210--

593--

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

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

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

222 res <- onceFork $ op k

605 res <- onceFork $ op k

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

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

224 Just res -> return (mp, res)

607 Just res -> return (mp, res)

608+

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

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

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

612+ let dflags'' =

613+ -- disabled, generated directly by ghcide instead

614+ flip gopt_unset Opt_WriteInterface $

615+ -- disabled, generated directly by ghcide instead

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

617+ dontWriteHieFiles $

618+ setIgnoreInterfacePragmas $

619+ setLinkerOptions $

620+ disableOptimisation $

621+ makeDynFlagsAbsolute compRoot dflags'

622+ -- initPackages parses the -package flags and

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

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

625+ return (final_df, targets)

626+

627+

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

629+-- (HscInterpreted) which implies LinkInMemory

630+-- HscInterpreted

631+setLinkerOptions :: DynFlags -> DynFlags

632+setLinkerOptions df = df {

633+ ghcLink = LinkInMemory

634+ , hscTarget = HscNothing

635+ , ghcMode = CompManager

636+ }

637+

638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639+setIgnoreInterfacePragmas df =

640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641+

642+disableOptimisation :: DynFlags -> DynFlags

643+disableOptimisation df = updOptLevel 0 df

644+

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

646+setHiDir f d =

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

648+ d { hiDir = Just f}

649+

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

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

652+ where

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

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

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

656+

657+-- | Sub directory for the cache path

658+cacheDir :: String

659+cacheDir = "ghcide"

660+

661+notifyCradleLoaded :: FilePath -> FromServerMessage

662+notifyCradleLoaded fp =

663+ NotCustomServer $

664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665+ toJSON fp

666+

667+cradleLoadedMethod :: T.Text

668+cradleLoadedMethod = "ghcide/cradle/loaded"

669+

670+ghcVersionChecker :: IO VersionCheck

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

672+

673+checkGhcVersion :: IO (Maybe HscEnvEq)

674+checkGhcVersion = do

675+ res <- ghcVersionChecker

676+ case res of

677+ Failure err -> do

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

679+ return Nothing

680+ Mismatch {..} ->

681+ return $ Just GhcVersionMismatch {..}

682+ _ ->

683+ return Nothing

exe/RuleTypes.hsdeleted−33

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

1−{-# LANGUAGE TypeFamilies #-}

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

3−

4−import Control.DeepSeq

5−import Data.Binary

6−import Data.Hashable (Hashable)

7−import Development.Shake

8−import Development.IDE.GHC.Util

9−import Data.Typeable (Typeable)

10−import GHC.Generics (Generic)

11−

12−-- Rule type for caching GHC sessions.

13−type instance RuleResult GetHscEnv = HscEnvEq

14−

15−data GetHscEnv = GetHscEnv

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

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

18− }

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

20−

21−instance Hashable GetHscEnv

22−instance NFData GetHscEnv

23−instance Binary GetHscEnv

24−

25−-- Rule type for caching cradle loading

26−type instance RuleResult LoadCradle = HscEnvEq

27−

28−data LoadCradle = LoadCradle

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

30−

31−instance Hashable LoadCradle

32−instance NFData LoadCradle

33−instance Binary LoadCradle

exe/Rules.hsdeleted−138

@@ -1,138 +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 Data.Version (Version)

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

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

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

22−import Development.IDE.GHC.Util

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

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

25−import Development.Shake

26−import GHC

27−import GHC.Check (runTimeVersion, compileTimeVersionFromLibdir)

28−import HIE.Bios

29−import HIE.Bios.Cradle

30−import HIE.Bios.Environment (addCmdOpts)

31−import HIE.Bios.Types

32−import Linker (initDynLinker)

33−import RuleTypes

34−import qualified System.Directory.Extra as IO

35−import System.FilePath.Posix (addTrailingPathSeparator,

36− (</>))

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

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

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

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

41−import Util

42−

43−-- Prefix for the cache path

44−cacheDir :: String

45−cacheDir = "ghcide"

46−

47−notifyCradleLoaded :: FilePath -> LSP.FromServerMessage

48−notifyCradleLoaded fp =

49− LSP.NotCustomServer $

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

51− toJSON fp

52−

53−loadGhcSession :: Rules ()

54−loadGhcSession =

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

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

57− -- the existing session.

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

59− liftIO $ createSession $ ComponentOptions opts deps

60−

61−cradleToSession :: Rules ()

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

63−

64− let f = fromNormalizedFilePath nfp

65−

66− IdeOptions{optTesting} <- getIdeOptions

67−

68− logger <- actionLogger

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

70−

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

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

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

74−

75− when optTesting $

76− sendEvent $ notifyCradleLoaded f

77−

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

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

80− let opts = componentOptions cmpOpts

81− deps = componentDependencies cmpOpts

82− deps' = case mbYaml of

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

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

85− _ -> deps

86− existingDeps <- filterM doesFileExist deps'

87− need existingDeps

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

89−

90−cradleLoadedMethod :: Text

91−cradleLoadedMethod = "ghcide/cradle/loaded"

92−

93−getComponentOptions :: Cradle a -> IO ComponentOptions

94−getComponentOptions cradle = do

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

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

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

98− case cradleRes of

99− CradleSuccess r -> pure r

100− CradleFail err -> throwIO err

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

102− -- That will require some more changes.

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

104−

105−compileTimeGhcVersion :: Version

106−compileTimeGhcVersion = $$(compileTimeVersionFromLibdir getLibdir)

107−

108−checkGhcVersion :: Ghc (Maybe HscEnvEq)

109−checkGhcVersion = do

110− v <- runTimeVersion

111− return $ if v == Just compileTimeGhcVersion

112− then Nothing

113− else Just GhcVersionMismatch {compileTime = compileTimeGhcVersion, runTime = v}

114−

115−createSession :: ComponentOptions -> IO HscEnvEq

116−createSession (ComponentOptions theOpts _) = do

117− libdir <- getLibdir

118−

119− cacheDir <- getCacheDir theOpts

120−

121− runGhc (Just libdir) $ do

122− dflags <- getSessionDynFlags

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

124− setupDynFlags cacheDir dflags'

125− versionMismatch <- checkGhcVersion

126− case versionMismatch of

127− Just mismatch -> return mismatch

128− Nothing -> do

129− env <- getSession

130− liftIO $ initDynLinker env

131− liftIO $ newHscEnvEq env

132−

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

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

135− where

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

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

138− 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+69−13

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

2build-type: Simple

3category: Development

4name: ghcide

5−version: 0.1.0

5+version: 0.2.0

6license: Apache-2.0

7license-file: LICENSE

8author: Digital Asset

9maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

11synopsis: The core of an IDE

12description:

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

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

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

16tested-with: GHC==8.6.5

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

18− test/data/GotoHover.hs

18+ test/data/hover/*.hs

19+ test/data/multi/cabal.project

20+ test/data/multi/hie.yaml

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

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

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

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

20source-repository head

26source-repository head

21 type: git

27 type: git

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

44 filepath,

50 filepath,

45 haddock-library >= 1.8,

51 haddock-library >= 1.8,

46 hashable,

52 hashable,

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

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

48− haskell-lsp == 0.21.*,

54+ haskell-lsp == 0.22.*,

49 mtl,

55 mtl,

50 network-uri,

56 network-uri,

51 prettyprinter-ansi-terminal,

57 prettyprinter-ansi-terminal,

@@ -74,7 +80,10 @@ library

74 ghc-boot-th,

80 ghc-boot-th,

75 ghc-boot,

81 ghc-boot,

76 ghc >= 8.4

82 ghc >= 8.4

77− if !os(windows)

83+ if os(windows)

84+ build-depends:

85+ Win32

86+ else

78 build-depends:

87 build-depends:

79 unix

88 unix

80 c-sources:

89 c-sources:

@@ -100,6 +109,7 @@ library

100 include-dirs:

109 include-dirs:

101 include

110 include

102 exposed-modules:

111 exposed-modules:

112+ Development.IDE.Compat

103 Development.IDE.Core.Debouncer

113 Development.IDE.Core.Debouncer

104 Development.IDE.Core.FileStore

114 Development.IDE.Core.FileStore

105 Development.IDE.Core.IdeConfiguration

115 Development.IDE.Core.IdeConfiguration

@@ -133,6 +143,7 @@ library

133 Development.IDE.GHC.CPP

143 Development.IDE.GHC.CPP

134 Development.IDE.GHC.Orphans

144 Development.IDE.GHC.Orphans

135 Development.IDE.GHC.Warnings

145 Development.IDE.GHC.Warnings

146+ Development.IDE.GHC.WithDynFlags

136 Development.IDE.Import.FindImports

147 Development.IDE.Import.FindImports

137 Development.IDE.LSP.Notifications

148 Development.IDE.LSP.Notifications

138 Development.IDE.Spans.AtPoint

149 Development.IDE.Spans.AtPoint

@@ -144,7 +155,12 @@ library

144 Development.IDE.Plugin.CodeAction.RuleTypes

155 Development.IDE.Plugin.CodeAction.RuleTypes

145 Development.IDE.Plugin.Completions.Logic

156 Development.IDE.Plugin.Completions.Logic

146 Development.IDE.Plugin.Completions.Types

157 Development.IDE.Plugin.Completions.Types

147− if impl(ghc > 8.7) || flag(ghc-lib)

158+ if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)

159+ hs-source-dirs: src-ghc88

160+ other-modules:

161+ Development.IDE.GHC.HieAst

162+ if (impl(ghc > 8.9))

163+ hs-source-dirs: src-ghc810

148 other-modules:

164 other-modules:

149 Development.IDE.GHC.HieAst

165 Development.IDE.GHC.HieAst

150 ghc-options: -Wall -Wno-name-shadowing

166 ghc-options: -Wall -Wno-name-shadowing

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

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

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

175 main-is: Main.hs

191 main-is: Main.hs

176 build-depends:

192 build-depends:

193+ time,

194+ async,

177 hslogger,

195 hslogger,

178 aeson,

196 aeson,

179 base == 4.*,

197 base == 4.*,

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

187 directory,

205 directory,

188 extra,

206 extra,

189 filepath,

207 filepath,

190− ghc-check >= 0.1.0.3,

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

191 ghc-paths,

209 ghc-paths,

192 ghc,

210 ghc,

193 gitrev,

211 gitrev,

194 hashable,

212 hashable,

195 haskell-lsp,

213 haskell-lsp,

196 haskell-lsp-types,

214 haskell-lsp-types,

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

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

198 ghcide,

216 ghcide,

199 optparse-applicative,

217 optparse-applicative,

200 shake,

218 shake,

201 text,

219 text,

202 unordered-containers

220 unordered-containers

203 other-modules:

221 other-modules:

222+ Utils

204 Arguments

223 Arguments

205 Paths_ghcide

224 Paths_ghcide

206− Rules

207− RuleTypes

208− Util

209

225

210 default-extensions:

226 default-extensions:

211 BangPatterns

227 BangPatterns

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

253 haskell-lsp-types,

269 haskell-lsp-types,

254 network-uri,

270 network-uri,

255 lens,

271 lens,

256− lsp-test >= 0.8,

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

257 parser-combinators,

273 parser-combinators,

258 QuickCheck,

274 QuickCheck,

259 quickcheck-instances,

275 quickcheck-instances,

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

286 TupleSections

302 TupleSections

287 TypeApplications

303 TypeApplications

288 ViewPatterns

304 ViewPatterns

305+

306+benchmark ghcide-bench

307+ type: exitcode-stdio-1.0

308+ default-language: Haskell2010

309+ build-tool-depends:

310+ ghcide:ghcide,

311+ ghcide:ghcide-test-preprocessor

312+ build-depends:

313+ aeson,

314+ base,

315+ bytestring,

316+ containers,

317+ directory,

318+ extra,

319+ filepath,

320+ ghcide,

321+ lsp-test < 0.12,

322+ optparse-applicative,

323+ parser-combinators,

324+ process,

325+ safe-exceptions

326+ hs-source-dirs: bench

327+ include-dirs: include

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

329+ main-is: Main.hs

330+ other-modules:

331+ default-extensions:

332+ BangPatterns

333+ DeriveFunctor

334+ DeriveGeneric

335+ GeneralizedNewtypeDeriving

336+ LambdaCase

337+ NamedFieldPuns

338+ OverloadedStrings

339+ RecordWildCards

340+ ScopedTypeVariables

341+ StandaloneDeriving

342+ TupleSections

343+ TypeApplications

344+ ViewPatterns

hie.yaml+12−1

@@ -1 +1,12 @@

1+cradle:

2+ cabal:

3+ - path: "./src"

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

4+ component: "ghcide:lib:ghcide"

5+ - path: "./exe"

6+ component: "ghcide:exe:ghcide"

7+ - path: "./test"

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

9+ - path: "./bench"

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

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

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

src-ghc810/Development/IDE/GHC/HieAst.hsnew file+1928

@@ -0,0 +1,1928 @@

3+{-

4+Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile

6+Main functions for .hie file generation

7+-}

8+{- HLINT ignore -}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE FlexibleContexts #-}

13+{-# LANGUAGE TypeSynonymInstances #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeApplications #-}

17+{-# LANGUAGE AllowAmbiguousTypes #-}

18+{-# LANGUAGE ViewPatterns #-}

19+{-# LANGUAGE DeriveDataTypeable #-}

20+module Development.IDE.GHC.HieAst ( mkHieFile ) where

21+

22+import GhcPrelude

23+

24+import Avail ( Avails )

25+import Bag ( Bag, bagToList )

26+import BasicTypes

27+import BooleanFormula

28+import Class ( FunDep )

29+import CoreUtils ( exprType )

30+import ConLike ( conLikeName )

31+import Desugar ( deSugarExpr )

32+import FieldLabel

33+import GHC.Hs

34+import HscTypes

35+import Module ( ModuleName, ml_hs_file )

36+import MonadUtils ( concatMapM, liftIO )

37+import Name ( Name, nameSrcSpan, setNameLoc )

38+import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )

39+import SrcLoc

40+import TcHsSyn ( hsLitType, hsPatType )

41+import Type ( mkVisFunTys, Type )

42+import TysWiredIn ( mkListTy, mkSumTy )

43+import Var ( Id, Var, setVarName, varName, varType )

44+import TcRnTypes

45+import MkIface ( mkIfaceExports )

46+import Panic

47+

48+import HieTypes

49+import HieUtils

50+

51+import qualified Data.Array as A

52+import qualified Data.ByteString as BS

53+import qualified Data.Map as M

54+import qualified Data.Set as S

55+import Data.Data ( Data, Typeable )

56+import Data.List ( foldl1' )

57+import Data.Maybe ( listToMaybe )

58+import Control.Monad.Trans.Reader

59+import Control.Monad.Trans.Class ( lift )

60+

61+{- Note [Updating HieAst for changes in the GHC AST]

62+

63+When updating the code in this file for changes in the GHC AST, you

64+need to pay attention to the following things:

65+

66+1) Symbols (Names/Vars/Modules) in the following categories:

67+

68+ a) Symbols that appear in the source file that directly correspond to

69+ something the user typed

70+ b) Symbols that don't appear in the source, but should be in some sense

71+ "visible" to a user, particularly via IDE tooling or the like. This

72+ includes things like the names introduced by RecordWildcards (We record

73+ all the names introduced by a (..) in HIE files), and will include implicit

74+ parameters and evidence variables after one of my pending MRs lands.

75+

76+2) Subtrees that may contain such symbols, or correspond to a SrcSpan in

77+ the file. This includes all `Located` things

78+

79+For 1), you need to call `toHie` for one of the following instances

80+

81+instance ToHie (Context (Located Name)) where ...

82+instance ToHie (Context (Located Var)) where ...

83+instance ToHie (IEContext (Located ModuleName)) where ...

84+

85+`Context` is a data type that looks like:

86+

87+data Context a = C ContextInfo a -- Used for names and bindings

88+

89+`ContextInfo` is defined in `HieTypes`, and looks like

90+

91+data ContextInfo

92+ = Use -- ^ regular variable

93+ | MatchBind

94+ | IEThing IEType -- ^ import/export

95+ | TyDecl

96+ -- | Value binding

97+ | ValBind

98+ BindType -- ^ whether or not the binding is in an instance

99+ Scope -- ^ scope over which the value is bound

100+ (Maybe Span) -- ^ span of entire binding

101+ ...

102+

103+It is used to annotate symbols in the .hie files with some extra information on

104+the context in which they occur and should be fairly self explanatory. You need

105+to select one that looks appropriate for the symbol usage. In very rare cases,

106+you might need to extend this sum type if none of the cases seem appropriate.

107+

108+So, given a `Located Name` that is just being "used", and not defined at a

109+particular location, you would do the following:

110+

111+ toHie $ C Use located_name

112+

113+If you select one that corresponds to a binding site, you will need to

114+provide a `Scope` and a `Span` for your binding. Both of these are basically

115+`SrcSpans`.

116+

117+The `SrcSpan` in the `Scope` is supposed to span over the part of the source

118+where the symbol can be legally allowed to occur. For more details on how to

119+calculate this, see Note [Capturing Scopes and other non local information]

120+in HieAst.

121+

122+The binding `Span` is supposed to be the span of the entire binding for

123+the name.

124+

125+For a function definition `foo`:

126+

127+foo x = x + y

128+ where y = x^2

129+

130+The binding `Span` is the span of the entire function definition from `foo x`

131+to `x^2`. For a class definition, this is the span of the entire class, and

132+so on. If this isn't well defined for your bit of syntax (like a variable

133+bound by a lambda), then you can just supply a `Nothing`

134+

135+There is a test that checks that all symbols in the resulting HIE file

136+occur inside their stated `Scope`. This can be turned on by passing the

137+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the

138+.hie file.

139+

140+You may also want to provide a test in testsuite/test/hiefile that includes

141+a file containing your new construction, and tests that the calculated scope

142+is valid (by using -fvalidate-ide-info)

143+

144+For subtrees in the AST that may contain symbols, the procedure is fairly

145+straightforward. If you are extending the GHC AST, you will need to provide a

146+`ToHie` instance for any new types you may have introduced in the AST.

147+

148+Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):

149+

150+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

151+ HsVar _ (L _ var) ->

152+ [ toHie $ C Use (L mspan var)

153+ -- Patch up var location since typechecker removes it

154+ ]

155+ HsConLikeOut _ con ->

156+ [ toHie $ C Use $ L mspan $ conLikeName con

157+ ]

158+ ...

159+ HsApp _ a b ->

160+ [ toHie a

161+ , toHie b

162+ ]

163+

164+If your subtree is `Located` or has a `SrcSpan` available, the output list

165+should contain a HieAst `Node` corresponding to the subtree. You can use

166+either `makeNode` or `getTypeNode` for this purpose, depending on whether it

167+makes sense to assign a `Type` to the subtree. After this, you just need

168+to concatenate the result of calling `toHie` on all subexpressions and

169+appropriately annotated symbols contained in the subtree.

170+

171+The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed

172+to work for both the renamed and typechecked source. `getTypeNode` is from

173+the `HasType` class defined in this file, and it has different instances

174+for `GhcTc` and `GhcRn` that allow it to access the type of the expression

175+when given a typechecked AST:

176+

177+class Data a => HasType a where

178+ getTypeNode :: a -> HieM [HieAST Type]

179+instance HasType (LHsExpr GhcTc) where

180+ getTypeNode e@(L spn e') = ... -- Actually get the type for this expression

181+instance HasType (LHsExpr GhcRn) where

182+ getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type

183+

184+If your subtree doesn't have a span available, you can omit the `makeNode`

185+call and just recurse directly in to the subexpressions.

186+

187+-}

188+

189+-- These synonyms match those defined in main/GHC.hs

190+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]

191+ , Maybe [(LIE GhcRn, Avails)]

192+ , Maybe LHsDocString )

193+type TypecheckedSource = LHsBinds GhcTc

194+

195+

196+{- Note [Name Remapping]

197+The Typechecker introduces new names for mono names in AbsBinds.

198+We don't care about the distinction between mono and poly bindings,

199+so we replace all occurrences of the mono name with the poly name.

200+-}

201+newtype HieState = HieState

202+ { name_remapping :: NameEnv Id

203+ }

204+

205+initState :: HieState

206+initState = HieState emptyNameEnv

207+

208+class ModifyState a where -- See Note [Name Remapping]

209+ addSubstitution :: a -> a -> HieState -> HieState

210+

211+instance ModifyState Name where

212+ addSubstitution _ _ hs = hs

213+

214+instance ModifyState Id where

215+ addSubstitution mono poly hs =

216+ hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}

217+

218+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState

219+modifyState = foldr go id

220+ where

221+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f

222+ go _ f = f

223+

224+type HieM = ReaderT HieState Hsc

225+

226+-- | Construct an 'HieFile' from the outputs of the typechecker.

227+mkHieFile :: ModSummary

228+ -> TcGblEnv

229+ -> RenamedSource

230+ -> BS.ByteString -> Hsc HieFile

231+mkHieFile ms ts rs src = do

232+ let tc_binds = tcg_binds ts

233+ (asts', arr) <- getCompressedAsts tc_binds rs

234+ let Just src_file = ml_hs_file $ ms_location ms

235+ return $ HieFile

236+ { hie_hs_file = src_file

237+ , hie_module = ms_mod ms

238+ , hie_types = arr

239+ , hie_asts = asts'

240+ -- mkIfaceExports sorts the AvailInfos for stability

241+ , hie_exports = mkIfaceExports (tcg_exports ts)

242+ , hie_hs_src = src

243+ }

244+

245+getCompressedAsts :: TypecheckedSource -> RenamedSource

246+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)

247+getCompressedAsts ts rs = do

248+ asts <- enrichHie ts rs

249+ return $ compressTypes asts

250+

251+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)

252+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do

253+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts

254+ rasts <- processGrp hsGrp

255+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports

256+ exps <- toHie $ fmap (map $ IEC Export . fst) exports

257+ let spanFile children = case children of

258+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)

259+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)

260+ (realSrcSpanEnd $ nodeSpan $ last children)

261+

262+ modulify xs =

263+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

264+

265+ asts = HieASTs

266+ $ resolveTyVarScopes

267+ $ M.map (modulify . mergeSortAsts)

268+ $ M.fromListWith (++)

269+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

270+

271+ flat_asts = concat

272+ [ tasts

273+ , rasts

274+ , imps

275+ , exps

276+ ]

277+ return asts

278+ where

279+ processGrp grp = concatM

280+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp

281+ , toHie $ hs_splcds grp

282+ , toHie $ hs_tyclds grp

283+ , toHie $ hs_derivds grp

284+ , toHie $ hs_fixds grp

285+ , toHie $ hs_defds grp

286+ , toHie $ hs_fords grp

287+ , toHie $ hs_warnds grp

288+ , toHie $ hs_annds grp

289+ , toHie $ hs_ruleds grp

290+ ]

291+

292+getRealSpan :: SrcSpan -> Maybe Span

293+getRealSpan (RealSrcSpan sp) = Just sp

294+getRealSpan _ = Nothing

295+

296+grhss_span :: GRHSs p body -> SrcSpan

297+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

298+grhss_span (XGRHSs _) = panic "XGRHS has no span"

299+

300+bindingsOnly :: [Context Name] -> [HieAST a]

301+bindingsOnly [] = []

302+bindingsOnly (C c n : xs) = case nameSrcSpan n of

303+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

304+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

305+ info = mempty{identInfo = S.singleton c}

306+ _ -> bindingsOnly xs

307+

308+concatM :: Monad m => [m [a]] -> m [a]

309+concatM xs = concat <$> sequence xs

310+

311+{- Note [Capturing Scopes and other non local information]

312+toHie is a local tranformation, but scopes of bindings cannot be known locally,

313+hence we have to push the relevant info down into the binding nodes.

314+We use the following types (*Context and *Scoped) to wrap things and

315+carry the required info

316+(Maybe Span) always carries the span of the entire binding, including rhs

317+-}

318+data Context a = C ContextInfo a -- Used for names and bindings

319+

320+data RContext a = RC RecFieldContext a

321+data RFContext a = RFC RecFieldContext (Maybe Span) a

322+-- ^ context for record fields

323+

324+data IEContext a = IEC IEType a

325+-- ^ context for imports/exports

326+

327+data BindContext a = BC BindType Scope a

328+-- ^ context for imports/exports

329+

330+data PatSynFieldContext a = PSC (Maybe Span) a

331+-- ^ context for pattern synonym fields.

332+

333+data SigContext a = SC SigInfo a

334+-- ^ context for type signatures

335+

336+data SigInfo = SI SigType (Maybe Span)

337+

338+data SigType = BindSig | ClassSig | InstSig

339+

340+data RScoped a = RS Scope a

341+-- ^ Scope spans over everything to the right of a, (mostly) not

342+-- including a itself

343+-- (Includes a in a few special cases like recursive do bindings) or

344+-- let/where bindings

345+

346+-- | Pattern scope

347+data PScoped a = PS (Maybe Span)

348+ Scope -- ^ use site of the pattern

349+ Scope -- ^ pattern to the right of a, not including a

350+ a

351+ deriving (Typeable, Data) -- Pattern Scope

352+

353+{- Note [TyVar Scopes]

354+Due to -XScopedTypeVariables, type variables can be in scope quite far from

355+their original binding. We resolve the scope of these type variables

356+in a separate pass

357+-}

358+data TScoped a = TS TyVarScope a -- TyVarScope

359+

360+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

361+-- ^ First scope remains constant

362+-- Second scope is used to build up the scope of a tyvar over

363+-- things to its right, ala RScoped

364+

365+-- | Each element scopes over the elements to the right

366+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

367+listScopes _ [] = []

368+listScopes rhsScope [pat] = [RS rhsScope pat]

369+listScopes rhsScope (pat : pats) = RS sc pat : pats'

370+ where

371+ pats'@((RS scope p):_) = listScopes rhsScope pats

372+ sc = combineScopes scope $ mkScope $ getLoc p

373+

374+-- | 'listScopes' specialised to 'PScoped' things

375+patScopes

376+ :: Maybe Span

377+ -> Scope

378+ -> Scope

379+ -> [LPat (GhcPass p)]

380+ -> [PScoped (LPat (GhcPass p))]

381+patScopes rsp useScope patScope xs =

382+ map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $

383+ listScopes patScope (map dL xs)

384+

385+-- | 'listScopes' specialised to 'TVScoped' things

386+tvScopes

387+ :: TyVarScope

388+ -> Scope

389+ -> [LHsTyVarBndr a]

390+ -> [TVScoped (LHsTyVarBndr a)]

391+tvScopes tvScope rhsScope xs =

392+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

393+

394+{- Note [Scoping Rules for SigPat]

395+Explicitly quantified variables in pattern type signatures are not

396+brought into scope in the rhs, but implicitly quantified variables

397+are (HsWC and HsIB).

398+This is unlike other signatures, where explicitly quantified variables

399+are brought into the RHS Scope

400+For example

401+foo :: forall a. ...;

402+foo = ... -- a is in scope here

403+

404+bar (x :: forall a. a -> a) = ... -- a is not in scope here

405+-- ^ a is in scope here (pattern body)

406+

407+bax (x :: a) = ... -- a is in scope here

408+Because of HsWC and HsIB pass on their scope to their children

409+we must wrap the LHsType in pattern signatures in a

410+Shielded explictly, so that the HsWC/HsIB scope is not passed

411+on the the LHsType

412+-}

413+

414+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

415+

416+type family ProtectedSig a where

417+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

418+ GhcRn

419+ (Shielded (LHsType GhcRn)))

420+ ProtectedSig GhcTc = NoExtField

421+

422+class ProtectSig a where

423+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

424+

425+instance (HasLoc a) => HasLoc (Shielded a) where

426+ loc (SH _ a) = loc a

427+

428+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

429+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

430+

431+instance ProtectSig GhcTc where

432+ protectSig _ _ = noExtField

433+

434+instance ProtectSig GhcRn where

435+ protectSig sc (HsWC a (HsIB b sig)) =

436+ HsWC a (HsIB b (SH sc sig))

437+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec

438+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec

439+

440+class HasLoc a where

441+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

442+ -- know what their implicit bindings are scoping over

443+ loc :: a -> SrcSpan

444+

445+instance HasLoc thing => HasLoc (TScoped thing) where

446+ loc (TS _ a) = loc a

447+

448+instance HasLoc thing => HasLoc (PScoped thing) where

449+ loc (PS _ _ _ a) = loc a

450+

451+instance HasLoc (LHsQTyVars GhcRn) where

452+ loc (HsQTvs _ vs) = loc vs

453+ loc _ = noSrcSpan

454+

455+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

456+ loc (HsIB _ a) = loc a

457+ loc _ = noSrcSpan

458+

459+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

460+ loc (HsWC _ a) = loc a

461+ loc _ = noSrcSpan

462+

463+instance HasLoc (Located a) where

464+ loc (L l _) = l

465+

466+instance HasLoc a => HasLoc [a] where

467+ loc [] = noSrcSpan

468+ loc xs = foldl1' combineSrcSpans $ map loc xs

469+

470+instance HasLoc a => HasLoc (FamEqn s a) where

471+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

472+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

473+ [loc a, loc tvs, loc b, loc c]

474+ loc _ = noSrcSpan

475+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

476+ loc (HsValArg tm) = loc tm

477+ loc (HsTypeArg _ ty) = loc ty

478+ loc (HsArgPar sp) = sp

479+

480+instance HasLoc (HsDataDefn GhcRn) where

481+ loc def@(HsDataDefn{}) = loc $ dd_cons def

482+ -- Only used for data family instances, so we only need rhs

483+ -- Most probably the rest will be unhelpful anyway

484+ loc _ = noSrcSpan

485+

486+{- Note [Real DataCon Name]

487+The typechecker subtitutes the conLikeWrapId for the name, but we don't want

488+this showing up in the hieFile, so we replace the name in the Id with the

489+original datacon name

490+See also Note [Data Constructor Naming]

491+-}

492+class HasRealDataConName p where

493+ getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)

494+

495+instance HasRealDataConName GhcRn where

496+ getRealDataCon _ n = n

497+instance HasRealDataConName GhcTc where

498+ getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =

499+ L sp (setVarName var (conLikeName con))

500+

501+-- | The main worker class

502+-- See Note [Updating HieAst for changes in the GHC AST] for more information

503+-- on how to add/modify instances for this.

504+class ToHie a where

505+ toHie :: a -> HieM [HieAST Type]

506+

507+-- | Used to collect type info

508+class Data a => HasType a where

509+ getTypeNode :: a -> HieM [HieAST Type]

510+

511+instance (ToHie a) => ToHie [a] where

512+ toHie = concatMapM toHie

513+

514+instance (ToHie a) => ToHie (Bag a) where

515+ toHie = toHie . bagToList

516+

517+instance (ToHie a) => ToHie (Maybe a) where

518+ toHie = maybe (pure []) toHie

519+

520+instance ToHie (Context (Located NoExtField)) where

521+ toHie _ = pure []

522+

523+instance ToHie (TScoped NoExtField) where

524+ toHie _ = pure []

525+

526+instance ToHie (IEContext (Located ModuleName)) where

527+ toHie (IEC c (L (RealSrcSpan span) mname)) =

528+ pure $ [Node (NodeInfo S.empty [] idents) span []]

529+ where details = mempty{identInfo = S.singleton (IEThing c)}

530+ idents = M.singleton (Left mname) details

531+ toHie _ = pure []

532+

533+instance ToHie (Context (Located Var)) where

534+ toHie c = case c of

535+ C context (L (RealSrcSpan span) name')

536+ -> do

537+ m <- asks name_remapping

538+ let name = case lookupNameEnv m (varName name') of

539+ Just var -> var

540+ Nothing-> name'

541+ pure

542+ [Node

543+ (NodeInfo S.empty [] $

544+ M.singleton (Right $ varName name)

545+ (IdentifierDetails (Just $ varType name')

546+ (S.singleton context)))

547+ span

548+ []]

549+ _ -> pure []

550+

551+instance ToHie (Context (Located Name)) where

552+ toHie c = case c of

553+ C context (L (RealSrcSpan span) name') -> do

554+ m <- asks name_remapping

555+ let name = case lookupNameEnv m name' of

556+ Just var -> varName var

557+ Nothing -> name'

558+ pure

559+ [Node

560+ (NodeInfo S.empty [] $

561+ M.singleton (Right name)

562+ (IdentifierDetails Nothing

563+ (S.singleton context)))

564+ span

565+ []]

566+ _ -> pure []

567+

568+-- | Dummy instances - never called

569+instance ToHie (TScoped (LHsSigWcType GhcTc)) where

570+ toHie _ = pure []

571+instance ToHie (TScoped (LHsWcType GhcTc)) where

572+ toHie _ = pure []

573+instance ToHie (SigContext (LSig GhcTc)) where

574+ toHie _ = pure []

575+instance ToHie (TScoped Type) where

576+ toHie _ = pure []

577+

578+instance HasType (LHsBind GhcRn) where

579+ getTypeNode (L spn bind) = makeNode bind spn

580+

581+instance HasType (LHsBind GhcTc) where

582+ getTypeNode (L spn bind) = case bind of

583+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

584+ _ -> makeNode bind spn

585+

586+instance HasType (Located (Pat GhcRn)) where

587+ getTypeNode (dL -> L spn pat) = makeNode pat spn

588+

589+instance HasType (Located (Pat GhcTc)) where

590+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

591+

592+instance HasType (LHsExpr GhcRn) where

593+ getTypeNode (L spn e) = makeNode e spn

594+

595+-- | This instance tries to construct 'HieAST' nodes which include the type of

596+-- the expression. It is not yet possible to do this efficiently for all

597+-- expression forms, so we skip filling in the type for those inputs.

598+--

599+-- 'HsApp', for example, doesn't have any type information available directly on

600+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

601+-- query the type of that. Yet both the desugaring call and the type query both

602+-- involve recursive calls to the function and argument! This is particularly

603+-- problematic when you realize that the HIE traversal will eventually visit

604+-- those nodes too and ask for their types again.

605+--

606+-- Since the above is quite costly, we just skip cases where computing the

607+-- expression's type is going to be expensive.

608+--

609+-- See #16233

610+instance HasType (LHsExpr GhcTc) where

611+ getTypeNode e@(L spn e') = lift $

612+ -- Some expression forms have their type immediately available

613+ let tyOpt = case e' of

614+ HsLit _ l -> Just (hsLitType l)

615+ HsOverLit _ o -> Just (overLitType o)

616+

617+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

618+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

619+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

620+

621+ ExplicitList ty _ _ -> Just (mkListTy ty)

622+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

623+ HsDo ty _ _ -> Just ty

624+ HsMultiIf ty _ -> Just ty

625+

626+ _ -> Nothing

627+

628+ in

629+ case tyOpt of

630+ Just t -> makeTypeNode e' spn t

631+ Nothing

632+ | skipDesugaring e' -> fallback

633+ | otherwise -> do

634+ hs_env <- Hsc $ \e w -> return (e,w)

635+ (_,mbe) <- liftIO $ deSugarExpr hs_env e

636+ maybe fallback (makeTypeNode e' spn . exprType) mbe

637+ where

638+ fallback = makeNode e' spn

639+

640+ matchGroupType :: MatchGroupTc -> Type

641+ matchGroupType (MatchGroupTc args res) = mkVisFunTys args res

642+

643+ -- | Skip desugaring of these expressions for performance reasons.

644+ --

645+ -- See impact on Haddock output (esp. missing type annotations or links)

646+ -- before marking more things here as 'False'. See impact on Haddock

647+ -- performance before marking more things as 'True'.

648+ skipDesugaring :: HsExpr a -> Bool

649+ skipDesugaring e = case e of

650+ HsVar{} -> False

651+ HsUnboundVar{} -> False

652+ HsConLikeOut{} -> False

653+ HsRecFld{} -> False

654+ HsOverLabel{} -> False

655+ HsIPVar{} -> False

656+ HsWrap{} -> False

657+ _ -> True

658+

659+instance ( ToHie (Context (Located (IdP a)))

660+ , ToHie (MatchGroup a (LHsExpr a))

661+ , ToHie (PScoped (LPat a))

662+ , ToHie (GRHSs a (LHsExpr a))

663+ , ToHie (LHsExpr a)

664+ , ToHie (Located (PatSynBind a a))

665+ , HasType (LHsBind a)

666+ , ModifyState (IdP a)

667+ , Data (HsBind a)

668+ ) => ToHie (BindContext (LHsBind a)) where

669+ toHie (BC context scope b@(L span bind)) =

670+ concatM $ getTypeNode b : case bind of

671+ FunBind{fun_id = name, fun_matches = matches} ->

672+ [ toHie $ C (ValBind context scope $ getRealSpan span) name

673+ , toHie matches

674+ ]

675+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

676+ [ toHie $ PS (getRealSpan span) scope NoScope lhs

677+ , toHie rhs

678+ ]

679+ VarBind{var_rhs = expr} ->

680+ [ toHie expr

681+ ]

682+ AbsBinds{abs_exports = xs, abs_binds = binds} ->

683+ [ local (modifyState xs) $ -- Note [Name Remapping]

684+ toHie $ fmap (BC context scope) binds

685+ ]

686+ PatSynBind _ psb ->

687+ [ toHie $ L span psb -- PatSynBinds only occur at the top level

688+ ]

689+ XHsBindsLR _ -> []

690+

691+instance ( ToHie (LMatch a body)

692+ ) => ToHie (MatchGroup a body) where

693+ toHie mg = concatM $ case mg of

694+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

695+ [ pure $ locOnly span

696+ , toHie alts

697+ ]

698+ MG{} -> []

699+ XMatchGroup _ -> []

700+

701+instance ( ToHie (Context (Located (IdP a)))

702+ , ToHie (PScoped (LPat a))

703+ , ToHie (HsPatSynDir a)

704+ ) => ToHie (Located (PatSynBind a a)) where

705+ toHie (L sp psb) = concatM $ case psb of

706+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

707+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

708+ , toHie $ toBind dets

709+ , toHie $ PS Nothing lhsScope NoScope pat

710+ , toHie dir

711+ ]

712+ where

713+ lhsScope = combineScopes varScope detScope

714+ varScope = mkLScope var

715+ detScope = case dets of

716+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

717+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

718+ (RecCon r) -> foldr go NoScope r

719+ go (RecordPatSynField a b) c = combineScopes c

720+ $ combineScopes (mkLScope a) (mkLScope b)

721+ detSpan = case detScope of

722+ LocalScope a -> Just a

723+ _ -> Nothing

724+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args

725+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

726+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r

727+ XPatSynBind _ -> []

728+

729+instance ( ToHie (MatchGroup a (LHsExpr a))

730+ ) => ToHie (HsPatSynDir a) where

731+ toHie dir = case dir of

732+ ExplicitBidirectional mg -> toHie mg

733+ _ -> pure []

734+

735+instance ( a ~ GhcPass p

736+ , ToHie body

737+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

738+ , ToHie (PScoped (LPat a))

739+ , ToHie (GRHSs a body)

740+ , Data (Match a body)

741+ ) => ToHie (LMatch (GhcPass p) body) where

742+ toHie (L span m ) = concatM $ makeNode m span : case m of

743+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

744+ [ toHie mctx

745+ , let rhsScope = mkScope $ grhss_span grhss

746+ in toHie $ patScopes Nothing rhsScope NoScope pats

747+ , toHie grhss

748+ ]

749+ XMatch _ -> []

750+

751+instance ( ToHie (Context (Located a))

752+ ) => ToHie (HsMatchContext a) where

753+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

754+ toHie (StmtCtxt a) = toHie a

755+ toHie _ = pure []

756+

757+instance ( ToHie (HsMatchContext a)

758+ ) => ToHie (HsStmtContext a) where

759+ toHie (PatGuard a) = toHie a

760+ toHie (ParStmtCtxt a) = toHie a

761+ toHie (TransStmtCtxt a) = toHie a

762+ toHie _ = pure []

763+

764+instance ( a ~ GhcPass p

765+ , ToHie (Context (Located (IdP a)))

766+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

767+ , ToHie (LHsExpr a)

768+ , ToHie (TScoped (LHsSigWcType a))

769+ , ProtectSig a

770+ , ToHie (TScoped (ProtectedSig a))

771+ , HasType (LPat a)

772+ , Data (HsSplice a)

773+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where

774+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

775+ concatM $ getTypeNode lpat : case opat of

776+ WildPat _ ->

777+ []

778+ VarPat _ lname ->

779+ [ toHie $ C (PatternBind scope pscope rsp) lname

780+ ]

781+ LazyPat _ p ->

782+ [ toHie $ PS rsp scope pscope p

783+ ]

784+ AsPat _ lname pat ->

785+ [ toHie $ C (PatternBind scope

786+ (combineScopes (mkLScope (dL pat)) pscope)

787+ rsp)

788+ lname

789+ , toHie $ PS rsp scope pscope pat

790+ ]

791+ ParPat _ pat ->

792+ [ toHie $ PS rsp scope pscope pat

793+ ]

794+ BangPat _ pat ->

795+ [ toHie $ PS rsp scope pscope pat

796+ ]

797+ ListPat _ pats ->

798+ [ toHie $ patScopes rsp scope pscope pats

799+ ]

800+ TuplePat _ pats _ ->

801+ [ toHie $ patScopes rsp scope pscope pats

802+ ]

803+ SumPat _ pat _ _ ->

804+ [ toHie $ PS rsp scope pscope pat

805+ ]

806+ ConPatIn c dets ->

807+ [ toHie $ C Use c

808+ , toHie $ contextify dets

809+ ]

810+ ConPatOut {pat_con = con, pat_args = dets}->

811+ [ toHie $ C Use $ fmap conLikeName con

812+ , toHie $ contextify dets

813+ ]

814+ ViewPat _ expr pat ->

815+ [ toHie expr

816+ , toHie $ PS rsp scope pscope pat

817+ ]

818+ SplicePat _ sp ->

819+ [ toHie $ L ospan sp

820+ ]

821+ LitPat _ _ ->

822+ []

823+ NPat _ _ _ _ ->

824+ []

825+ NPlusKPat _ n _ _ _ _ ->

826+ [ toHie $ C (PatternBind scope pscope rsp) n

827+ ]

828+ SigPat _ pat sig ->

829+ [ toHie $ PS rsp scope pscope pat

830+ , let cscope = mkLScope (dL pat) in

831+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])

832+ (protectSig @a cscope sig)

833+ -- See Note [Scoping Rules for SigPat]

834+ ]

835+ CoPat _ _ _ _ ->

836+ []

837+ XPat _ -> []

838+ where

839+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

840+ contextify (InfixCon a b) = InfixCon a' b'

841+ where [a', b'] = patScopes rsp scope pscope [a,b]

842+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

843+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

844+ where

845+ go (RS fscope (L spn (HsRecField lbl pat pun))) =

846+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

847+ scoped_fds = listScopes pscope fds

848+

849+instance ( ToHie body

850+ , ToHie (LGRHS a body)

851+ , ToHie (RScoped (LHsLocalBinds a))

852+ ) => ToHie (GRHSs a body) where

853+ toHie grhs = concatM $ case grhs of

854+ GRHSs _ grhss binds ->

855+ [ toHie grhss

856+ , toHie $ RS (mkScope $ grhss_span grhs) binds

857+ ]

858+ XGRHSs _ -> []

859+

860+instance ( ToHie (Located body)

861+ , ToHie (RScoped (GuardLStmt a))

862+ , Data (GRHS a (Located body))

863+ ) => ToHie (LGRHS a (Located body)) where

864+ toHie (L span g) = concatM $ makeNode g span : case g of

865+ GRHS _ guards body ->

866+ [ toHie $ listScopes (mkLScope body) guards

867+ , toHie body

868+ ]

869+ XGRHS _ -> []

870+

871+instance ( a ~ GhcPass p

872+ , ToHie (Context (Located (IdP a)))

873+ , HasType (LHsExpr a)

874+ , ToHie (PScoped (LPat a))

875+ , ToHie (MatchGroup a (LHsExpr a))

876+ , ToHie (LGRHS a (LHsExpr a))

877+ , ToHie (RContext (HsRecordBinds a))

878+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

879+ , ToHie (ArithSeqInfo a)

880+ , ToHie (LHsCmdTop a)

881+ , ToHie (RScoped (GuardLStmt a))

882+ , ToHie (RScoped (LHsLocalBinds a))

883+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))

884+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

885+ , Data (HsExpr a)

886+ , Data (HsSplice a)

887+ , Data (HsTupArg a)

888+ , Data (AmbiguousFieldOcc a)

889+ , (HasRealDataConName a)

890+ ) => ToHie (LHsExpr (GhcPass p)) where

891+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

892+ HsVar _ (L _ var) ->

893+ [ toHie $ C Use (L mspan var)

894+ -- Patch up var location since typechecker removes it

895+ ]

896+ HsUnboundVar _ _ ->

897+ []

898+ HsConLikeOut _ con ->

899+ [ toHie $ C Use $ L mspan $ conLikeName con

900+ ]

901+ HsRecFld _ fld ->

902+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

903+ ]

904+ HsOverLabel _ _ _ -> []

905+ HsIPVar _ _ -> []

906+ HsOverLit _ _ -> []

907+ HsLit _ _ -> []

908+ HsLam _ mg ->

909+ [ toHie mg

910+ ]

911+ HsLamCase _ mg ->

912+ [ toHie mg

913+ ]

914+ HsApp _ a b ->

915+ [ toHie a

916+ , toHie b

917+ ]

918+ HsAppType _ expr sig ->

919+ [ toHie expr

920+ , toHie $ TS (ResolvedScopes []) sig

921+ ]

922+ OpApp _ a b c ->

923+ [ toHie a

924+ , toHie b

925+ , toHie c

926+ ]

927+ NegApp _ a _ ->

928+ [ toHie a

929+ ]

930+ HsPar _ a ->

931+ [ toHie a

932+ ]

933+ SectionL _ a b ->

934+ [ toHie a

935+ , toHie b

936+ ]

937+ SectionR _ a b ->

938+ [ toHie a

939+ , toHie b

940+ ]

941+ ExplicitTuple _ args _ ->

942+ [ toHie args

943+ ]

944+ ExplicitSum _ _ _ expr ->

945+ [ toHie expr

946+ ]

947+ HsCase _ expr matches ->

948+ [ toHie expr

949+ , toHie matches

950+ ]

951+ HsIf _ _ a b c ->

952+ [ toHie a

953+ , toHie b

954+ , toHie c

955+ ]

956+ HsMultiIf _ grhss ->

957+ [ toHie grhss

958+ ]

959+ HsLet _ binds expr ->

960+ [ toHie $ RS (mkLScope expr) binds

961+ , toHie expr

962+ ]

963+ HsDo _ _ (L ispan stmts) ->

964+ [ pure $ locOnly ispan

965+ , toHie $ listScopes NoScope stmts

966+ ]

967+ ExplicitList _ _ exprs ->

968+ [ toHie exprs

969+ ]

970+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->

971+ [ toHie $ C Use (getRealDataCon @a mrealcon name)

972+ -- See Note [Real DataCon Name]

973+ , toHie $ RC RecFieldAssign $ binds

974+ ]

975+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->

976+ [ toHie expr

977+ , toHie $ map (RC RecFieldAssign) upds

978+ ]

979+ ExprWithTySig _ expr sig ->

980+ [ toHie expr

981+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

982+ ]

983+ ArithSeq _ _ info ->

984+ [ toHie info

985+ ]

986+ HsSCC _ _ _ expr ->

987+ [ toHie expr

988+ ]

989+ HsCoreAnn _ _ _ expr ->

990+ [ toHie expr

991+ ]

992+ HsProc _ pat cmdtop ->

993+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

994+ , toHie cmdtop

995+ ]

996+ HsStatic _ expr ->

997+ [ toHie expr

998+ ]

999+ HsTick _ _ expr ->

1000+ [ toHie expr

1001+ ]

1002+ HsBinTick _ _ _ expr ->

1003+ [ toHie expr

1004+ ]

1005+ HsTickPragma _ _ _ _ expr ->

1006+ [ toHie expr

1007+ ]

1008+ HsWrap _ _ a ->

1009+ [ toHie $ L mspan a

1010+ ]

1011+ HsBracket _ b ->

1012+ [ toHie b

1013+ ]

1014+ HsRnBracketOut _ b p ->

1015+ [ toHie b

1016+ , toHie p

1017+ ]

1018+ HsTcBracketOut _ b p ->

1019+ [ toHie b

1020+ , toHie p

1021+ ]

1022+ HsSpliceE _ x ->

1023+ [ toHie $ L mspan x

1024+ ]

1025+ XExpr _ -> []

1026+

1027+instance ( a ~ GhcPass p

1028+ , ToHie (LHsExpr a)

1029+ , Data (HsTupArg a)

1030+ ) => ToHie (LHsTupArg (GhcPass p)) where

1031+ toHie (L span arg) = concatM $ makeNode arg span : case arg of

1032+ Present _ expr ->

1033+ [ toHie expr

1034+ ]

1035+ Missing _ -> []

1036+ XTupArg _ -> []

1037+

1038+instance ( a ~ GhcPass p

1039+ , ToHie (PScoped (LPat a))

1040+ , ToHie (LHsExpr a)

1041+ , ToHie (SigContext (LSig a))

1042+ , ToHie (RScoped (LHsLocalBinds a))

1043+ , ToHie (RScoped (ApplicativeArg a))

1044+ , ToHie (Located body)

1045+ , Data (StmtLR a a (Located body))

1046+ , Data (StmtLR a a (Located (HsExpr a)))

1047+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

1048+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

1049+ LastStmt _ body _ _ ->

1050+ [ toHie body

1051+ ]

1052+ BindStmt _ pat body _ _ ->

1053+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

1054+ , toHie body

1055+ ]

1056+ ApplicativeStmt _ stmts _ ->

1057+ [ concatMapM (toHie . RS scope . snd) stmts

1058+ ]

1059+ BodyStmt _ body _ _ ->

1060+ [ toHie body

1061+ ]

1062+ LetStmt _ binds ->

1063+ [ toHie $ RS scope binds

1064+ ]

1065+ ParStmt _ parstmts _ _ ->

1066+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

1067+ toHie $ listScopes NoScope stmts)

1068+ parstmts

1069+ ]

1070+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

1071+ [ toHie $ listScopes scope stmts

1072+ , toHie using

1073+ , toHie by

1074+ ]

1075+ RecStmt {recS_stmts = stmts} ->

1076+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

1077+ ]

1078+ XStmtLR _ -> []

1079+

1080+instance ( ToHie (LHsExpr a)

1081+ , ToHie (PScoped (LPat a))

1082+ , ToHie (BindContext (LHsBind a))

1083+ , ToHie (SigContext (LSig a))

1084+ , ToHie (RScoped (HsValBindsLR a a))

1085+ , Data (HsLocalBinds a)

1086+ ) => ToHie (RScoped (LHsLocalBinds a)) where

1087+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

1088+ EmptyLocalBinds _ -> []

1089+ HsIPBinds _ _ -> []

1090+ HsValBinds _ valBinds ->

1091+ [ toHie $ RS (combineScopes scope $ mkScope sp)

1092+ valBinds

1093+ ]

1094+ XHsLocalBindsLR _ -> []

1095+

1096+instance ( ToHie (BindContext (LHsBind a))

1097+ , ToHie (SigContext (LSig a))

1098+ , ToHie (RScoped (XXValBindsLR a a))

1099+ ) => ToHie (RScoped (HsValBindsLR a a)) where

1100+ toHie (RS sc v) = concatM $ case v of

1101+ ValBinds _ binds sigs ->

1102+ [ toHie $ fmap (BC RegularBind sc) binds

1103+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1104+ ]

1105+ XValBindsLR x -> [ toHie $ RS sc x ]

1106+

1107+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

1108+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1109+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1110+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1111+ ]

1112+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

1113+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1114+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1115+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1116+ ]

1117+

1118+instance ( ToHie (RContext (LHsRecField a arg))

1119+ ) => ToHie (RContext (HsRecFields a arg)) where

1120+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

1121+

1122+instance ( ToHie (RFContext (Located label))

1123+ , ToHie arg

1124+ , HasLoc arg

1125+ , Data label

1126+ , Data arg

1127+ ) => ToHie (RContext (LHsRecField' label arg)) where

1128+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

1129+ HsRecField label expr _ ->

1130+ [ toHie $ RFC c (getRealSpan $ loc expr) label

1131+ , toHie expr

1132+ ]

1133+

1134+removeDefSrcSpan :: Name -> Name

1135+removeDefSrcSpan n = setNameLoc n noSrcSpan

1136+

1137+instance ToHie (RFContext (LFieldOcc GhcRn)) where

1138+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1139+ FieldOcc name _ ->

1140+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1141+ ]

1142+ XFieldOcc _ -> []

1143+

1144+instance ToHie (RFContext (LFieldOcc GhcTc)) where

1145+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1146+ FieldOcc var _ ->

1147+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1148+ in [ toHie $ C (RecField c rhs) (L nspan var')

1149+ ]

1150+ XFieldOcc _ -> []

1151+

1152+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1153+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1154+ Unambiguous name _ ->

1155+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1156+ ]

1157+ Ambiguous _name _ ->

1158+ [ ]

1159+ XAmbiguousFieldOcc _ -> []

1160+

1161+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1162+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1163+ Unambiguous var _ ->

1164+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1165+ in [ toHie $ C (RecField c rhs) (L nspan var')

1166+ ]

1167+ Ambiguous var _ ->

1168+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1169+ in [ toHie $ C (RecField c rhs) (L nspan var')

1170+ ]

1171+ XAmbiguousFieldOcc _ -> []

1172+

1173+instance ( a ~ GhcPass p

1174+ , ToHie (PScoped (LPat a))

1175+ , ToHie (BindContext (LHsBind a))

1176+ , ToHie (LHsExpr a)

1177+ , ToHie (SigContext (LSig a))

1178+ , ToHie (RScoped (HsValBindsLR a a))

1179+ , Data (StmtLR a a (Located (HsExpr a)))

1180+ , Data (HsLocalBinds a)

1181+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1182+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM

1183+ [ toHie $ PS Nothing sc NoScope pat

1184+ , toHie expr

1185+ ]

1186+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1187+ [ toHie $ listScopes NoScope stmts

1188+ , toHie $ PS Nothing sc NoScope pat

1189+ ]

1190+ toHie (RS _ (XApplicativeArg _)) = pure []

1191+

1192+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1193+ toHie (PrefixCon args) = toHie args

1194+ toHie (RecCon rec) = toHie rec

1195+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1196+

1197+instance ( ToHie (LHsCmd a)

1198+ , Data (HsCmdTop a)

1199+ ) => ToHie (LHsCmdTop a) where

1200+ toHie (L span top) = concatM $ makeNode top span : case top of

1201+ HsCmdTop _ cmd ->

1202+ [ toHie cmd

1203+ ]

1204+ XCmdTop _ -> []

1205+

1206+instance ( a ~ GhcPass p

1207+ , ToHie (PScoped (LPat a))

1208+ , ToHie (BindContext (LHsBind a))

1209+ , ToHie (LHsExpr a)

1210+ , ToHie (MatchGroup a (LHsCmd a))

1211+ , ToHie (SigContext (LSig a))

1212+ , ToHie (RScoped (HsValBindsLR a a))

1213+ , Data (HsCmd a)

1214+ , Data (HsCmdTop a)

1215+ , Data (StmtLR a a (Located (HsCmd a)))

1216+ , Data (HsLocalBinds a)

1217+ , Data (StmtLR a a (Located (HsExpr a)))

1218+ ) => ToHie (LHsCmd (GhcPass p)) where

1219+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1220+ HsCmdArrApp _ a b _ _ ->

1221+ [ toHie a

1222+ , toHie b

1223+ ]

1224+ HsCmdArrForm _ a _ _ cmdtops ->

1225+ [ toHie a

1226+ , toHie cmdtops

1227+ ]

1228+ HsCmdApp _ a b ->

1229+ [ toHie a

1230+ , toHie b

1231+ ]

1232+ HsCmdLam _ mg ->

1233+ [ toHie mg

1234+ ]

1235+ HsCmdPar _ a ->

1236+ [ toHie a

1237+ ]

1238+ HsCmdCase _ expr alts ->

1239+ [ toHie expr

1240+ , toHie alts

1241+ ]

1242+ HsCmdIf _ _ a b c ->

1243+ [ toHie a

1244+ , toHie b

1245+ , toHie c

1246+ ]

1247+ HsCmdLet _ binds cmd' ->

1248+ [ toHie $ RS (mkLScope cmd') binds

1249+ , toHie cmd'

1250+ ]

1251+ HsCmdDo _ (L ispan stmts) ->

1252+ [ pure $ locOnly ispan

1253+ , toHie $ listScopes NoScope stmts

1254+ ]

1255+ HsCmdWrap _ _ _ -> []

1256+ XCmd _ -> []

1257+

1258+instance ToHie (TyClGroup GhcRn) where

1259+ toHie TyClGroup{ group_tyclds = classes

1260+ , group_roles = roles

1261+ , group_kisigs = sigs

1262+ , group_instds = instances } =

1263+ concatM

1264+ [ toHie classes

1265+ , toHie sigs

1266+ , toHie roles

1267+ , toHie instances

1268+ ]

1269+ toHie (XTyClGroup _) = pure []

1270+

1271+instance ToHie (LTyClDecl GhcRn) where

1272+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1273+ FamDecl {tcdFam = fdecl} ->

1274+ [ toHie (L span fdecl)

1275+ ]

1276+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1277+ [ toHie $ C (Decl SynDec $ getRealSpan span) name

1278+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1279+ , toHie typ

1280+ ]

1281+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1282+ [ toHie $ C (Decl DataDec $ getRealSpan span) name

1283+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1284+ , toHie defn

1285+ ]

1286+ where

1287+ quant_scope = mkLScope $ dd_ctxt defn

1288+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1289+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1290+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1291+ deriv_sc = mkLScope $ dd_derivs defn

1292+ ClassDecl { tcdCtxt = context

1293+ , tcdLName = name

1294+ , tcdTyVars = vars

1295+ , tcdFDs = deps

1296+ , tcdSigs = sigs

1297+ , tcdMeths = meths

1298+ , tcdATs = typs

1299+ , tcdATDefs = deftyps

1300+ } ->

1301+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1302+ , toHie context

1303+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1304+ , toHie deps

1305+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1306+ , toHie $ fmap (BC InstanceBind ModuleScope) meths

1307+ , toHie typs

1308+ , concatMapM (pure . locOnly . getLoc) deftyps

1309+ , toHie deftyps

1310+ ]

1311+ where

1312+ context_scope = mkLScope context

1313+ rhs_scope = foldl1' combineScopes $ map mkScope

1314+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1315+ XTyClDecl _ -> []

1316+

1317+instance ToHie (LFamilyDecl GhcRn) where

1318+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1319+ FamilyDecl _ info name vars _ sig inj ->

1320+ [ toHie $ C (Decl FamDec $ getRealSpan span) name

1321+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1322+ , toHie info

1323+ , toHie $ RS injSpan sig

1324+ , toHie inj

1325+ ]

1326+ where

1327+ rhsSpan = sigSpan `combineScopes` injSpan

1328+ sigSpan = mkScope $ getLoc sig

1329+ injSpan = maybe NoScope (mkScope . getLoc) inj

1330+ XFamilyDecl _ -> []

1331+

1332+instance ToHie (FamilyInfo GhcRn) where

1333+ toHie (ClosedTypeFamily (Just eqns)) = concatM $

1334+ [ concatMapM (pure . locOnly . getLoc) eqns

1335+ , toHie $ map go eqns

1336+ ]

1337+ where

1338+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1339+ toHie _ = pure []

1340+

1341+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1342+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1343+ NoSig _ ->

1344+ []

1345+ KindSig _ k ->

1346+ [ toHie k

1347+ ]

1348+ TyVarSig _ bndr ->

1349+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1350+ ]

1351+ XFamilyResultSig _ -> []

1352+

1353+instance ToHie (Located (FunDep (Located Name))) where

1354+ toHie (L span fd@(lhs, rhs)) = concatM $

1355+ [ makeNode fd span

1356+ , toHie $ map (C Use) lhs

1357+ , toHie $ map (C Use) rhs

1358+ ]

1359+

1360+instance (ToHie rhs, HasLoc rhs)

1361+ => ToHie (TScoped (FamEqn GhcRn rhs)) where

1362+ toHie (TS _ f) = toHie f

1363+

1364+instance (ToHie rhs, HasLoc rhs)

1365+ => ToHie (FamEqn GhcRn rhs) where

1366+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1367+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1368+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1369+ , toHie pats

1370+ , toHie rhs

1371+ ]

1372+ where scope = combineScopes patsScope rhsScope

1373+ patsScope = mkScope (loc pats)

1374+ rhsScope = mkScope (loc rhs)

1375+ toHie (XFamEqn _) = pure []

1376+

1377+instance ToHie (LInjectivityAnn GhcRn) where

1378+ toHie (L span ann) = concatM $ makeNode ann span : case ann of

1379+ InjectivityAnn lhs rhs ->

1380+ [ toHie $ C Use lhs

1381+ , toHie $ map (C Use) rhs

1382+ ]

1383+

1384+instance ToHie (HsDataDefn GhcRn) where

1385+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1386+ [ toHie ctx

1387+ , toHie mkind

1388+ , toHie cons

1389+ , toHie derivs

1390+ ]

1391+ toHie (XHsDataDefn _) = pure []

1392+

1393+instance ToHie (HsDeriving GhcRn) where

1394+ toHie (L span clauses) = concatM

1395+ [ pure $ locOnly span

1396+ , toHie clauses

1397+ ]

1398+

1399+instance ToHie (LHsDerivingClause GhcRn) where

1400+ toHie (L span cl) = concatM $ makeNode cl span : case cl of

1401+ HsDerivingClause _ strat (L ispan tys) ->

1402+ [ toHie strat

1403+ , pure $ locOnly ispan

1404+ , toHie $ map (TS (ResolvedScopes [])) tys

1405+ ]

1406+ XHsDerivingClause _ -> []

1407+

1408+instance ToHie (Located (DerivStrategy GhcRn)) where

1409+ toHie (L span strat) = concatM $ makeNode strat span : case strat of

1410+ StockStrategy -> []

1411+ AnyclassStrategy -> []

1412+ NewtypeStrategy -> []

1413+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1414+

1415+instance ToHie (Located OverlapMode) where

1416+ toHie (L span _) = pure $ locOnly span

1417+

1418+instance ToHie (LConDecl GhcRn) where

1419+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1420+ ConDeclGADT { con_names = names, con_qvars = qvars

1421+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1422+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1423+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1424+ , toHie ctx

1425+ , toHie args

1426+ , toHie typ

1427+ ]

1428+ where

1429+ rhsScope = combineScopes argsScope tyScope

1430+ ctxScope = maybe NoScope mkLScope ctx

1431+ argsScope = condecl_scope args

1432+ tyScope = mkLScope typ

1433+ ConDeclH98 { con_name = name, con_ex_tvs = qvars

1434+ , con_mb_cxt = ctx, con_args = dets } ->

1435+ [ toHie $ C (Decl ConDec $ getRealSpan span) name

1436+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1437+ , toHie ctx

1438+ , toHie dets

1439+ ]

1440+ where

1441+ rhsScope = combineScopes ctxScope argsScope

1442+ ctxScope = maybe NoScope mkLScope ctx

1443+ argsScope = condecl_scope dets

1444+ XConDecl _ -> []

1445+ where condecl_scope args = case args of

1446+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1447+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1448+ RecCon x -> mkLScope x

1449+

1450+instance ToHie (Located [LConDeclField GhcRn]) where

1451+ toHie (L span decls) = concatM $

1452+ [ pure $ locOnly span

1453+ , toHie decls

1454+ ]

1455+

1456+instance ( HasLoc thing

1457+ , ToHie (TScoped thing)

1458+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1459+ toHie (TS sc (HsIB ibrn a)) = concatM $

1460+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1461+ , toHie $ TS sc a

1462+ ]

1463+ where span = loc a

1464+ toHie (TS _ (XHsImplicitBndrs _)) = pure []

1465+

1466+instance ( HasLoc thing

1467+ , ToHie (TScoped thing)

1468+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1469+ toHie (TS sc (HsWC names a)) = concatM $

1470+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1471+ , toHie $ TS sc a

1472+ ]

1473+ where span = loc a

1474+ toHie (TS _ (XHsWildCardBndrs _)) = pure []

1475+

1476+instance ToHie (LStandaloneKindSig GhcRn) where

1477+ toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]

1478+

1479+instance ToHie (StandaloneKindSig GhcRn) where

1480+ toHie sig = concatM $ case sig of

1481+ StandaloneKindSig _ name typ ->

1482+ [ toHie $ C TyDecl name

1483+ , toHie $ TS (ResolvedScopes []) typ

1484+ ]

1485+ XStandaloneKindSig _ -> []

1486+

1487+instance ToHie (SigContext (LSig GhcRn)) where

1488+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1489+ TypeSig _ names typ ->

1490+ [ toHie $ map (C TyDecl) names

1491+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1492+ ]

1493+ PatSynSig _ names typ ->

1494+ [ toHie $ map (C TyDecl) names

1495+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1496+ ]

1497+ ClassOpSig _ _ names typ ->

1498+ [ case styp of

1499+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1500+ _ -> toHie $ map (C $ TyDecl) names

1501+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1502+ ]

1503+ IdSig _ _ -> []

1504+ FixSig _ fsig ->

1505+ [ toHie $ L sp fsig

1506+ ]

1507+ InlineSig _ name _ ->

1508+ [ toHie $ (C Use) name

1509+ ]

1510+ SpecSig _ name typs _ ->

1511+ [ toHie $ (C Use) name

1512+ , toHie $ map (TS (ResolvedScopes [])) typs

1513+ ]

1514+ SpecInstSig _ _ typ ->

1515+ [ toHie $ TS (ResolvedScopes []) typ

1516+ ]

1517+ MinimalSig _ _ form ->

1518+ [ toHie form

1519+ ]

1520+ SCCFunSig _ _ name mtxt ->

1521+ [ toHie $ (C Use) name

1522+ , pure $ maybe [] (locOnly . getLoc) mtxt

1523+ ]

1524+ CompleteMatchSig _ _ (L ispan names) typ ->

1525+ [ pure $ locOnly ispan

1526+ , toHie $ map (C Use) names

1527+ , toHie $ fmap (C Use) typ

1528+ ]

1529+ XSig _ -> []

1530+

1531+instance ToHie (LHsType GhcRn) where

1532+ toHie x = toHie $ TS (ResolvedScopes []) x

1533+

1534+instance ToHie (TScoped (LHsType GhcRn)) where

1535+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1536+ HsForAllTy _ _ bndrs body ->

1537+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1538+ , toHie body

1539+ ]

1540+ HsQualTy _ ctx body ->

1541+ [ toHie ctx

1542+ , toHie body

1543+ ]

1544+ HsTyVar _ _ var ->

1545+ [ toHie $ C Use var

1546+ ]

1547+ HsAppTy _ a b ->

1548+ [ toHie a

1549+ , toHie b

1550+ ]

1551+ HsAppKindTy _ ty ki ->

1552+ [ toHie ty

1553+ , toHie $ TS (ResolvedScopes []) ki

1554+ ]

1555+ HsFunTy _ a b ->

1556+ [ toHie a

1557+ , toHie b

1558+ ]

1559+ HsListTy _ a ->

1560+ [ toHie a

1561+ ]

1562+ HsTupleTy _ _ tys ->

1563+ [ toHie tys

1564+ ]

1565+ HsSumTy _ tys ->

1566+ [ toHie tys

1567+ ]

1568+ HsOpTy _ a op b ->

1569+ [ toHie a

1570+ , toHie $ C Use op

1571+ , toHie b

1572+ ]

1573+ HsParTy _ a ->

1574+ [ toHie a

1575+ ]

1576+ HsIParamTy _ ip ty ->

1577+ [ toHie ip

1578+ , toHie ty

1579+ ]

1580+ HsKindSig _ a b ->

1581+ [ toHie a

1582+ , toHie b

1583+ ]

1584+ HsSpliceTy _ a ->

1585+ [ toHie $ L span a

1586+ ]

1587+ HsDocTy _ a _ ->

1588+ [ toHie a

1589+ ]

1590+ HsBangTy _ _ ty ->

1591+ [ toHie ty

1592+ ]

1593+ HsRecTy _ fields ->

1594+ [ toHie fields

1595+ ]

1596+ HsExplicitListTy _ _ tys ->

1597+ [ toHie tys

1598+ ]

1599+ HsExplicitTupleTy _ tys ->

1600+ [ toHie tys

1601+ ]

1602+ HsTyLit _ _ -> []

1603+ HsWildCardTy _ -> []

1604+ HsStarTy _ _ -> []

1605+ XHsType _ -> []

1606+

1607+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1608+ toHie (HsValArg tm) = toHie tm

1609+ toHie (HsTypeArg _ ty) = toHie ty

1610+ toHie (HsArgPar sp) = pure $ locOnly sp

1611+

1612+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1613+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1614+ UserTyVar _ var ->

1615+ [ toHie $ C (TyVarBind sc tsc) var

1616+ ]

1617+ KindedTyVar _ var kind ->

1618+ [ toHie $ C (TyVarBind sc tsc) var

1619+ , toHie kind

1620+ ]

1621+ XTyVarBndr _ -> []

1622+

1623+instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1624+ toHie (TS sc (HsQTvs implicits vars)) = concatM $

1625+ [ pure $ bindingsOnly bindings

1626+ , toHie $ tvScopes sc NoScope vars

1627+ ]

1628+ where

1629+ varLoc = loc vars

1630+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1631+ toHie (TS _ (XLHsQTyVars _)) = pure []

1632+

1633+instance ToHie (LHsContext GhcRn) where

1634+ toHie (L span tys) = concatM $

1635+ [ pure $ locOnly span

1636+ , toHie tys

1637+ ]

1638+

1639+instance ToHie (LConDeclField GhcRn) where

1640+ toHie (L span field) = concatM $ makeNode field span : case field of

1641+ ConDeclField _ fields typ _ ->

1642+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1643+ , toHie typ

1644+ ]

1645+ XConDeclField _ -> []

1646+

1647+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1648+ toHie (From expr) = toHie expr

1649+ toHie (FromThen a b) = concatM $

1650+ [ toHie a

1651+ , toHie b

1652+ ]

1653+ toHie (FromTo a b) = concatM $

1654+ [ toHie a

1655+ , toHie b

1656+ ]

1657+ toHie (FromThenTo a b c) = concatM $

1658+ [ toHie a

1659+ , toHie b

1660+ , toHie c

1661+ ]

1662+

1663+instance ToHie (LSpliceDecl GhcRn) where

1664+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1665+ SpliceDecl _ splice _ ->

1666+ [ toHie splice

1667+ ]

1668+ XSpliceDecl _ -> []

1669+

1670+instance ToHie (HsBracket a) where

1671+ toHie _ = pure []

1672+

1673+instance ToHie PendingRnSplice where

1674+ toHie _ = pure []

1675+

1676+instance ToHie PendingTcSplice where

1677+ toHie _ = pure []

1678+

1679+instance ToHie (LBooleanFormula (Located Name)) where

1680+ toHie (L span form) = concatM $ makeNode form span : case form of

1681+ Var a ->

1682+ [ toHie $ C Use a

1683+ ]

1684+ And forms ->

1685+ [ toHie forms

1686+ ]

1687+ Or forms ->

1688+ [ toHie forms

1689+ ]

1690+ Parens f ->

1691+ [ toHie f

1692+ ]

1693+

1694+instance ToHie (Located HsIPName) where

1695+ toHie (L span e) = makeNode e span

1696+

1697+instance ( ToHie (LHsExpr a)

1698+ , Data (HsSplice a)

1699+ ) => ToHie (Located (HsSplice a)) where

1700+ toHie (L span sp) = concatM $ makeNode sp span : case sp of

1701+ HsTypedSplice _ _ _ expr ->

1702+ [ toHie expr

1703+ ]

1704+ HsUntypedSplice _ _ _ expr ->

1705+ [ toHie expr

1706+ ]

1707+ HsQuasiQuote _ _ _ ispan _ ->

1708+ [ pure $ locOnly ispan

1709+ ]

1710+ HsSpliced _ _ _ ->

1711+ []

1712+ HsSplicedT _ ->

1713+ []

1714+ XSplice _ -> []

1715+

1716+instance ToHie (LRoleAnnotDecl GhcRn) where

1717+ toHie (L span annot) = concatM $ makeNode annot span : case annot of

1718+ RoleAnnotDecl _ var roles ->

1719+ [ toHie $ C Use var

1720+ , concatMapM (pure . locOnly . getLoc) roles

1721+ ]

1722+ XRoleAnnotDecl _ -> []

1723+

1724+instance ToHie (LInstDecl GhcRn) where

1725+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1726+ ClsInstD _ d ->

1727+ [ toHie $ L span d

1728+ ]

1729+ DataFamInstD _ d ->

1730+ [ toHie $ L span d

1731+ ]

1732+ TyFamInstD _ d ->

1733+ [ toHie $ L span d

1734+ ]

1735+ XInstDecl _ -> []

1736+

1737+instance ToHie (LClsInstDecl GhcRn) where

1738+ toHie (L span decl) = concatM

1739+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1740+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1741+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1742+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1743+ , toHie $ cid_tyfam_insts decl

1744+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1745+ , toHie $ cid_datafam_insts decl

1746+ , toHie $ cid_overlap_mode decl

1747+ ]

1748+

1749+instance ToHie (LDataFamInstDecl GhcRn) where

1750+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1751+

1752+instance ToHie (LTyFamInstDecl GhcRn) where

1753+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1754+

1755+instance ToHie (Context a)

1756+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1757+ toHie (PSC sp (RecordPatSynField a b)) = concatM $

1758+ [ toHie $ C (RecField RecFieldDecl sp) a

1759+ , toHie $ C Use b

1760+ ]

1761+

1762+instance ToHie (LDerivDecl GhcRn) where

1763+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1764+ DerivDecl _ typ strat overlap ->

1765+ [ toHie $ TS (ResolvedScopes []) typ

1766+ , toHie strat

1767+ , toHie overlap

1768+ ]

1769+ XDerivDecl _ -> []

1770+

1771+instance ToHie (LFixitySig GhcRn) where

1772+ toHie (L span sig) = concatM $ makeNode sig span : case sig of

1773+ FixitySig _ vars _ ->

1774+ [ toHie $ map (C Use) vars

1775+ ]

1776+ XFixitySig _ -> []

1777+

1778+instance ToHie (LDefaultDecl GhcRn) where

1779+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1780+ DefaultDecl _ typs ->

1781+ [ toHie typs

1782+ ]

1783+ XDefaultDecl _ -> []

1784+

1785+instance ToHie (LForeignDecl GhcRn) where

1786+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1787+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1788+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1789+ , toHie $ TS (ResolvedScopes []) sig

1790+ , toHie fi

1791+ ]

1792+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1793+ [ toHie $ C Use name

1794+ , toHie $ TS (ResolvedScopes []) sig

1795+ , toHie fe

1796+ ]

1797+ XForeignDecl _ -> []

1798+

1799+instance ToHie ForeignImport where

1800+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1801+ [ locOnly a

1802+ , locOnly b

1803+ , locOnly c

1804+ ]

1805+

1806+instance ToHie ForeignExport where

1807+ toHie (CExport (L a _) (L b _)) = pure $ concat $

1808+ [ locOnly a

1809+ , locOnly b

1810+ ]

1811+

1812+instance ToHie (LWarnDecls GhcRn) where

1813+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1814+ Warnings _ _ warnings ->

1815+ [ toHie warnings

1816+ ]

1817+ XWarnDecls _ -> []

1818+

1819+instance ToHie (LWarnDecl GhcRn) where

1820+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1821+ Warning _ vars _ ->

1822+ [ toHie $ map (C Use) vars

1823+ ]

1824+ XWarnDecl _ -> []

1825+

1826+instance ToHie (LAnnDecl GhcRn) where

1827+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1828+ HsAnnotation _ _ prov expr ->

1829+ [ toHie prov

1830+ , toHie expr

1831+ ]

1832+ XAnnDecl _ -> []

1833+

1834+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1835+ toHie (ValueAnnProvenance a) = toHie $ C Use a

1836+ toHie (TypeAnnProvenance a) = toHie $ C Use a

1837+ toHie ModuleAnnProvenance = pure []

1838+

1839+instance ToHie (LRuleDecls GhcRn) where

1840+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1841+ HsRules _ _ rules ->

1842+ [ toHie rules

1843+ ]

1844+ XRuleDecls _ -> []

1845+

1846+instance ToHie (LRuleDecl GhcRn) where

1847+ toHie (L _ (XRuleDecl _)) = pure []

1848+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1849+ [ makeNode r span

1850+ , pure $ locOnly $ getLoc rname

1851+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1852+ , toHie $ map (RS $ mkScope span) bndrs

1853+ , toHie exprA

1854+ , toHie exprB

1855+ ]

1856+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1857+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1858+ exprA_sc = mkLScope exprA

1859+ exprB_sc = mkLScope exprB

1860+

1861+instance ToHie (RScoped (LRuleBndr GhcRn)) where

1862+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1863+ RuleBndr _ var ->

1864+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1865+ ]

1866+ RuleBndrSig _ var typ ->

1867+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1868+ , toHie $ TS (ResolvedScopes [sc]) typ

1869+ ]

1870+ XRuleBndr _ -> []

1871+

1872+instance ToHie (LImportDecl GhcRn) where

1873+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1874+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1875+ [ toHie $ IEC Import name

1876+ , toHie $ fmap (IEC ImportAs) as

1877+ , maybe (pure []) goIE hidden

1878+ ]

1879+ XImportDecl _ -> []

1880+ where

1881+ goIE (hiding, (L sp liens)) = concatM $

1882+ [ pure $ locOnly sp

1883+ , toHie $ map (IEC c) liens

1884+ ]

1885+ where

1886+ c = if hiding then ImportHiding else Import

1887+

1888+instance ToHie (IEContext (LIE GhcRn)) where

1889+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1890+ IEVar _ n ->

1891+ [ toHie $ IEC c n

1892+ ]

1893+ IEThingAbs _ n ->

1894+ [ toHie $ IEC c n

1895+ ]

1896+ IEThingAll _ n ->

1897+ [ toHie $ IEC c n

1898+ ]

1899+ IEThingWith _ n _ ns flds ->

1900+ [ toHie $ IEC c n

1901+ , toHie $ map (IEC c) ns

1902+ , toHie $ map (IEC c) flds

1903+ ]

1904+ IEModuleContents _ n ->

1905+ [ toHie $ IEC c n

1906+ ]

1907+ IEGroup _ _ _ -> []

1908+ IEDoc _ _ -> []

1909+ IEDocNamed _ _ -> []

1910+ XIE _ -> []

1911+

1912+instance ToHie (IEContext (LIEWrappedName Name)) where

1913+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1914+ IEName n ->

1915+ [ toHie $ C (IEThing c) n

1916+ ]

1917+ IEPattern p ->

1918+ [ toHie $ C (IEThing c) p

1919+ ]

1920+ IEType n ->

1921+ [ toHie $ C (IEThing c) n

1922+ ]

1923+

1924+instance ToHie (IEContext (Located (FieldLbl Name))) where

1925+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1926+ FieldLabel _ _ n ->

1927+ [ toHie $ C (IEThing c) $ L span n

1928+ ]

src/Development/IDE/GHC/HieAst.hs → src-ghc88/Development/IDE/GHC/HieAst.hsrenamed

The content is the same.

src/Development/IDE/Compat.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE CPP #-}

2+module Development.IDE.Compat

3+ (

4+ getProcessID

5+ ) where

7+#ifdef mingw32_HOST_OS

9+import qualified System.Win32.Process as P (getCurrentProcessId)

10+getProcessID :: IO Int

11+getProcessID = fromIntegral <$> P.getCurrentProcessId

12+

13+#else

14+

15+import qualified System.Posix.Process as P (getProcessID)

16+getProcessID :: IO Int

17+getProcessID = fromIntegral <$> P.getProcessID

18+

19+#endif

src/Development/IDE/Core/Compile.hs+77−14

@@ -19,6 +19,7 @@ module Development.IDE.Core.Compile

19 , generateByteCode

20 , generateAndWriteHieFile

21 , generateAndWriteHiFile

22+ , getModSummaryFromImports

22 , loadHieFile

23 , loadHieFile

23 , loadInterface

24 , loadInterface

24 , loadDepModule

25 , loadDepModule

@@ -70,30 +71,34 @@ import Control.Exception.Safe

70import Control.Monad.Extra

71import Control.Monad.Extra

71import Control.Monad.Except

72import Control.Monad.Except

72import Control.Monad.Trans.Except

73import Control.Monad.Trans.Except

74+import Data.Bifunctor (first, second)

73import qualified Data.Text as T

75import qualified Data.Text as T

74import Data.IORef

76import Data.IORef

75import Data.List.Extra

77import Data.List.Extra

76import Data.Maybe

78import Data.Maybe

77−import Data.Tuple.Extra

78import qualified Data.Map.Strict as Map

79import qualified Data.Map.Strict as Map

79import System.FilePath

80import System.FilePath

80import System.Directory

81import System.Directory

81import System.IO.Extra

82import System.IO.Extra

82import Data.Either.Extra (maybeToEither)

83import Data.Either.Extra (maybeToEither)

84+import Control.DeepSeq (rnf)

85+import Control.Exception (evaluate)

86+import Exception (ExceptionMonad)

85-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

89-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

86parseModule

90parseModule

87 :: IdeOptions

91 :: IdeOptions

88 -> HscEnv

92 -> HscEnv

93+ -> [PackageName]

89 -> FilePath

94 -> FilePath

90 -> Maybe SB.StringBuffer

95 -> Maybe SB.StringBuffer

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

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

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

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

93 fmap (either (, Nothing) id) $

98 fmap (either (, Nothing) id) $

94 evalGhcEnv env $ runExceptT $ do

99 evalGhcEnv env $ runExceptT $ do

95 (contents, dflags) <- preprocessor filename mbContents

100 (contents, dflags) <- preprocessor filename mbContents

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

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

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

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

103

104

@@ -115,7 +120,7 @@ typecheckModule :: IdeDefer

115 -> ParsedModule

120 -> ParsedModule

116 -> IO (IdeResult (HscEnv, TcModuleResult))

121 -> IO (IdeResult (HscEnv, TcModuleResult))

117typecheckModule (IdeDefer defer) hsc depsIn pm = do

122typecheckModule (IdeDefer defer) hsc depsIn pm = do

118− fmap (either (, Nothing) (second Just) . fmap sequence . sequence) $

123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $

119 runGhcEnv hsc $

124 runGhcEnv hsc $

120 catchSrcErrors "typecheck" $ do

125 catchSrcErrors "typecheck" $ do

121 -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

126 -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

@@ -250,7 +255,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

250 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

251hideDiag _originalFlags t = t

256hideDiag _originalFlags t = t

252

257

253−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags

254addRelativeImport fp modu dflags = dflags

259addRelativeImport fp modu dflags = dflags

255 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

256

261

@@ -407,16 +412,14 @@ getImportsParsed dflags (L loc parsed) = do

407 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

408 ])

413 ])

409

414

410−

411-- | Produce a module summary from a StringBuffer.

415-- | Produce a module summary from a StringBuffer.

412getModSummaryFromBuffer

416getModSummaryFromBuffer

413 :: GhcMonad m

417 :: GhcMonad m

414 => FilePath

418 => FilePath

415− -> SB.StringBuffer

416 -> DynFlags

419 -> DynFlags

417 -> GHC.ParsedSource

420 -> GHC.ParsedSource

418 -> ExceptT [FileDiagnostic] m ModSummary

421 -> ExceptT [FileDiagnostic] m ModSummary

419−getModSummaryFromBuffer fp contents dflags parsed = do

422+getModSummaryFromBuffer fp dflags parsed = do

420 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

421

424

422 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

425 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

@@ -432,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do

432 , ms_textual_imps = [imp | (False, imp) <- imports]

435 , ms_textual_imps = [imp | (False, imp) <- imports]

433 , ms_hspp_file = fp

436 , ms_hspp_file = fp

434 , ms_hspp_opts = dflags

437 , ms_hspp_opts = dflags

435− , ms_hspp_buf = Just contents

438+ , ms_hspp_buf = Nothing

436

439

437 -- defaults:

440 -- defaults:

438 , ms_hsc_src = sourceType

441 , ms_hsc_src = sourceType

@@ -447,17 +450,61 @@ getModSummaryFromBuffer fp contents dflags parsed = do

447 where

450 where

448 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

451 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

449

452

450−

453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.

454+-- Runs preprocessors as needed.

455+getModSummaryFromImports

456+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)

457+ => FilePath

458+ -> Maybe SB.StringBuffer

459+ -> ExceptT [FileDiagnostic] m ModSummary

460+getModSummaryFromImports fp contents = do

461+ (contents, dflags) <- preprocessor fp contents

462+ (srcImports, textualImports, L _ moduleName) <-

463+ ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp

464+

465+ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily

466+ liftIO $ evaluate $ rnf srcImports

467+ liftIO $ evaluate $ rnf textualImports

468+

469+ modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp

470+

471+ let mod = mkModule (thisPackage dflags) moduleName

472+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

473+ summary =

474+ ModSummary

475+ { ms_mod = mod

476+#if MIN_GHC_API_VERSION(8,8,0)

477+ , ms_hie_date = Nothing

478+#endif

479+ , ms_hs_date = error "Rules should not depend on ms_hs_date"

480+ -- When we are working with a virtual file we do not have a file date.

481+ -- To avoid silent issues where something is not processed because the date

482+ -- has not changed, we make sure that things blow up if they depend on the date.

483+ , ms_hsc_src = sourceType

484+ , ms_hspp_buf = Nothing

485+ , ms_hspp_file = fp

486+ , ms_hspp_opts = dflags

487+ , ms_iface_date = Nothing

488+ , ms_location = modLoc

489+ , ms_obj_date = Nothing

490+ , ms_parsed_mod = Nothing

491+ , ms_srcimps = srcImports

492+ , ms_textual_imps = textualImports

493+ }

494+ return summary

495+

496+

451−-- | Given a buffer, flags, file path and module summary, produce a

497+-- | Given a buffer, flags, and file path, produce a

452-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

498-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

453parseFileContents

499parseFileContents

454 :: GhcMonad m

500 :: GhcMonad m

455 => (GHC.ParsedSource -> IdePreprocessedSource)

501 => (GHC.ParsedSource -> IdePreprocessedSource)

456 -> DynFlags -- ^ flags to use

502 -> DynFlags -- ^ flags to use

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

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

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

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

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

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

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

460−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

461 let loc = mkRealSrcLoc (mkFastString filename) 1 1

508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

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

463#if MIN_GHC_API_VERSION(8,10,0)

510#if MIN_GHC_API_VERSION(8,10,0)

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

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

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

490 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

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

539+ let parsed' = removePackageImports comp_pkgs parsed

492 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

493− ms <- getModSummaryFromBuffer filename contents dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

494 let pm =

542 let pm =

495 ParsedModule {

543 ParsedModule {

496 pm_mod_summary = ms

544 pm_mod_summary = ms

497− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

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

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

499 , pm_annotations = hpm_annotations

547 , pm_annotations = hpm_annotations

500 }

548 }

501 warnings = diagFromErrMsgs "parser" dflags warns

549 warnings = diagFromErrMsgs "parser" dflags warns

502 pure (warnings ++ preproc_warnings, pm)

550 pure (warnings ++ preproc_warnings, pm)

503

551

552+

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

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

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

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

557+ where

558+ imports' = map do_one_import hsmodImports

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

560+ case PackageName . sl_fs <$> ideclPkgQual of

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

562+ _ -> L l i

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

564+ do_one_import l = l

565+#endif

566+

504loadHieFile :: FilePath -> IO GHC.HieFile

567loadHieFile :: FilePath -> IO GHC.HieFile

505loadHieFile f = do

568loadHieFile f = do

506 u <- mkSplitUniqSupply 'a'

569 u <- mkSplitUniqSupply 'a'

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

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

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs

94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

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

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

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

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

99+ case () of

95− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

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

96− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

97− , Just True <- _dynamicRegistration

102+ , Just True <- _dynamicRegistration

98− = fileExistsRulesFast getLspId vfs

103+ -> fileExistsRulesFast getLspId vfs

99− | otherwise = do

104+ | otherwise -> do

100− logger <- logger <$> getShakeExtrasRules

105+ logger <- logger <$> getShakeExtrasRules

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

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

102− fileExistsRulesSlow vfs

107+ fileExistsRulesSlow vfs

103

108

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

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

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

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

106−fileExistsRulesFast getLspId vfs = do

111+fileExistsRulesFast getLspId vfs =

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

108 defineEarlyCutoff $ \GetFileExists file -> do

112 defineEarlyCutoff $ \GetFileExists file -> do

109 isWf <- isWorkspaceFile file

113 isWf <- isWorkspaceFile file

110 if isWf

114 if isWf

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

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

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

3module Development.IDE.Core.PositionMapping

4 ( PositionMapping(..)

5+ , fromCurrentPosition

6+ , toCurrentPosition

7+ , PositionDelta(..)

8+ , addDelta

9+ , mkDelta

5 , toCurrentRange

10 , toCurrentRange

6 , fromCurrentRange

11 , fromCurrentRange

7 , applyChange

12 , applyChange

8− , idMapping

13+ , zeroMapping

9 -- toCurrent and fromCurrent are mainly exposed for testing

14 -- toCurrent and fromCurrent are mainly exposed for testing

10 , toCurrent

15 , toCurrent

11 , fromCurrent

16 , fromCurrent

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

14import Control.Monad

19import Control.Monad

15import qualified Data.Text as T

20import qualified Data.Text as T

16import Language.Haskell.LSP.Types

21import Language.Haskell.LSP.Types

22+import Data.List

18−data PositionMapping = PositionMapping

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

25+data PositionDelta = PositionDelta

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

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

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

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

21 }

28 }

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

31+fromCurrentPosition (PositionMapping pm) = fromDelta pm

32+

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

34+toCurrentPosition (PositionMapping pm) = toDelta pm

35+

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

37+-- a specific version

38+newtype PositionMapping = PositionMapping PositionDelta

39+

40+

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

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

24toCurrentRange mapping (Range a b) =

42toCurrentRange mapping (Range a b) =

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

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

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

28fromCurrentRange mapping (Range a b) =

46fromCurrentRange mapping (Range a b) =

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

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

31−idMapping :: PositionMapping

49+zeroMapping :: PositionMapping

32−idMapping = PositionMapping Just Just

50+zeroMapping = PositionMapping idDelta

51+

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

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

54+composeDelta :: PositionDelta

55+ -> PositionDelta

56+ -> PositionDelta

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

58+ PositionDelta (to1 <=< to2)

59+ (from1 >=> from2)

60+

61+idDelta :: PositionDelta

62+idDelta = PositionDelta Just Just

63+

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

65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66+mkDelta cs = foldl' applyChange idDelta cs

67+

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

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

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

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

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

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

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

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

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

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

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

38 }

76 }

39applyChange posMapping _ = posMapping

77applyChange posMapping _ = posMapping

src/Development/IDE/Core/Preprocessor.hs+11−3

@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

29import Data.Text (Text)

30import qualified Data.Text as T

31import Outputable (showSDoc)

32+import Control.DeepSeq (NFData(rnf))

33+import Control.Exception (evaluate)

34+import Control.Monad.IO.Class (MonadIO)

35+import Exception (ExceptionMonad)

34-- | Given a file and some contents, apply any necessary preprocessors,

38-- | Given a file and some contents, apply any necessary preprocessors,

35-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

39-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

36−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

37preprocessor filename mbContents = do

41preprocessor filename mbContents = do

38 -- Perform unlit

42 -- Perform unlit

39 (isOnDisk, contents) <-

43 (isOnDisk, contents) <-

@@ -129,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

129

133

130-- | This reads the pragma information directly from the provided buffer.

134-- | This reads the pragma information directly from the provided buffer.

131parsePragmasIntoDynFlags

135parsePragmasIntoDynFlags

132− :: GhcMonad m

136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

133 => FilePath

137 => FilePath

134 -> SB.StringBuffer

138 -> SB.StringBuffer

135 -> m (Either [FileDiagnostic] DynFlags)

139 -> m (Either [FileDiagnostic] DynFlags)

136parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

137− dflags0 <- getSessionDynFlags

141+ dflags0 <- getDynFlags

138 let opts = Hdr.getOptions dflags0 contents fp

142 let opts = Hdr.getOptions dflags0 contents fp

143+

144+ -- Force bits that might keep the dflags and stringBuffer alive unnecessarily

145+ liftIO $ evaluate $ rnf opts

146+

139 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

140 return dflags

148 return dflags

141

149

src/Development/IDE/Core/RuleTypes.hs+10−1

@@ -105,6 +105,10 @@ type instance RuleResult GetModIface = HiFileResult

105

106type instance RuleResult IsFileOfInterest = Bool

107

108+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.

109+-- without needing to parse the entire source

110+type instance RuleResult GetModSummary = ModSummary

111+

108data GetParsedModule = GetParsedModule

112data GetParsedModule = GetParsedModule

109 deriving (Eq, Show, Typeable, Generic)

113 deriving (Eq, Show, Typeable, Generic)

110instance Hashable GetParsedModule

114instance Hashable GetParsedModule

@@ -177,9 +181,14 @@ instance Hashable GetModIface

177instance NFData GetModIface

181instance NFData GetModIface

178instance Binary GetModIface

182instance Binary GetModIface

179

183

180−

181data IsFileOfInterest = IsFileOfInterest

184data IsFileOfInterest = IsFileOfInterest

182 deriving (Eq, Show, Typeable, Generic)

185 deriving (Eq, Show, Typeable, Generic)

183instance Hashable IsFileOfInterest

186instance Hashable IsFileOfInterest

184instance NFData IsFileOfInterest

187instance NFData IsFileOfInterest

185instance Binary IsFileOfInterest

188instance Binary IsFileOfInterest

189+

190+data GetModSummary = GetModSummary

191+ deriving (Eq, Show, Typeable, Generic)

192+instance Hashable GetModSummary

193+instance NFData GetModSummary

194+instance Binary GetModSummary

src/Development/IDE/Core/Rules.hs+229−119

@@ -1,10 +1,11 @@

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

4+{-# LANGUAGE CPP #-}

4−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE DuplicateRecordFields #-}

7{-# LANGUAGE DuplicateRecordFields #-}

7−{-# LANGUAGE PatternSynonyms #-}

8+#include "ghc-api-version.h"

9-- | A Shake implementation of the compiler service, built

10-- | A Shake implementation of the compiler service, built

10-- using the "Shaker" abstraction layer for in-memory use.

11-- using the "Shaker" abstraction layer for in-memory use.

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

28import Fingerprint

29import Fingerprint

30−import Data.Binary

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

31−import Data.Bifunctor (second)

32+import Data.Bifunctor (first, second)

32import Control.Monad.Extra

33import Control.Monad.Extra

33import Control.Monad.Trans.Class

34import Control.Monad.Trans.Class

34import Control.Monad.Trans.Maybe

35import Control.Monad.Trans.Maybe

@@ -44,13 +45,12 @@ import Development.IDE.Types.Diagnostics

44import Development.IDE.Types.Location

45import Development.IDE.Types.Location

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

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

46import Development.IDE.GHC.Util

47import Development.IDE.GHC.Util

47−import Data.Coerce

48+import Development.IDE.GHC.WithDynFlags

48import Data.Either.Extra

49import Data.Either.Extra

49import Data.Maybe

50import Data.Maybe

50import Data.Foldable

51import Data.Foldable

51import qualified Data.IntMap.Strict as IntMap

52import qualified Data.IntMap.Strict as IntMap

52import Data.IntMap.Strict (IntMap)

53import Data.IntMap.Strict (IntMap)

53−import qualified Data.IntSet as IntSet

54import Data.List

55import Data.Ord

56import qualified Data.Set as Set

@@ -59,16 +59,23 @@ import Development.IDE.GHC.Error

59import Development.Shake hiding (Diagnostic)

60import Development.IDE.Core.RuleTypes

61import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

63import qualified GHC.LanguageExtensions as LangExt

64import qualified GHC.LanguageExtensions as LangExt

64import HscTypes

65import HscTypes

66+import PackageConfig

65−import DynFlags (xopt)

67+import DynFlags (gopt_set, xopt)

66import GHC.Generics(Generic)

68import GHC.Generics(Generic)

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

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

69import Development.IDE.Core.Service

71import Development.IDE.Core.Service

70import Development.IDE.Core.Shake

72import Development.IDE.Core.Shake

71−import Development.Shake.Classes

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

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

75+import Data.ByteString (ByteString)

76+import Control.Concurrent.Async (concurrently)

77+

78+import Control.Monad.State

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

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

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

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

@@ -131,12 +138,11 @@ getHieFile file mod = do

131

138

132getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

139getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

133getHomeHieFile f = do

140getHomeHieFile f = do

134− pm <- use_ GetParsedModule f

141+ ms <- use_ GetModSummary f

135 let normal_hie_f = toNormalizedFilePath' hie_f

142 let normal_hie_f = toNormalizedFilePath' hie_f

136− hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm

143+ hie_f = ml_hie_file $ ms_location ms

137 mbHieTimestamp <- use GetModificationTime normal_hie_f

144 mbHieTimestamp <- use GetModificationTime normal_hie_f

138 srcTimestamp <- use_ GetModificationTime f

145 srcTimestamp <- use_ GetModificationTime f

139−

140 let isUpToDate

146 let isUpToDate

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

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

142 | otherwise = False

148 | otherwise = False

@@ -144,7 +150,7 @@ getHomeHieFile f = do

144 unless isUpToDate $

150 unless isUpToDate $

145 void $ use_ TypeCheck f

151 void $ use_ TypeCheck f

146

152

147− hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing

153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)

148 return ([], hf)

154 return ([], hf)

149

155

150getPackageHieFile :: Module -- ^ Package Module to load .hie file for

156getPackageHieFile :: Module -- ^ Package Module to load .hie file for

@@ -185,31 +191,60 @@ priorityFilesOfInterest :: Priority

185priorityFilesOfInterest = Priority (-2)

191priorityFilesOfInterest = Priority (-2)

186

192

187getParsedModuleRule :: Rules ()

193getParsedModuleRule :: Rules ()

188−getParsedModuleRule =

189− defineEarlyCutoff $ \GetParsedModule file -> do

194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

190− (_, contents) <- getFileContents file

191− packageState <- 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)

192− opt <- getIdeOptions

200+ opt <- getIdeOptions

201+ (_, contents) <- getFileContents file

202+

203+ let dflags = hsc_dflags hsc

204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

205+

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

207+ if gopt Opt_Haddock dflags

208+ then

209+ liftIO mainParse

210+ else do

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

212+ haddockParse = do

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

214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

215+ return diagsHaddock

216+

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

218+ -- parse twice, with and without Haddocks, concurrently

219+ -- we cannot ignore Haddock parse errors because files of

220+ -- non-interest are always parsed with Haddocks

221+ liftIO $ concurrently mainParse haddockParse

222+

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

224+

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

226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do

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

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

194− case res of

228+ case res of

195− Nothing -> pure (Nothing, (diag, Nothing))

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

196− Just (contents, modu) -> do

230+ Just (contents, modu) -> do

197− mbFingerprint <- if isNothing $ optShakeFiles opt

231+ mbFingerprint <- if isNothing $ optShakeFiles opt

198− then pure Nothing

232+ then pure Nothing

199− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

200− pure (mbFingerprint, (diag, Just modu))

234+ pure (mbFingerprint, (diag, Just modu))

201

235

202getLocatedImportsRule :: Rules ()

236getLocatedImportsRule :: Rules ()

203getLocatedImportsRule =

237getLocatedImportsRule =

204 define $ \GetLocatedImports file -> do

238 define $ \GetLocatedImports file -> do

205− pm <- use_ GetParsedModule file

239+ ms <- use_ GetModSummary file

206− let ms = pm_mod_summary pm

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

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

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

241+ env_eq <- use_ GhcSession file

242+ let env = hscEnv env_eq

243+ let import_dirs = deps env_eq

209− let dflags = addRelativeImport file pm $ hsc_dflags env

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

210 opt <- getIdeOptions

245 opt <- getIdeOptions

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

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

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

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

213 case diagOrImp of

248 case diagOrImp of

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

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

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

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

@@ -223,54 +258,91 @@ getLocatedImportsRule =

223 Nothing -> pure (concat diags, Nothing)

258 Nothing -> pure (concat diags, Nothing)

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

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

225

260

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

262+

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

264+execRawDepM act =

265+ execStateT act

266+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty

267+ , IntMap.empty

268+ )

226

269

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

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

228-- imports recursively.

271-- imports recursively.

229−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

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

230−rawDependencyInformation f = do

273+rawDependencyInformation fs = do

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

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

232− (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap

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

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

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

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

236 return (rdi { rawBootMap = bm })

276 return (rdi { rawBootMap = bm })

237 where

277 where

238− go fs (rawDepInfo, ss) =

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

239− case IntSet.minView fs of

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

240− -- Queue is empty

280+ go f = do

241− Nothing -> pure (rawDepInfo, ss)

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

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

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

243− Just (f, fs) -> do

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

244− let fId = FilePathId f

284+ checkAlreadyProcessed f $ do

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

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

287+ fId <- getFreshFid al

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

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

290+ addBootMap al fId

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

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

292+ importsOrErr <- lift $ use GetLocatedImports f

246− case importsOrErr of

293+ case importsOrErr of

247− Nothing ->

294+ Nothing -> do

248− -- File doesn’t parse

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

296+ -- dependency information, continue processing the other

297+ -- elements in the queue

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

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

250− in go fs (rawDepInfo', ss)

299+ return fId

251− Just (modImports, pkgImports) -> do

300+ Just (modImports, pkgImports) -> do

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

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

253− -> (a, Maybe ArtifactsLocation)

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

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

303+ let (no_file, with_file) = splitImports modImports

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

304+ (mns, ls) = unzip with_file

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

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

257− Just path ->

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

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

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

308+ -- Associate together the ModuleName with the FilePathId

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

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

311+ -- imports.

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

313+ return fId

314+

315+

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

317+ checkAlreadyProcessed nfp k = do

318+ (rawDepInfo, _) <- get

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

320+

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

322+ modifyRawDepInfo f = modify (first f)

323+

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

325+ addBootMap al fId =

259− ss' = if isBootLocation path

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

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

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

261− else ss

328+ else ss))

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

329+

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

330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331+ getFreshFid al = do

332+ (rawDepInfo, ss) <- get

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

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

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

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

266− let newFiles =

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

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

336+ put (rawDepInfo', ss)

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

337+ return fId

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

338+

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

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

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

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

272−

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

273−

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)

274

346

275 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

347 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

276 if not artifactIsSource

348 if not artifactIsSource

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

288getDependencyInformationRule :: Rules ()

360getDependencyInformationRule :: Rules ()

289getDependencyInformationRule =

361getDependencyInformationRule =

290 define $ \GetDependencyInformation file -> do

362 define $ \GetDependencyInformation file -> do

291− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

292 pure ([], Just $ processDependencyInformation rawDepInfo)

364 pure ([], Just $ processDependencyInformation rawDepInfo)

293

365

294reportImportCyclesRule :: Rules ()

366reportImportCyclesRule :: Rules ()

@@ -321,8 +393,8 @@ reportImportCyclesRule =

321 where loc = srcSpanToLocation (getLoc imp)

393 where loc = srcSpanToLocation (getLoc imp)

322 fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

394 fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

323 getModuleName file = do

395 getModuleName file = do

324− pm <- use_ GetParsedModule file

396+ ms <- use_ GetModSummary file

325− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

397+ pure (moduleNameString . moduleName . ms_mod $ ms)

326 showCycle mods = T.intercalate ", " (map T.pack mods)

398 showCycle mods = T.intercalate ", " (map T.pack mods)

327

399

328-- returns all transitive dependencies in topological order.

400-- returns all transitive dependencies in topological order.

@@ -342,22 +414,31 @@ getSpanInfoRule :: Rules ()

342getSpanInfoRule =

414getSpanInfoRule =

343 define $ \GetSpanInfo file -> do

415 define $ \GetSpanInfo file -> do

344 tc <- use_ TypeCheck file

416 tc <- use_ TypeCheck file

417+ packageState <- hscEnv <$> use_ GhcSession file

345 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

418 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

346 let tdeps = transitiveModuleDeps deps

419 let tdeps = transitiveModuleDeps deps

420+

421+-- When possible, rely on the haddocks embedded in our interface files

422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424+ let parsedDeps = []

425+#else

347 parsedDeps <- uses_ GetParsedModule tdeps

426 parsedDeps <- uses_ GetParsedModule tdeps

427+#endif

428+

348 ifaces <- uses_ GetModIface tdeps

429 ifaces <- uses_ GetModIface tdeps

349 (fileImports, _) <- use_ GetLocatedImports file

430 (fileImports, _) <- use_ GetLocatedImports file

350− packageState <- hscEnv <$> use_ GhcSession file

351 let imports = second (fmap artifactFilePath) <$> fileImports

431 let imports = second (fmap artifactFilePath) <$> fileImports

352− x <- liftIO $ getSrcSpanInfos packageState imports tc (zip parsedDeps $ map hirModIface ifaces)

432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

353 return ([], Just x)

433 return ([], Just x)

354

434

355-- Typechecks a module.

435-- Typechecks a module.

356typeCheckRule :: Rules ()

436typeCheckRule :: Rules ()

357−typeCheckRule = define $ \TypeCheck file ->

437+typeCheckRule = define $ \TypeCheck file -> do

438+ pm <- use_ GetParsedModule file

358 -- do not generate interface files as this rule is called

439 -- do not generate interface files as this rule is called

359 -- for files of interest on every keystroke

440 -- for files of interest on every keystroke

360− typeCheckRuleDefinition file SkipGenerationOfInterfaceFiles

441+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

361

442

362data GenerateInterfaceFiles

443data GenerateInterfaceFiles

363 = DoGenerateInterfaceFiles

444 = DoGenerateInterfaceFiles

@@ -370,10 +451,10 @@ data GenerateInterfaceFiles

370-- retain the information forever in the shake graph.

451-- retain the information forever in the shake graph.

371typeCheckRuleDefinition

452typeCheckRuleDefinition

372 :: NormalizedFilePath -- ^ Path to source file

453 :: NormalizedFilePath -- ^ Path to source file

454+ -> ParsedModule

373 -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

455 -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

374 -> Action (IdeResult TcModuleResult)

456 -> Action (IdeResult TcModuleResult)

375−typeCheckRuleDefinition file generateArtifacts = do

457+typeCheckRuleDefinition file pm generateArtifacts = do

376− pm <- use_ GetParsedModule file

377 deps <- use_ GetDependencies file

458 deps <- use_ GetDependencies file

378 hsc <- hscEnv <$> use_ GhcSession file

459 hsc <- hscEnv <$> use_ GhcSession file

379 -- Figure out whether we need TemplateHaskell or QuasiQuotes support

460 -- Figure out whether we need TemplateHaskell or QuasiQuotes support

@@ -390,7 +471,7 @@ typeCheckRuleDefinition file generateArtifacts = do

390 setPriority priorityTypeCheck

471 setPriority priorityTypeCheck

391 IdeOptions { optDefer = defer } <- getIdeOptions

472 IdeOptions { optDefer = defer } <- getIdeOptions

392

473

393− liftIO $ do

474+ addUsageDependencies $ liftIO $ do

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

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

395 case res of

476 case res of

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

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

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

404 uses_th_qq dflags =

485 uses_th_qq dflags =

405 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

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

406

487

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

489+ addUsageDependencies a = do

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

491+ forM_ mtc $ \tc -> do

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

493+ udep (UsageFile fp _h) = Just fp

494+ udep _ = Nothing

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

496+ -- qAddDependentFile

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

498+ return r

499+

407

500

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

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

409generateCore runSimplifier file = do

502generateCore runSimplifier file = do

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

436instance NFData GhcSessionIO

529instance NFData GhcSessionIO

437instance Binary GhcSessionIO

530instance Binary GhcSessionIO

438

531

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

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

440instance Show GhcSessionFun where show _ = "GhcSessionFun"

533instance Show GhcSessionFun where show _ = "GhcSessionFun"

441instance NFData GhcSessionFun where rnf !_ = ()

534instance NFData GhcSessionFun where rnf !_ = ()

442

535

@@ -446,69 +539,70 @@ loadGhcSession = do

446 defineNoFile $ \GhcSessionIO -> do

539 defineNoFile $ \GhcSessionIO -> do

447 opts <- getIdeOptions

540 opts <- getIdeOptions

448 GhcSessionFun <$> optGhcSession opts

541 GhcSessionFun <$> optGhcSession opts

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

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

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

545+ -- last time

449 defineEarlyCutoff $ \GhcSession file -> do

546 defineEarlyCutoff $ \GhcSession file -> do

450 GhcSessionFun fun <- useNoFile_ GhcSessionIO

547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

451 val <- fun $ fromNormalizedFilePath file

549 val <- fun $ fromNormalizedFilePath file

550+

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

452 opts <- getIdeOptions

552 opts <- getIdeOptions

453− 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)

454

562

455getHiFileRule :: Rules ()

563getHiFileRule :: Rules ()

456getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

564getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

457− session <- hscEnv <$> use_ GhcSession f

458 -- get all dependencies interface files, to check for freshness

565 -- get all dependencies interface files, to check for freshness

459 (deps,_) <- use_ GetLocatedImports f

566 (deps,_) <- use_ GetLocatedImports f

460 depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

567 depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

461

568

462− -- TODO find the hi file without relying on the parsed module

569+ ms <- use_ GetModSummary f

463− -- it should be possible to construct a ModSummary parsing just the imports

464− -- (see HeaderInfo in the GHC package)

465− pm <- use_ GetParsedModule f

466− let hiFile = toNormalizedFilePath' $

570+ let hiFile = toNormalizedFilePath'

467− case ms_hsc_src ms of

571+ $ case ms_hsc_src ms of

468 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

572 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

469 _ -> ml_hi_file $ ms_location ms

573 _ -> ml_hi_file $ ms_location ms

470− ms = pm_mod_summary pm

471−

472− IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions

473−

474− let mkInterfaceFilesGenerationDiag f intro

475− | optInterfaceLoadingDiagnostics = mkDiag $ intro <> msg

476− | otherwise = []

477− where

478− msg =

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

480− mkDiag = pure

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

482− . T.pack

483

574

484 case sequence depHis of

575 case sequence depHis of

485− Nothing -> do

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

487− pure (Nothing, (d, Nothing))

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

488 Just deps -> do

577 Just deps -> do

489 gotHiFile <- getFileExists hiFile

578 gotHiFile <- getFileExists hiFile

490 if not gotHiFile

579 if not gotHiFile

491− then do

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

493− pure (Nothing, (d, Nothing))

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

494 else do

581 else do

495 hiVersion <- use_ GetModificationTime hiFile

582 hiVersion <- use_ GetModificationTime hiFile

496 modVersion <- use_ GetModificationTime f

583 modVersion <- use_ GetModificationTime f

497 let sourceModified = modificationTime hiVersion < modificationTime modVersion

584 let sourceModified = modificationTime hiVersion < modificationTime modVersion

498 if sourceModified

585 if sourceModified

499 then do

586 then do

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

501− pure (Nothing, (d, Nothing))

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

502 else do

588 else do

589+ session <- hscEnv <$> use_ GhcSession f

503 r <- liftIO $ loadInterface session ms deps

590 r <- liftIO $ loadInterface session ms deps

504 case r of

591 case r of

505 Right iface -> do

592 Right iface -> do

506 let result = HiFileResult ms iface

593 let result = HiFileResult ms iface

507− return (Just (fingerprintToBS (mi_mod_hash iface)), ([], Just result))

594+ return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))

508 Left err -> do

595 Left err -> do

509 let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

596 let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

510 return (Nothing, (pure diag, Nothing))

597 return (Nothing, (pure diag, Nothing))

511

598

599+getModSummaryRule :: Rules ()

600+getModSummaryRule = define $ \GetModSummary f -> do

601+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f

602+ (_, mFileContent) <- getFileContents f

603+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $

604+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)

605+ return $ either (,Nothing) (([], ) . Just) modS

512

606

513getModIfaceRule :: Rules ()

607getModIfaceRule :: Rules ()

514getModIfaceRule = define $ \GetModIface f -> do

608getModIfaceRule = define $ \GetModIface f -> do

@@ -526,11 +620,26 @@ getModIfaceRule = define $ \GetModIface f -> do

526 tmr <- use TypeCheck f

620 tmr <- use TypeCheck f

527 return ([], extract tmr)

621 return ([], extract tmr)

528 | otherwise -> do

622 | otherwise -> do

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

529− -- Otherwise the interface file does not exist or is out of date. Invoke typechecking directly to update it without incurring a dependency on the typecheck rule.

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

625+ -- on the parsed module and the typecheck rules

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)

631+ opt <- getIdeOptions

632+ (_, contents) <- getFileContents f

633+ -- Embed --haddocks in the interface file

634+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents

636+ case mb_pm of

637+ Nothing -> return (diags, Nothing)

638+ Just pm -> do

530− (diags, tmr) <- typeCheckRuleDefinition f DoGenerateInterfaceFiles

639+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles

531− -- Bang pattern is important to avoid leaking 'tmr'

640+ -- Bang pattern is important to avoid leaking 'tmr'

532− let !res = extract tmr

641+ let !res = extract tmr

533− return (diags, res)

642+ return (diags <> diags', res)

534 where

643 where

535 extract Nothing = Nothing

644 extract Nothing = Nothing

536 extract (Just tmr) =

645 extract (Just tmr) =

@@ -559,3 +668,4 @@ mainRule = do

559 getHiFileRule

668 getHiFileRule

560 getModIfaceRule

669 getModIfaceRule

561 isFileOfInterestRule

670 isFileOfInterestRule

671+ getModSummaryRule

src/Development/IDE/Core/Shake.hs+44−34

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

53import Data.Dynamic

54import Data.Maybe

55import Data.Map.Strict (Map)

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

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

57import qualified Data.Set as Set

58import qualified Data.Text as T

59import Data.Traversable (for)

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

69import Development.IDE.Types.Options

70import Control.Concurrent.Async

71import Control.Concurrent.Extra

72−import Control.Exception

72+import Control.Exception.Extra

73import Control.DeepSeq

74import System.Time.Extra

75import Data.Typeable

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

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

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

99 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

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

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

103+ -- First mapping is delta from previous version and second one is an

104+ -- accumlation of all previous mappings.

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

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

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

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

105 }

107 }

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

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

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

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

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

126 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

127− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

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

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

129

131

130

132

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

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

132getIdeGlobalExtras ShakeExtras{globals} = do

134getIdeGlobalExtras ShakeExtras{globals} = do

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

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

136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

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

137+ case x of

138+ Just x

139+ | Just x <- fromDynamic x -> pure x

140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

135

142

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

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

137getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

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

154 | otherwise = False

161 | otherwise = False

155

162

156instance Hashable Key where

163instance Hashable Key where

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

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

158

165

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

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

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

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

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

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

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

165-- errors but still failed.

172-- errors but still failed.

166--

173--

167−-- A rule on a file should only return diagnostics for that given file. It should

168−-- not propagate diagnostic errors through multiple phases.

169−type IdeResult v = ([FileDiagnostic], Maybe v)

170

174

171data Value v

175data Value v

172 = Succeeded TextDocumentVersion v

176 = Succeeded TextDocumentVersion v

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

201 Failed -> Nothing

205 Failed -> Nothing

202

206

203mappingForVersion

207mappingForVersion

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

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

205 -> NormalizedFilePath

209 -> NormalizedFilePath

206 -> TextDocumentVersion

210 -> TextDocumentVersion

207 -> PositionMapping

211 -> PositionMapping

208mappingForVersion allMappings file ver =

212mappingForVersion allMappings file ver =

209− fromMaybe idMapping $

213+ maybe zeroMapping snd $

210 Map.lookup ver =<<

214 Map.lookup ver =<<

211 HMap.lookup (filePathToUri' file) allMappings

215 HMap.lookup (filePathToUri' file) allMappings

212

216

@@ -239,7 +243,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

239 shakeProfileDatabase shakeDb $ dir </> file

243 shakeProfileDatabase shakeDb $ dir </> file

240 return (dir </> file)

244 return (dir </> file)

241 return (res, proFile)

245 return (res, proFile)

242− where

243

246

244{-# NOINLINE profileStartTime #-}

247{-# NOINLINE profileStartTime #-}

245profileStartTime :: String

248profileStartTime :: String

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

510

513

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

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

512-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

513−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

514−-- can just remove it?

515−data A v = A (Value v) ShakeValue

516+newtype A v = A (Value v)

516 deriving Show

517 deriving Show

517

518

518−instance NFData (A v) where rnf (A v x) = v `seq` rnf x

519+instance NFData (A v) where rnf (A v) = v `seq` ()

519

520

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

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

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

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

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

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

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

526uses :: IdeRule k v

527uses :: IdeRule k v

527 => k -> [NormalizedFilePath] -> Action [Maybe v]

528 => k -> [NormalizedFilePath] -> Action [Maybe v]

528−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)

529

530

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

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

531usesWithStale :: IdeRule k v

532usesWithStale :: IdeRule k v

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

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

533usesWithStale key files = do

534usesWithStale key files = do

534− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

535− mapM (uncurry lastValue) (zip files values)

536+ zipWithM lastValue files values

536

537

538

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

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

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

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

541+ -- This functions are deliberately eta-expanded to avoid space leaks.

542+ -- Do not remove the eta-expansion without profiling a session with at

543+ -- least 1000 modifications.

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

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

541

545

542

546

543defineEarlyCutoff

547defineEarlyCutoff

@@ -554,16 +558,16 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

554 case v of

558 case v of

555 -- No changes in the dependencies and we have

559 -- No changes in the dependencies and we have

556 -- an existing result.

560 -- an existing result.

557− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v

558 _ -> return Nothing

562 _ -> return Nothing

559 _ -> return Nothing

563 _ -> return Nothing

560 case val of

564 case val of

561 Just res -> return res

565 Just res -> return res

562 Nothing -> do

566 Nothing -> do

563 (bs, (diags, res)) <- actionCatch

567 (bs, (diags, res)) <- actionCatch

564− (do v <- op key file; liftIO $ evaluate $ force $ v) $

568+ (do v <- op key file; liftIO $ evaluate $ force v) $

565 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

569 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

566− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

567 (bs, res) <- case res of

571 (bs, res) <- case res of

568 Nothing -> do

572 Nothing -> do

569 staleV <- liftIO $ getValues state key file

573 staleV <- liftIO $ getValues state key file

@@ -573,7 +577,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

573 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

577 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

574 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

578 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

575 Failed -> (toShakeValue ShakeResult bs, Failed)

579 Failed -> (toShakeValue ShakeResult bs, Failed)

576− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

577 liftIO $ setValues state key file res

581 liftIO $ setValues state key file res

578 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

582 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

579 let eq = case (bs, fmap decodeShakeValue old) of

583 let eq = case (bs, fmap decodeShakeValue old) of

@@ -585,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

585 return $ RunResult

589 return $ RunResult

586 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

587 (encodeShakeValue bs) $

591 (encodeShakeValue bs) $

588− A res bs

592+ A res

589

593

590

594

591-- | Rule type, input file

595-- | Rule type, input file

@@ -700,7 +704,7 @@ updateFileDiagnostics ::

700 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

701 -> Action ()

705 -> Action ()

702updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

703− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

704 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

705 mask_ $ do

709 mask_ $ do

706 -- Mask async exceptions to ensure that updated diagnostics are always

710 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -713,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

713 let newDiags = getFileDiagnostics fp newDiagsStore

717 let newDiags = getFileDiagnostics fp newDiagsStore

714 _ <- evaluate newDiagsStore

718 _ <- evaluate newDiagsStore

715 _ <- evaluate newDiags

719 _ <- evaluate newDiags

716− pure $! (newDiagsStore, newDiags)

720+ pure (newDiagsStore, newDiags)

717 modifyVar_ hiddenDiagnostics $ \old -> do

721 modifyVar_ hiddenDiagnostics $ \old -> do

718 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

719 (T.pack $ show k) (map snd currentHidden) old

723 (T.pack $ show k) (map snd currentHidden) old

@@ -739,7 +743,7 @@ publishDiagnosticsNotification uri diags =

739newtype Priority = Priority Double

743newtype Priority = Priority Double

740

744

741setPriority :: Priority -> Action ()

745setPriority :: Priority -> Action ()

742−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

743

747

744sendEvent :: LSP.FromServerMessage -> Action ()

748sendEvent :: LSP.FromServerMessage -> Action ()

745sendEvent e = do

749sendEvent e = do

@@ -765,7 +769,7 @@ instance Binary GetModificationTime

765type instance RuleResult GetModificationTime = FileVersion

769type instance RuleResult GetModificationTime = FileVersion

766

770

767data FileVersion

771data FileVersion

768− = VFSVersion Int

772+ = VFSVersion !Int

769 | ModificationTime

773 | ModificationTime

770 !Int -- ^ Large unit (platform dependent, do not make assumptions)

774 !Int -- ^ Large unit (platform dependent, do not make assumptions)

771 !Int -- ^ Small unit (platform dependent, do not make assumptions)

775 !Int -- ^ Small unit (platform dependent, do not make assumptions)

@@ -829,11 +833,17 @@ filterVersionMap =

829 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

833 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

830

834

831updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

832−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

833 modifyVar_ positionMapping $ \allMappings -> do

837 modifyVar_ positionMapping $ \allMappings -> do

834 let uri = toNormalizedUri _uri

838 let uri = toNormalizedUri _uri

835 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

839 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

836− let updatedMapping =

840+ let (_, updatedMapping) =

841+ -- Very important to use mapAccum here so that the tails of

842+ -- each mapping can be shared, otherwise quadratic space is

843+ -- used which is evident in long running sessions.

844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845+ zeroMapping

837− Map.insert _version idMapping $

846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)

838− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

839 pure $! HMap.insert uri updatedMapping allMappings

847 pure $! HMap.insert uri updatedMapping allMappings

848+ where

849+ shared_change = mkDelta changes

src/Development/IDE/GHC/Compat.hs+59−2

@@ -7,6 +7,7 @@

8-- | Attempt at hiding the GHC version differences we can.

9module Development.IDE.GHC.Compat(

10+ getHeaderImports,

10 HieFileResult(..),

11 HieFileResult(..),

11 HieFile,

12 HieFile,

12 hieExportNames,

13 hieExportNames,

@@ -24,6 +25,8 @@ module Development.IDE.GHC.Compat(

24 includePathsGlobal,

25 includePathsGlobal,

25 includePathsQuote,

26 includePathsQuote,

26 addIncludePathsQuote,

27 addIncludePathsQuote,

28+ getModuleHash,

29+ getPackageName,

27 pattern DerivD,

30 pattern DerivD,

28 pattern ForD,

31 pattern ForD,

29 pattern InstD,

32 pattern InstD,

@@ -35,6 +38,7 @@ module Development.IDE.GHC.Compat(

35 GHC.ModLocation,

38 GHC.ModLocation,

36 Module.addBootSuffix,

39 Module.addBootSuffix,

37 pattern ModLocation,

40 pattern ModLocation,

41+ getConArgs,

39 module GHC

43 module GHC

40 ) where

44 ) where

@@ -42,15 +46,29 @@ module Development.IDE.GHC.Compat(

42import StringBuffer

46import StringBuffer

43import DynFlags

47import DynFlags

44import FieldLabel

48import FieldLabel

49+import Fingerprint (Fingerprint)

45import qualified Module

50import qualified Module

51+import Packages

47import qualified GHC

53import qualified GHC

54+import GHC hiding (

48−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)

55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation

56+#if MIN_GHC_API_VERSION(8,6,0)

57+ , getConArgs

58+#endif

59+ )

60+import qualified HeaderInfo as Hdr

49import Avail

61import Avail

62+import ErrUtils (ErrorMessages)

63+import FastString (FastString)

64+

65+#if MIN_GHC_API_VERSION(8,10,0)

66+import HscTypes (mi_mod_hash)

67+#endif

51#if MIN_GHC_API_VERSION(8,8,0)

69#if MIN_GHC_API_VERSION(8,8,0)

52import Control.Applicative ((<|>))

70import Control.Applicative ((<|>))

53−import Development.IDE.GHC.HieAst

71+import Development.IDE.GHC.HieAst (mkHieFile)

54import HieBin

72import HieBin

55import HieTypes

73import HieTypes

@@ -69,6 +87,7 @@ import IfaceEnv

69#endif

87#endif

71import Binary

89import Binary

90+import Control.Exception (catch)

72import Data.ByteString (ByteString)

91import Data.ByteString (ByteString)

73import GhcPlugins hiding (ModLocation)

92import GhcPlugins hiding (ModLocation)

74import NameCache

93import NameCache

@@ -250,3 +269,41 @@ readHieFile _ _ = return undefined

250#endif

269#endif

251

270

252#endif

271#endif

272+

273+getHeaderImports

274+ :: DynFlags

275+ -> StringBuffer

276+ -> FilePath

277+ -> FilePath

278+ -> IO

279+ ( Either

280+ ErrorMessages

281+ ( [(Maybe FastString, Located ModuleName)]

282+ , [(Maybe FastString, Located ModuleName)]

283+ , Located ModuleName

284+ )

285+ )

286+#if MIN_GHC_API_VERSION(8,8,0)

287+getHeaderImports = Hdr.getImports

288+#else

289+getHeaderImports a b c d =

290+ catch (Right <$> Hdr.getImports a b c d)

291+ (return . Left . srcErrorMessages)

292+#endif

293+

294+getModuleHash :: ModIface -> Fingerprint

295+#if MIN_GHC_API_VERSION(8,10,0)

296+getModuleHash = mi_mod_hash . mi_final_exts

297+#else

298+getModuleHash = mi_mod_hash

299+#endif

300+

301+getConArgs :: ConDecl pass -> HsConDeclDetails pass

302+#if MIN_GHC_API_VERSION(8,6,0)

303+getConArgs = GHC.getConArgs

304+#else

305+getConArgs = GHC.getConDetails

306+#endif

307+

308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+24−2

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error

9 , diagFromStrings

10 , diagFromGhcException

11 , catchSrcErrors

12+ , mergeDiagnostics

13 -- * utilities working with spans

14 -- * utilities working with spans

14 , srcSpanToLocation

15 , srcSpanToLocation

@@ -36,6 +37,7 @@ import Panic

36import ErrUtils

37import ErrUtils

37import SrcLoc

38import SrcLoc

38import qualified Outputable as Out

39import qualified Outputable as Out

40+import Exception (ExceptionMonad)

@@ -54,13 +56,33 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename

54-- | Produce a GHC-style error from a source span and a message.

56-- | Produce a GHC-style error from a source span and a message.

55diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

56diagFromErrMsg diagSource dflags e =

58diagFromErrMsg diagSource dflags e =

57− [ 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

58 | Just sev <- [toDSeverity $ errMsgSeverity e]]

61 | Just sev <- [toDSeverity $ errMsgSeverity e]]

61diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

62diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

67+-- | Merges two sorted lists of diagnostics, removing duplicates.

68+-- Assumes all the diagnostics are for the same file.

69+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]

70+mergeDiagnostics aa [] = aa

71+mergeDiagnostics [] bb = bb

72+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)

73+ | ar < br

74+ = a : mergeDiagnostics aa (b:bb)

75+ | br < ar

76+ = b : mergeDiagnostics (a:aa) bb

77+ | _severity ad == _severity bd

78+ && _source ad == _source bd

79+ && _message ad == _message bd

80+ && _code ad == _code bd

81+ && _relatedInformation ad == _relatedInformation bd

82+ && _tags ad == _tags bd

83+ = a : mergeDiagnostics aa bb

84+ | otherwise

85+ = a : b : mergeDiagnostics aa bb

65-- | Convert a GHC SrcSpan to a DAML compiler Range

87-- | Convert a GHC SrcSpan to a DAML compiler Range

66srcSpanToRange :: SrcSpan -> Range

88srcSpanToRange :: SrcSpan -> Range

@@ -128,7 +150,7 @@ realSpan = \case

128

150

129-- | Run something in a Ghc monad and catch the errors (SourceErrors and

151-- | Run something in a Ghc monad and catch the errors (SourceErrors and

130-- compiler-internal exceptions like Panic or InstallationError).

152-- compiler-internal exceptions like Panic or InstallationError).

131−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

132catchSrcErrors fromWhere ghcM = do

154catchSrcErrors fromWhere ghcM = do

133 dflags <- getDynFlags

155 dflags <- getDynFlags

134 handleGhcException (ghcExceptionToDiagnostics dflags) $

156 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+10−3

@@ -1,8 +1,10 @@

2-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE CPP #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# OPTIONS_GHC -Wno-orphans #-}

6{-# OPTIONS_GHC -Wno-orphans #-}

7+#include "ghc-api-version.h"

7-- | Orphan instances for GHC.

9-- | Orphan instances for GHC.

8-- Note that the 'NFData' instances may not be law abiding.

10-- Note that the 'NFData' instances may not be law abiding.

@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf

31instance Show InstalledUnitId where

33instance Show InstalledUnitId where

32 show = installedUnitIdString

34 show = installedUnitIdString

34−instance NFData InstalledUnitId where rnf = rwhnf

36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

36instance NFData SB.StringBuffer where rnf = rwhnf

38instance NFData SB.StringBuffer where rnf = rwhnf

@@ -40,8 +42,8 @@ instance Show Module where

41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

43−instance NFData (GenLocated SrcSpan ModuleName) where

45+instance (NFData l, NFData e) => NFData (GenLocated l e) where

44− rnf = rwhnf

46+ rnf (L l e) = rnf l `seq` rnf e

46instance Show ModSummary where

48instance Show ModSummary where

47 show = show . ms_mod

49 show = show . ms_mod

@@ -52,6 +54,11 @@ instance Show ParsedModule where

52instance NFData ModSummary where

54instance NFData ModSummary where

53 rnf = rwhnf

55 rnf = rwhnf

57+#if !MIN_GHC_API_VERSION(8,10,0)

58+instance NFData FastString where

59+ rnf = rwhnf

60+#endif

61+

55instance NFData ParsedModule where

62instance NFData ParsedModule where

56 rnf = rwhnf

63 rnf = rwhnf

src/Development/IDE/GHC/Util.hs+21−15

@@ -8,6 +8,7 @@ module Development.IDE.GHC.Util(

8 modifyDynFlags,

9 evalGhcEnv,

10 runGhcEnv,

11+ deps,

11 -- * GHC wrappers

12 -- * GHC wrappers

12 prettyPrint,

13 prettyPrint,

13 printRdrName,

14 printRdrName,

@@ -64,7 +65,7 @@ import Packages (getPackageConfigMap, lookupPackage')

64import SrcLoc (mkRealSrcLoc)

65import SrcLoc (mkRealSrcLoc)

65import FastString (mkFastString)

66import FastString (mkFastString)

66import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

67import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

67−import Module (moduleNameSlashes)

68+import Module (moduleNameSlashes, InstalledUnitId)

68import OccName (parenSymOcc)

69import OccName (parenSymOcc)

69import RdrName (nameRdrName, rdrNameOcc)

70import RdrName (nameRdrName, rdrNameOcc)

@@ -147,29 +148,30 @@ runGhcEnv env act = do

147-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

148-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

148-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

149-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

149-- @\/usr\/Test@ should be on the include path to find sibling modules.

150-- @\/usr\/Test@ should be on the include path to find sibling modules.

150−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

151-- The call to takeDirectory is required since DAML does not require that

152-- The call to takeDirectory is required since DAML does not require that

152-- the file name matches the module name in the last component.

153-- the file name matches the module name in the last component.

153-- Once that has changed we can get rid of this.

154-- Once that has changed we can get rid of this.

154−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

155 -- This happens for single-component modules since takeDirectory "A" == "."

156 -- This happens for single-component modules since takeDirectory "A" == "."

156 | modDir == "." = Just pathDir

157 | modDir == "." = Just pathDir

157 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

158 where

159 where

159− ms = GHC.pm_mod_summary pm

160− mod' = GHC.ms_mod ms

161 -- A for module A.B

160 -- A for module A.B

162 modDir =

161 modDir =

163 takeDirectory $

162 takeDirectory $

164 fromNormalizedFilePath $ toNormalizedFilePath' $

163 fromNormalizedFilePath $ toNormalizedFilePath' $

165− moduleNameSlashes $ GHC.moduleName mod'

164+ moduleNameSlashes mn

166

165

167-- | An 'HscEnv' with equality. Two values are considered equal

166-- | An 'HscEnv' with equality. Two values are considered equal

168-- if they are created with the same call to 'newHscEnvEq'.

167-- if they are created with the same call to 'newHscEnvEq'.

169data HscEnvEq

168data HscEnvEq

170 = HscEnvEq !Unique !HscEnv

169 = HscEnvEq !Unique !HscEnv

170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv

171+ -- This is only used at the moment for the import dirs in

172+ -- the DynFlags

171 | GhcVersionMismatch { compileTime :: !Version

173 | GhcVersionMismatch { compileTime :: !Version

172− , runTime :: !(Maybe Version)

174+ , runTime :: !Version

173 }

175 }

174

176

175-- | Unwrap an 'HsEnvEq'.

177-- | Unwrap an 'HsEnvEq'.

@@ -177,35 +179,39 @@ hscEnv :: HscEnvEq -> HscEnv

177hscEnv = either error id . hscEnv'

179hscEnv = either error id . hscEnv'

178

180

179hscEnv' :: HscEnvEq -> Either String HscEnv

181hscEnv' :: HscEnvEq -> Either String HscEnv

180−hscEnv' (HscEnvEq _ x) = Right x

182+hscEnv' (HscEnvEq _ x _) = Right x

181hscEnv' GhcVersionMismatch{..} = Left $

183hscEnv' GhcVersionMismatch{..} = Left $

182 unwords

184 unwords

183 ["ghcide compiled against GHC"

185 ["ghcide compiled against GHC"

184 ,showVersion compileTime

186 ,showVersion compileTime

185 ,"but currently using"

187 ,"but currently using"

186− ,maybe "an unknown version of GHC" (\v -> "GHC " <> showVersion v) runTime

188+ ,showVersion runTime

187 ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

189 ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

188 ]

190 ]

189

191

192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193+deps (HscEnvEq _ _ u) = u

194+deps GhcVersionMismatch{} = []

195+

190-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

191−newHscEnvEq :: HscEnv -> IO HscEnvEq

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

192−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

193

199

194instance Show HscEnvEq where

200instance Show HscEnvEq where

195− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

196 show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

202 show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

197

203

198instance Eq HscEnvEq where

204instance Eq HscEnvEq where

199− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

200 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

206 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

201 _ == _ = False

207 _ == _ = False

202

208

203instance NFData HscEnvEq where

209instance NFData HscEnvEq where

204− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

205 rnf GhcVersionMismatch{} = rnf runTime

211 rnf GhcVersionMismatch{} = rnf runTime

206

212

207instance Hashable HscEnvEq where

213instance Hashable HscEnvEq where

208− hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

209 hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

215 hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

210

216

211-- Fake instance needed to persuade Shake to accept this type as a key.

217-- Fake instance needed to persuade Shake to accept this type as a key.

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

6+import Control.Monad.Trans.Reader (ask, ReaderT(..))

7+import GHC (DynFlags)

8+import Control.Monad.IO.Class (MonadIO)

9+import Exception (ExceptionMonad(..))

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+import GhcPlugins (HasDynFlags(..))

12+

13+-- | A monad transformer implementing the 'HasDynFlags' effect

14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16+

17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19+

20+instance Monad m => HasDynFlags (WithDynFlags m) where

21+ getDynFlags = WithDynFlags ask

22+

23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24+ gmask f = WithDynFlags $ ReaderT $ \env ->

25+ gmask $ \restore ->

26+ let restore' = lift . restore . flip runReaderT env . withDynFlags

27+ in runReaderT (withDynFlags $ f restore') env

28+

29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+23−19

@@ -62,17 +62,22 @@ data ModuleImports = ModuleImports

62 -- that module on disk (if we found it)

63 , packageImports :: !(Set InstalledUnitId)

64 -- ^ Transitive package dependencies unioned for all imports.

65− }

65+ } deriving Show

67−-- | For processing dependency information, we need lots of maps and sets

67+-- | For processing dependency information, we need lots of maps and sets of

68−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

68+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

69−-- instead and only convert at the edges

69+-- instead and only convert at the edges.

70−-- and

71newtype FilePathId = FilePathId { getFilePathId :: Int }

70newtype FilePathId = FilePathId { getFilePathId :: Int }

72 deriving (Show, NFData, Eq, Ord)

71 deriving (Show, NFData, Eq, Ord)

73+-- | Map from 'FilePathId'

74+type FilePathIdMap = IntMap

75+

76+-- | Set of 'FilePathId's

77+type FilePathIdSet = IntSet

78+

74data PathIdMap = PathIdMap

79data PathIdMap = PathIdMap

75− { idToPathMap :: !(IntMap ArtifactsLocation)

80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

76 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

81 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

77 }

82 }

78 deriving (Show, Generic)

83 deriving (Show, Generic)

@@ -109,41 +114,40 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap fil

109idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

114idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

110idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

115idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

111

116

112−

113−type BootIdMap = IntMap FilePathId

117+type BootIdMap = FilePathIdMap FilePathId

114

118

115insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

119insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

116insertBootId k = IntMap.insert (getFilePathId k)

120insertBootId k = IntMap.insert (getFilePathId k)

117

121

118−

119-- | Unprocessed results that we find by following imports recursively.

122-- | Unprocessed results that we find by following imports recursively.

120data RawDependencyInformation = RawDependencyInformation

123data RawDependencyInformation = RawDependencyInformation

121− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

122 , rawPathIdMap :: !PathIdMap

125 , rawPathIdMap :: !PathIdMap

123 -- The rawBootMap maps the FilePathId of a hs-boot file to its

126 -- The rawBootMap maps the FilePathId of a hs-boot file to its

124 -- corresponding hs file. It is used when topologically sorting as we

127 -- corresponding hs file. It is used when topologically sorting as we

125 -- need to add edges between .hs-boot and .hs so that the .hs files

128 -- need to add edges between .hs-boot and .hs so that the .hs files

126 -- appear later in the sort.

129 -- appear later in the sort.

127 , rawBootMap :: !BootIdMap

130 , rawBootMap :: !BootIdMap

128− }

131+ } deriving Show

129

132

130−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

131pkgDependencies RawDependencyInformation{..} =

134pkgDependencies RawDependencyInformation{..} =

132 IntMap.map (either (const Set.empty) packageImports) rawImports

135 IntMap.map (either (const Set.empty) packageImports) rawImports

133

136

134data DependencyInformation =

137data DependencyInformation =

135 DependencyInformation

138 DependencyInformation

136− { depErrorNodes :: !(IntMap (NonEmpty NodeError))

139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

137 -- ^ Nodes that cannot be processed correctly.

140 -- ^ Nodes that cannot be processed correctly.

138− , depModuleNames :: !(IntMap ShowableModuleName)

141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)

139− , depModuleDeps :: !(IntMap IntSet)

142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

140 -- ^ For a non-error node, this contains the set of module immediate dependencies

143 -- ^ For a non-error node, this contains the set of module immediate dependencies

141 -- in the same package.

144 -- in the same package.

142− , depPkgDeps :: !(IntMap (Set InstalledUnitId))

145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

143 -- ^ For a non-error node, this contains the set of immediate pkg deps.

146 -- ^ For a non-error node, this contains the set of immediate pkg deps.

144 , depPathIdMap :: !PathIdMap

147 , depPathIdMap :: !PathIdMap

145− -- ^ Map from hs-boot file to the corresponding hs file

148+ -- ^ Map from FilePath to FilePathId

146 , depBootMap :: !BootIdMap

149 , depBootMap :: !BootIdMap

150+ -- ^ Map from hs-boot file to the corresponding hs file

147 } deriving (Show, Generic)

151 } deriving (Show, Generic)

148

152

149newtype ShowableModuleName =

153newtype ShowableModuleName =

@@ -243,7 +247,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

243-- 2. Mark each node that has a parse error as an error node.

247-- 2. Mark each node that has a parse error as an error node.

244-- 3. Mark each node whose immediate children could not be located as an error.

248-- 3. Mark each node whose immediate children could not be located as an error.

245-- 4. Recursively propagate errors to parents if they are not already error nodes.

249-- 4. Recursively propagate errors to parents if they are not already error nodes.

246−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

247buildResultGraph g = propagatedErrors

251buildResultGraph g = propagatedErrors

248 where

252 where

249 sccs = stronglyConnComp (graphEdges g)

253 sccs = stronglyConnComp (graphEdges g)

@@ -290,7 +294,7 @@ buildResultGraph g = propagatedErrors

290 Right ModuleImports{moduleImports} ->

294 Right ModuleImports{moduleImports} ->

291 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

292

296

293−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

294graphEdges g =

298graphEdges g =

295 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

296 where deps :: Either e ModuleImports -> [FilePathId]

300 where deps :: Either e ModuleImports -> [FilePathId]

src/Development/IDE/Import/FindImports.hs+40−14

@@ -8,17 +8,18 @@ module Development.IDE.Import.FindImports

8 ( locateModule

9 , Import(..)

10 , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

11 , isBootLocation

12 , isBootLocation

13+ , mkImportDirs

12 ) where

14 ) where

14import Development.IDE.GHC.Error as ErrUtils

16import Development.IDE.GHC.Error as ErrUtils

15import Development.IDE.GHC.Orphans()

17import Development.IDE.GHC.Orphans()

16import Development.IDE.Types.Diagnostics

18import Development.IDE.Types.Diagnostics

17import Development.IDE.Types.Location

19import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

18-- GHC imports

21-- GHC imports

19−import DynFlags

20import FastString

22import FastString

21−import GHC

22import qualified Module as M

23import qualified Module as M

23import Packages

24import Packages

24import Outputable (showSDoc, ppr, pprPanic)

25import Outputable (showSDoc, ppr, pprPanic)

@@ -29,6 +30,8 @@ import Control.DeepSeq

29import Control.Monad.Extra

30import Control.Monad.Extra

30import Control.Monad.IO.Class

31import Control.Monad.IO.Class

31import System.FilePath

32import System.FilePath

33+import DriverPhases

34+import Data.Maybe

33data Import

36data Import

34 = FileImport !ArtifactsLocation

37 = FileImport !ArtifactsLocation

@@ -52,58 +55,81 @@ instance NFData Import where

52 rnf (FileImport x) = rnf x

55 rnf (FileImport x) = rnf x

53 rnf (PackageImport x) = rnf x

56 rnf (PackageImport x) = rnf x

58+modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation

59+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))

60+ where

61+ isSource HsSrcFile = True

62+ isSource _ = False

63+

56-- | locate a module in the file system. Where we go from *daml to Haskell

65-- | locate a module in the file system. Where we go from *daml to Haskell

57locateModuleFile :: MonadIO m

66locateModuleFile :: MonadIO m

58− => DynFlags

67+ => [[FilePath]]

59 -> [String]

68 -> [String]

60 -> (NormalizedFilePath -> m Bool)

69 -> (NormalizedFilePath -> m Bool)

61 -> Bool

70 -> Bool

62 -> ModuleName

71 -> ModuleName

63 -> m (Maybe NormalizedFilePath)

72 -> m (Maybe NormalizedFilePath)

64−locateModuleFile dflags exts doesExist isSource modName = do

73+locateModuleFile import_dirss exts doesExist isSource modName = do

65− let candidates =

74+ let candidates import_dirs =

66 [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

75 [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

67− | prefix <- importPaths dflags, ext <- exts]

76+ | prefix <- import_dirs , ext <- exts]

68− findM doesExist candidates

77+ findM doesExist (concatMap candidates import_dirss)

69 where

78 where

70 maybeBoot ext

79 maybeBoot ext

71 | isSource = ext ++ "-boot"

80 | isSource = ext ++ "-boot"

72 | otherwise = ext

81 | otherwise = ext

83+-- | This function is used to map a package name to a set of import paths.

84+-- It only returns Just for unit-ids which are possible to import into the

85+-- current module. In particular, it will return Nothing for 'main' components

86+-- as they can never be imported into another package.

87+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])

88+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i

89+

74-- | locate a module in either the file system or the package database. Where we go from *daml to

90-- | locate a module in either the file system or the package database. Where we go from *daml to

75-- Haskell

91-- Haskell

76locateModule

92locateModule

77 :: MonadIO m

93 :: MonadIO m

78 => DynFlags

94 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

79 -> [String]

96 -> [String]

80 -> (NormalizedFilePath -> m Bool)

97 -> (NormalizedFilePath -> m Bool)

81 -> Located ModuleName

98 -> Located ModuleName

82 -> Maybe FastString

99 -> Maybe FastString

83 -> Bool

100 -> Bool

84 -> m (Either [FileDiagnostic] Import)

101 -> m (Either [FileDiagnostic] Import)

85−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

86 case mbPkgName of

103 case mbPkgName of

87 -- "this" means that we should only look in the current package

104 -- "this" means that we should only look in the current package

88 Just "this" -> do

105 Just "this" -> do

89− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

106+ lookupLocal [importPaths dflags]

90− case mbFile of

91− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

92− Just file -> toModLocation file

93 -- if a package name is given we only go look for a package

107 -- if a package name is given we only go look for a package

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

94− Just _pkgName -> lookupInPackageDB dflags

111+ | otherwise -> lookupInPackageDB dflags

95 Nothing -> do

112 Nothing -> do

96 -- first try to find the module as a file. If we can't find it try to find it in the package

113 -- first try to find the module as a file. If we can't find it try to find it in the package

97 -- database.

114 -- database.

115+ -- Here the importPaths for the current modules are added to the front of the import paths from the other components.

116+ -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in

117+ -- each component will end up being found in the wrong place and cause a multi-cradle match failure.

98− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

99 case mbFile of

119 case mbFile of

100 Nothing -> lookupInPackageDB dflags

120 Nothing -> lookupInPackageDB dflags

101 Just file -> toModLocation file

121 Just file -> toModLocation file

102 where

122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

103 toModLocation file = liftIO $ do

124 toModLocation file = liftIO $ do

104 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

105 return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

126 return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

106

127

128+ lookupLocal dirs = do

129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

130+ case mbFile of

131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

132+ Just file -> toModLocation file

107

133

108 lookupInPackageDB dfs =

134 lookupInPackageDB dfs =

109 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

src/Development/IDE/LSP/LanguageServer.hs+8−8

@@ -144,14 +144,14 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

144 Response x@RequestMessage{_id, _params} wrap act ->

145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146 \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151 \(res, newReq) -> do

152 case res of

153− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

154− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155 whenJust newReq $ \(rm, newReqParams) -> do

156 reqId <- getNextReqId

157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175 Left () -> do

176 logDebug (ideLogger ide) $ T.pack $

177 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179− Just $ ResponseError RequestCancelled "" Nothing

179+ $ ResponseError RequestCancelled "" Nothing

180 Right res -> k res

181 ) $ \(e :: SomeException) -> do

182 logError (ideLogger ide) $ T.pack $

183 "Unexpected exception on request, please report!\n" ++

184 "Message: " ++ show msg ++ "\n" ++

185 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187− Just $ ResponseError InternalError (T.pack $ show e) Nothing

187+ $ ResponseError InternalError (T.pack $ show e) Nothing

188

189initializeRequestHandler :: PartialHandlers config

190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{

src/Development/IDE/LSP/Outline.hs+16−4

@@ -43,7 +43,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

43 mb_decls <- runAction ideState $ use GetParsedModule fp

44 pure $ Right $ case mb_decls of

45 Nothing -> DSDocumentSymbols (List [])

46− Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })

46+ Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

47 -> let

48 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

49 moduleSymbol = hsmodName <&> \(L l m) ->

@@ -108,27 +108,39 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

108 { _name = showRdrName n

109 , _kind = SkConstructor

110 , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

111 }

112 }

112 | L l x <- dd_cons

113 | L l x <- dd_cons

113 , L l' n <- getConNames x

114 , L l' n <- getConNames x

114 ]

115 ]

115 }

116 }

117+ where

118+ -- | Extract the record fields of a constructor

119+ conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List

120+ [ (defDocumentSymbol l :: DocumentSymbol)

121+ { _name = showRdrName n

122+ , _kind = SkField

123+ }

124+ | L _ cdf <- lcdfs

125+ , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf

126+ ]

127+ conArgRecordFields _ = Nothing

116documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

117 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

118 , _kind = SkTypeParameter

130 , _kind = SkTypeParameter

119 , _selectionRange = srcSpanToRange l'

131 , _selectionRange = srcSpanToRange l'

120 }

132 }

121−documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))

133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

122 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

123 , _kind = SkInterface

135 , _kind = SkInterface

124 }

136 }

125−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

126 = Just (defDocumentSymbol l :: DocumentSymbol)

138 = Just (defDocumentSymbol l :: DocumentSymbol)

127 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

128 (map pprText feqn_pats)

140 (map pprText feqn_pats)

129 , _kind = SkInterface

141 , _kind = SkInterface

130 }

142 }

131−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

132 = Just (defDocumentSymbol l :: DocumentSymbol)

144 = Just (defDocumentSymbol l :: DocumentSymbol)

133 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

134 (map pprText feqn_pats)

146 (map pprText feqn_pats)

src/Development/IDE/Plugin.hs+24−1

@@ -1,11 +1,13 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

4import Data.Default

5+import qualified Data.Text as T

5import Development.Shake

6import Development.Shake

6import Development.IDE.LSP.Server

7import Development.IDE.LSP.Server

8import Language.Haskell.LSP.Types

9import Language.Haskell.LSP.Types

10+import Development.IDE.Compat

9import Development.IDE.Core.Rules

11import Development.IDE.Core.Rules

10import qualified Language.Haskell.LSP.Core as LSP

12import qualified Language.Haskell.LSP.Core as LSP

11import Language.Haskell.LSP.Messages

13import Language.Haskell.LSP.Messages

@@ -35,3 +37,24 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..}

35 }

37 }

36 where

38 where

37 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

39 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

40+

41+-- | Prefix to uniquely identify commands sent to the client. This

42+-- has two parts

43+--

44+-- - A representation of the process id to make sure that a client has

45+-- unique commands if it is running multiple servers, since some

46+-- clients have a global command table and get confused otherwise.

47+--

48+-- - A string to identify ghcide, to ease integration into

49+-- haskell-language-server, which routes commands to plugins based

50+-- on that.

51+makeLspCommandId :: T.Text -> IO T.Text

52+makeLspCommandId command = do

53+ pid <- getPid

54+ return $ pid <> ":ghcide:" <> command

55+

56+-- | Get the operating system process id for the running server

57+-- instance. This should be the same for the lifetime of the instance,

58+-- and different from that of any other currently running instance.

59+getPid :: IO T.Text

60+getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hs+10−2

@@ -14,6 +14,7 @@ module Development.IDE.Plugin.CodeAction

14 , codeAction

15 , codeLens

16 , rulePackageExports

17+ , executeAddSignatureCommand

17 ) where

18 ) where

19import Language.Haskell.LSP.Types

20import Language.Haskell.LSP.Types

@@ -92,13 +93,14 @@ codeLens

92 -> CodeLensParams

93 -> CodeLensParams

93 -> IO (Either ResponseError (List CodeLens))

94 -> IO (Either ResponseError (List CodeLens))

94codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

95codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96+ commandId <- makeLspCommandId "typesignature.add"

95 fmap (Right . List) $ case uriToFilePath' uri of

97 fmap (Right . List) $ case uriToFilePath' uri of

96 Just (toNormalizedFilePath' -> filePath) -> do

98 Just (toNormalizedFilePath' -> filePath) -> do

97 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

99 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

98 diag <- getDiagnostics ideState

100 diag <- getDiagnostics ideState

99 hDiag <- getHiddenDiagnostics ideState

101 hDiag <- getHiddenDiagnostics ideState

100 pure

102 pure

101− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

102 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

104 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

103 , dFile == filePath

105 , dFile == filePath

104 , (title, tedit) <- suggestSignature False dDiag

106 , (title, tedit) <- suggestSignature False dDiag

@@ -113,7 +115,11 @@ executeAddSignatureCommand

113 -> ExecuteCommandParams

115 -> ExecuteCommandParams

114 -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

116 -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

115executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

117executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

118+ -- _command is prefixed with a process ID, because certain clients

119+ -- have a global command registry, and all commands must be

120+ -- unique. And there can be more than one ghcide instance running

121+ -- at a time against the same client.

116− | _command == "typesignature.add"

122+ | T.isSuffixOf "typesignature.add" _command

117 , Just (List [edit]) <- _arguments

123 , Just (List [edit]) <- _arguments

118 , Success wedit <- fromJSON edit

124 , Success wedit <- fromJSON edit

119 = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

125 = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

@@ -418,6 +424,8 @@ extractNotInScopeName x

418 = Just $ NotInScopeDataConstructor name

424 = Just $ NotInScopeDataConstructor name

419 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

425 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

420 = Just $ NotInScopeTypeConstructorOrClass name

426 = Just $ NotInScopeTypeConstructorOrClass name

427+ | Just [name] <- matchRegex x "ot in scope: \$([^‘ ]+)\$"

428+ = Just $ NotInScopeThing name

421 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

429 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

422 = Just $ NotInScopeThing name

430 = Just $ NotInScopeThing name

423 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

431 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

src/Development/IDE/Plugin/Completions.hs+13−2

@@ -1,9 +1,10 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

3+#include "ghc-api-version.h"

3module Development.IDE.Plugin.Completions(plugin) where

5module Development.IDE.Plugin.Completions(plugin) where

5import Control.Applicative

7import Control.Applicative

6−import Data.Maybe

7import Language.Haskell.LSP.Messages

8import Language.Haskell.LSP.Messages

8import Language.Haskell.LSP.Types

9import Language.Haskell.LSP.Types

9import qualified Language.Haskell.LSP.Core as LSP

10import qualified Language.Haskell.LSP.Core as LSP

@@ -22,8 +23,11 @@ import Development.IDE.Core.RuleTypes

22import Development.IDE.Core.Shake

23import Development.IDE.Core.Shake

23import Development.IDE.GHC.Util

24import Development.IDE.GHC.Util

24import Development.IDE.LSP.Server

25import Development.IDE.LSP.Server

25−import Development.IDE.Import.DependencyInformation

27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28+import Data.Maybe

29+import Development.IDE.Import.DependencyInformation

30+#endif

28plugin :: Plugin c

32plugin :: Plugin c

29plugin = Plugin produceCompletions setHandlersCompletion

33plugin = Plugin produceCompletions setHandlersCompletion

@@ -31,8 +35,15 @@ plugin = Plugin produceCompletions setHandlersCompletion

31produceCompletions :: Rules ()

35produceCompletions :: Rules ()

32produceCompletions =

36produceCompletions =

33 define $ \ProduceCompletions file -> do

37 define $ \ProduceCompletions file -> do

38+

39+-- When possible, rely on the haddocks embedded in our interface files

40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

42+ let parsedDeps = []

43+#else

34 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

44 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

35 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

45 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

46+#endif

36 tm <- fmap fst <$> useWithStale TypeCheck file

47 tm <- fmap fst <$> useWithStale TypeCheck file

37 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

48 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

38 case (tm, packageState) of

49 case (tm, packageState) of

src/Development/IDE/Plugin/Completions/Logic.hs+2−2

@@ -11,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (

11import Control.Applicative

12import Data.Char (isSpace, isUpper)

13import Data.Generics

14−import Data.List as List hiding (stripPrefix)

14+import Data.List.Extra as List hiding (stripPrefix)

15import qualified Data.Map as Map

16import Data.Maybe (fromMaybe, mapMaybe)

17import qualified Data.Text as T

@@ -162,7 +162,7 @@ getArgText typ = argText

162 where

163 argTypes = getArgs typ

164 argText :: T.Text

165− argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes

165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

166 snippet :: Int -> Type -> T.Text

167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168 getArgs :: Type -> [Type]

src/Development/IDE/Spans/AtPoint.hs+1−1

@@ -123,7 +123,7 @@ locationsAtPoint

123 -> Position

124 -> [SpanInfo]

125 -> m [Location]

126−locationsAtPoint getHieFile IdeOptions{..} pos =

126+locationsAtPoint getHieFile _ideOptions pos =

127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

129 getSpan NoSource = pure Nothing

src/Development/IDE/Spans/Calculate.hs+9−7

@@ -52,29 +52,31 @@ getSrcSpanInfos

52 :: HscEnv

53 -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

54 -> TcModuleResult

55− -> [(ParsedModule, ModIface)]

55+ -> [ParsedModule] -- ^ Dependencies parsed, optional

56+ -> [ModIface] -- ^ Dependencies module interfaces, required

56 -> IO SpansInfo

57 -> IO SpansInfo

57−getSrcSpanInfos env imports tc deps =

58+getSrcSpanInfos env imports tc parsedDeps deps =

58 evalGhcEnv env $

59 evalGhcEnv env $

59− getSpanInfo imports (tmrModule tc) deps

60+ getSpanInfo imports (tmrModule tc) parsedDeps deps

61-- | Get ALL source spans in the module.

62-- | Get ALL source spans in the module.

62getSpanInfo :: GhcMonad m

63getSpanInfo :: GhcMonad m

63 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

64 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

64 -> TypecheckedModule

65 -> TypecheckedModule

65− -> [(ParsedModule, ModIface)]

66+ -> [ParsedModule]

67+ -> [ModIface]

66 -> m SpansInfo

68 -> m SpansInfo

67−getSpanInfo mods tcm@TypecheckedModule{..} deps =

69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

68 do let tcs = tm_typechecked_source

70 do let tcs = tm_typechecked_source

69 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

71 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

70 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

72 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

71 ps = listifyAllSpans' tcs :: [Pat GhcTc]

73 ps = listifyAllSpans' tcs :: [Pat GhcTc]

72 ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]

74 ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]

73− allModules = tm_parsed_module : map fst deps

75+ allModules = tm_parsed_module : parsedDeps

74 funBinds = funBindMap tm_parsed_module

76 funBinds = funBindMap tm_parsed_module

76 -- Load all modules in HPT to make their interface documentation available

78 -- Load all modules in HPT to make their interface documentation available

77− mapM_ ((`loadDepModule` Nothing) . snd) (reverse deps)

79+ mapM_ (`loadDepModule` Nothing) (reverse deps)

78 forM_ (modInfoIface tm_checked_module_info) $ \modIface ->

80 forM_ (modInfoIface tm_checked_module_info) $ \modIface ->

79 modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)

81 modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)

src/Development/IDE/Types/Diagnostics.hs+4

@@ -6,6 +6,7 @@ module Development.IDE.Types.Diagnostics (

6 LSP.Diagnostic(..),

7 ShowDiagnostic(..),

8 FileDiagnostic,

9+ IdeResult,

9 LSP.DiagnosticSeverity(..),

10 LSP.DiagnosticSeverity(..),

10 DiagnosticStore,

11 DiagnosticStore,

11 List(..),

12 List(..),

@@ -31,6 +32,9 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

32import Development.IDE.Types.Location

33import Development.IDE.Types.Location

35+-- A rule on a file should only return diagnostics for that given file. It should

36+-- not propagate diagnostic errors through multiple phases.

37+type IdeResult v = ([FileDiagnostic], Maybe v)

35ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

36ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

40ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

src/Development/IDE/Types/Options.hs+4−5

@@ -12,6 +12,7 @@ module Development.IDE.Types.Options

12 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15+ , IdeResult

15 ) where

16 ) where

17import Development.Shake

18import Development.Shake

@@ -20,12 +21,13 @@ import GHC hiding (parseModule, typecheckModule)

20import GhcPlugins as GHC hiding (fst3, (<>))

21import GhcPlugins as GHC hiding (fst3, (<>))

21import qualified Language.Haskell.LSP.Types.Capabilities as LSP

22import qualified Language.Haskell.LSP.Types.Capabilities as LSP

22import qualified Data.Text as T

23import qualified Data.Text as T

24+import Development.IDE.Types.Diagnostics

24data IdeOptions = IdeOptions

26data IdeOptions = IdeOptions

25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

27 -- and a list of errors, along with a new parse tree.

29 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: Action (FilePath -> Action HscEnvEq)

30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

30 -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

32 -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

@@ -58,8 +60,6 @@ data IdeOptions = IdeOptions

58 -- features such as diagnostics and go-to-definition, in

60 -- features such as diagnostics and go-to-definition, in

59 -- situations in which they would become unavailable because of

61 -- situations in which they would become unavailable because of

60 -- the presence of type errors, holes or unbound variables.

62 -- the presence of type errors, holes or unbound variables.

61− , optInterfaceLoadingDiagnostics :: Bool

62− -- ^ Generate Info-level diagnostics to report interface loading actions

63 }

65data IdePreprocessedSource = IdePreprocessedSource

@@ -78,7 +78,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

78clientSupportsProgress caps = IdeReportProgress $ Just True ==

79 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

81−defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

82defaultIdeOptions session = IdeOptions

83 {optPreprocessor = IdePreprocessedSource [] []

84 ,optGhcSession = session

@@ -93,7 +93,6 @@ defaultIdeOptions session = IdeOptions

93 ,optKeywords = haskellKeywords

94 ,optDefer = IdeDefer True

95 ,optTesting = False

96− ,optInterfaceLoadingDiagnostics = False

97 }

96 }

stack-ghc-lib.yaml+5−5

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-16

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.10.3.0

8−- hie-bios-0.4.0

8+- hie-bios-0.5.0

9- ghc-lib-parser-8.8.1

10- ghc-lib-8.8.1

11- fuzzy-0.1.0.0

@@ -13,7 +13,7 @@ extra-deps:

13- regex-base-0.94.0.0

14- regex-tdfa-1.3.1.0

15- haddock-library-1.8.0

16−- ghc-check-0.1.0.3

16+- ghc-check-0.3.0.1

17nix:

18 packages: [zlib]

19flags:

stack.yaml+5−5

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.11.0.1

8−- hie-bios-0.4.0

8+- hie-bios-0.5.0

9- fuzzy-0.1.0.0

10- regex-pcre-builtin-0.95.1.1.8.43

11- regex-base-0.94.0.0

@@ -14,6 +14,6 @@ extra-deps:

14- parser-combinators-1.2.1

15- haddock-library-1.8.0

16- tasty-rerun-1.1.17

17−- ghc-check-0.1.0.3

17+- ghc-check-0.3.0.1

18nix:

19 packages: [zlib]

stack810.yamlnew file+18

@@ -0,0 +1,18 @@

1+resolver: nightly-2020-02-13

2+compiler: ghc-8.10.1

3+allow-newer: true

4+packages:

5+- .

6+extra-deps:

7+- haskell-lsp-0.22.0.0

8+- haskell-lsp-types-0.22.0.0

9+- lsp-test-0.11.0.1

10+- ghc-check-0.3.0.1

11+- hie-bios-0.5.0

12+

13+# for ghc-8.10

14+- Cabal-3.2.0.0

15+- lens-4.19.1

16+

17+nix:

18+ packages: [zlib]

stack84.yaml+5−6

@@ -5,13 +5,13 @@ packages:

5extra-deps:

6- aeson-1.4.6.0

7- base-orphans-0.8.2

8−- haskell-lsp-0.21.0.0

8+- haskell-lsp-0.22.0.0

9−- haskell-lsp-types-0.21.0.0

9+- haskell-lsp-types-0.22.0.0

10−- lsp-test-0.10.2.0

10+- lsp-test-0.11.0.1

11- rope-utf16-splay-0.3.1.0

12- filepattern-0.1.1

13- js-dgtable-0.5.2

14−- hie-bios-0.4.0

14+- hie-bios-0.5.0

15- fuzzy-0.1.0.0

16- shake-0.18.5

17- time-compat-1.9.2.2

@@ -22,8 +22,7 @@ extra-deps:

22- unordered-containers-0.2.10.0

23- file-embed-0.0.11.2

24- heaps-0.3.6.1

25−- ghc-check-0.1.0.3

25+- ghc-check-0.3.0.1

26−

27# For tasty-retun

26# For tasty-retun

28- ansi-terminal-0.10.3

27- ansi-terminal-0.10.3

29- ansi-wl-pprint-0.6.9

28- ansi-wl-pprint-0.6.9

stack88.yaml+5−5

@@ -2,10 +2,10 @@ resolver: nightly-2020-02-13

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.21.0.0

5+- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.21.0.0

6+- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.2.0

7+- lsp-test-0.11.0.1

8−- ghc-check-0.1.0.3

8+- ghc-check-0.3.0.1

9−

9+- hie-bios-0.5.0

10nix:

11 packages: [zlib]

test/data/Bar.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Bar (Bar) where

2−

3−data Bar = Bar

test/data/hover/Bar.hsnew file+3

@@ -0,0 +1,3 @@

1+module Bar (Bar(..)) where

3+data Bar = Bar

test/data/Foo.hs → test/data/hover/Foo.hsrenamed

The content is the same.

test/data/GotoHover.hs → test/data/hover/GotoHover.hsrenamed+1−1

@@ -1,10 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

1{- HLINT ignore -}

2{- HLINT ignore -}

2module Testing ( module Testing ) where

3module Testing ( module Testing ) where

3import Data.Text (Text, pack)

4import Data.Text (Text, pack)

4import Foo (Bar, foo)

5import Foo (Bar, foo)

7−

8data TypeConstructor = DataConstructor

9 { fff :: Text

10 , ggg :: Int }

test/data/multi/a/A.hsnew file+3

@@ -0,0 +1,3 @@

1+module A(foo) where

3+foo = ()

test/data/multi/a/a.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: a

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base

8+ exposed-modules: A

9+ hs-source-dirs: .

test/data/multi/b/B.hsnew file+3

@@ -0,0 +1,3 @@

1+module B(module B) where

2+import A

3+qux = foo

test/data/multi/b/b.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: b

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base, a

8+ exposed-modules: B

9+ hs-source-dirs: .

test/data/multi/cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: a b

test/data/multi/hie.yamlnew file+6

@@ -0,0 +1,6 @@

1+cradle:

2+ cabal:

3+ - path: "./a"

4+ component: "lib:a"

5+ - path: "./b"

6+ component: "lib:b"

test/exe/Main.hs+368−205

@@ -1,6 +1,7 @@

2-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE DuplicateRecordFields #-}

5{-# LANGUAGE DuplicateRecordFields #-}

5{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE CPP #-}

7{-# LANGUAGE CPP #-}

@@ -9,31 +10,32 @@

9module Main (main) where

10module Main (main) where

11import Control.Applicative.Combinators

12import Control.Applicative.Combinators

12−import Control.Exception (catch)

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

13import Control.Monad

15import Control.Monad

14import Control.Monad.IO.Class (liftIO)

16import Control.Monad.IO.Class (liftIO)

15−import Data.Aeson (Value)

17+import Data.Aeson (FromJSON, Value)

16−import Data.Char (toLower)

17import Data.Foldable

18import Data.Foldable

18−import Data.List

19+import Data.List.Extra

19import Data.Rope.UTF16 (Rope)

20import Data.Rope.UTF16 (Rope)

20import qualified Data.Rope.UTF16 as Rope

21import qualified Data.Rope.UTF16 as Rope

21import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

22import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

22import Development.IDE.GHC.Util

23import Development.IDE.GHC.Util

23import qualified Data.Text as T

24import qualified Data.Text as T

25+import Data.Typeable

24import Development.IDE.Spans.Common

26import Development.IDE.Spans.Common

25import Development.IDE.Test

27import Development.IDE.Test

26import Development.IDE.Test.Runfiles

28import Development.IDE.Test.Runfiles

27import Development.IDE.Types.Location

29import Development.IDE.Types.Location

28import Development.Shake (getDirectoryFilesIO)

30import Development.Shake (getDirectoryFilesIO)

29−import qualified Language.Haskell.LSP.Test as LSPTest

31+import Language.Haskell.LSP.Test

30−import Language.Haskell.LSP.Test hiding (openDoc')

31import Language.Haskell.LSP.Messages

32import Language.Haskell.LSP.Messages

32import Language.Haskell.LSP.Types

33import Language.Haskell.LSP.Types

33import Language.Haskell.LSP.Types.Capabilities

34import Language.Haskell.LSP.Types.Capabilities

35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

34import Language.Haskell.LSP.VFS (applyChange)

36import Language.Haskell.LSP.VFS (applyChange)

35import Network.URI

37import Network.URI

36−import System.Environment.Blank (setEnv)

38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)

37import System.FilePath

39import System.FilePath

38import System.IO.Extra

40import System.IO.Extra

39import System.Directory

41import System.Directory

@@ -47,31 +49,35 @@ import Test.Tasty.QuickCheck

47import Data.Maybe

49import Data.Maybe

49main :: IO ()

51main :: IO ()

52+main = do

53+ -- We mess with env vars so run single-threaded.

54+ setEnv "TASTY_NUM_THREADS" "1" True

50−main = defaultMainWithRerun $ testGroup "HIE"

55+ defaultMainWithRerun $ testGroup "HIE"

51− [ testSession "open close" $ do

56+ [ testSession "open close" $ do

52− doc <- openDoc' "Testing.hs" "haskell" ""

57+ doc <- createDoc "Testing.hs" "haskell" ""

53− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

54− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

55− closeDoc doc

60+ closeDoc doc

56− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

57− , initializeResponseTests

62+ , initializeResponseTests

58− , completionTests

63+ , completionTests

59− , cppTests

64+ , cppTests

60− , diagnosticTests

65+ , diagnosticTests

61− , codeActionTests

66+ , codeActionTests

62− , codeLensesTests

67+ , codeLensesTests

63− , outlineTests

68+ , outlineTests

64− , findDefinitionAndHoverTests

69+ , findDefinitionAndHoverTests

65− , pluginTests

70+ , pluginTests

66− , preprocessorTests

71+ , preprocessorTests

67− , thTests

72+ , thTests

68− , safeTests

73+ , safeTests

69− , unitTests

74+ , unitTests

70− , haddockTests

75+ , haddockTests

71− , positionMappingTests

76+ , positionMappingTests

72− , watchedFilesTests

77+ , watchedFilesTests

73− , cradleTests

78+ , cradleTests

79+ , dependentFileTest

74− ]

80+ ]

76initializeResponseTests :: TestTree

82initializeResponseTests :: TestTree

77initializeResponseTests = withResource acquire release tests where

83initializeResponseTests = withResource acquire release tests where

@@ -106,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where

106 , chk "NO doc link" _documentLinkProvider Nothing

112 , chk "NO doc link" _documentLinkProvider Nothing

107 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

108 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

109− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

110 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

111 , chk "NO experimental" _experimental Nothing

117 , chk "NO experimental" _experimental Nothing

112 ] where

118 ] where

@@ -122,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where

122 chk title getActual expected =

128 chk title getActual expected =

123 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

124

130

131+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree

132+ che title getActual _expected = testCase title doTest

133+ where

134+ doTest = do

135+ ir <- getInitializeResponse

136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir

137+ True @=? T.isSuffixOf "typesignature.add" command

138+

139+

125 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

126− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

127 innerCaps _ = error "this test only expects inner capabilities"

142 innerCaps _ = error "this test only expects inner capabilities"

128

143

129 acquire :: IO InitializeResponse

144 acquire :: IO InitializeResponse

@@ -137,7 +152,7 @@ diagnosticTests :: TestTree

137diagnosticTests = testGroup "diagnostics"

152diagnosticTests = testGroup "diagnostics"

138 [ testSessionWait "fix syntax error" $ do

153 [ testSessionWait "fix syntax error" $ do

139 let content = T.unlines [ "module Testing wher" ]

154 let content = T.unlines [ "module Testing wher" ]

140− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

141 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

142 let change = TextDocumentContentChangeEvent

157 let change = TextDocumentContentChangeEvent

143 { _range = Just (Range (Position 0 15) (Position 0 19))

158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -148,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"

148 expectDiagnostics [("Testing.hs", [])]

163 expectDiagnostics [("Testing.hs", [])]

149 , testSessionWait "introduce syntax error" $ do

164 , testSessionWait "introduce syntax error" $ do

150 let content = T.unlines [ "module Testing where" ]

165 let content = T.unlines [ "module Testing where" ]

151− doc <- openDoc' "Testing.hs" "haskell" content

166+ doc <- createDoc "Testing.hs" "haskell" content

152 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

153 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

154 let change = TextDocumentContentChangeEvent

169 let change = TextDocumentContentChangeEvent

@@ -166,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

166 , "bar :: Int -> Int -> Int"

181 , "bar :: Int -> Int -> Int"

167 , "bar a b = cd + b"

182 , "bar a b = cd + b"

168 ]

183 ]

169− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

170 expectDiagnostics

185 expectDiagnostics

171 [ ( "Testing.hs"

186 [ ( "Testing.hs"

172 , [ (DsError, (2, 14), "Variable not in scope: ab")

187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -180,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

180 , "foo :: Int -> String -> Int"

195 , "foo :: Int -> String -> Int"

181 , "foo a b = a + b"

196 , "foo a b = a + b"

182 ]

197 ]

183− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

184 expectDiagnostics

199 expectDiagnostics

185 [ ( "Testing.hs"

200 [ ( "Testing.hs"

186 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -192,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

192 , "foo :: Int -> String"

207 , "foo :: Int -> String"

193 , "foo a = _ a"

208 , "foo a = _ a"

194 ]

209 ]

195− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

196 expectDiagnostics

211 expectDiagnostics

197 [ ( "Testing.hs"

212 [ ( "Testing.hs"

198 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -214,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

214 [ ("A.hs", [(DsError, (2,4), aMessage)])

229 [ ("A.hs", [(DsError, (2,4), aMessage)])

215 , ("B.hs", [(DsError, (3,4), bMessage)])]

230 , ("B.hs", [(DsError, (3,4), bMessage)])]

216 deferralTest title binding msg = testSessionWait title $ do

231 deferralTest title binding msg = testSessionWait title $ do

217− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

218− _ <- openDoc' "B.hs" "haskell" sourceB

233+ _ <- createDoc "B.hs" "haskell" sourceB

219 expectDiagnostics $ expectedDs msg

234 expectDiagnostics $ expectedDs msg

220 in

235 in

221 [ deferralTest "type error" "True" "Couldn't match expected type"

236 [ deferralTest "type error" "True" "Couldn't match expected type"

222 , deferralTest "typed hole" "_" "Found hole"

237 , deferralTest "typed hole" "_" "Found hole"

223 , deferralTest "out of scope var" "unbound" "Variable not in scope"

238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

224− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

225 ]

239 ]

226

240

227 , testSessionWait "remove required module" $ do

241 , testSessionWait "remove required module" $ do

228 let contentA = T.unlines [ "module ModuleA where" ]

242 let contentA = T.unlines [ "module ModuleA where" ]

229− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

230 let contentB = T.unlines

244 let contentB = T.unlines

231 [ "module ModuleB where"

245 [ "module ModuleB where"

232 , "import ModuleA"

246 , "import ModuleA"

233 ]

247 ]

234− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

235 let change = TextDocumentContentChangeEvent

249 let change = TextDocumentContentChangeEvent

236 { _range = Just (Range (Position 0 0) (Position 0 20))

250 { _range = Just (Range (Position 0 0) (Position 0 20))

237 , _rangeLength = Nothing

251 , _rangeLength = Nothing

@@ -244,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"

244 [ "module ModuleB where"

258 [ "module ModuleB where"

245 , "import ModuleA"

259 , "import ModuleA"

246 ]

260 ]

247− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

248 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

249 let contentA = T.unlines [ "module ModuleA where" ]

263 let contentA = T.unlines [ "module ModuleA where" ]

250− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

251 expectDiagnostics [("ModuleB.hs", [])]

265 expectDiagnostics [("ModuleB.hs", [])]

252 , testSessionWait "add missing module (non workspace)" $ do

266 , testSessionWait "add missing module (non workspace)" $ do

253 let contentB = T.unlines

267 let contentB = T.unlines

254 [ "module ModuleB where"

268 [ "module ModuleB where"

255 , "import ModuleA"

269 , "import ModuleA"

256 ]

270 ]

257− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

258 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

259 let contentA = T.unlines [ "module ModuleA where" ]

273 let contentA = T.unlines [ "module ModuleA where" ]

260− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

261 expectDiagnostics [("/tmp/ModuleB.hs", [])]

275 expectDiagnostics [("/tmp/ModuleB.hs", [])]

262 , testSessionWait "cyclic module dependency" $ do

276 , testSessionWait "cyclic module dependency" $ do

263 let contentA = T.unlines

277 let contentA = T.unlines

@@ -268,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

268 [ "module ModuleB where"

282 [ "module ModuleB where"

269 , "import ModuleA"

283 , "import ModuleA"

270 ]

284 ]

271− _ <- openDoc' "ModuleA.hs" "haskell" contentA

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

272− _ <- openDoc' "ModuleB.hs" "haskell" contentB

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

273 expectDiagnostics

287 expectDiagnostics

274 [ ( "ModuleA.hs"

288 [ ( "ModuleA.hs"

275 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -290,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

290 let contentBboot = T.unlines

304 let contentBboot = T.unlines

291 [ "module ModuleB where"

305 [ "module ModuleB where"

292 ]

306 ]

293− _ <- openDoc' "ModuleA.hs" "haskell" contentA

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

294− _ <- openDoc' "ModuleB.hs" "haskell" contentB

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

295− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

296 expectDiagnostics []

310 expectDiagnostics []

297 , testSessionWait "correct reference used with hs-boot" $ do

311 , testSessionWait "correct reference used with hs-boot" $ do

298 let contentB = T.unlines

312 let contentB = T.unlines

@@ -314,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

314 -- resolved to the hs-boot file

328 -- resolved to the hs-boot file

315 , "y = x"

329 , "y = x"

316 ]

330 ]

317− _ <- openDoc' "ModuleB.hs" "haskell" contentB

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

318− _ <- openDoc' "ModuleA.hs" "haskell" contentA

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

319− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

320− _ <- openDoc' "ModuleC.hs" "haskell" contentC

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

321 expectDiagnostics []

335 expectDiagnostics []

322 , testSessionWait "redundant import" $ do

336 , testSessionWait "redundant import" $ do

323 let contentA = T.unlines ["module ModuleA where"]

337 let contentA = T.unlines ["module ModuleA where"]

@@ -326,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

326 , "module ModuleB where"

340 , "module ModuleB where"

327 , "import ModuleA"

341 , "import ModuleA"

328 ]

342 ]

329− _ <- openDoc' "ModuleA.hs" "haskell" contentA

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

330− _ <- openDoc' "ModuleB.hs" "haskell" contentB

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

331 expectDiagnostics

345 expectDiagnostics

332 [ ( "ModuleB.hs"

346 [ ( "ModuleB.hs"

333 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -349,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

349 , "wrong1 = ThisList.map"

363 , "wrong1 = ThisList.map"

350 , "wrong2 = BaseList.x"

364 , "wrong2 = BaseList.x"

351 ]

365 ]

352− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

353− _ <- openDoc' "Main.hs" "haskell" mainContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

354 expectDiagnostics

368 expectDiagnostics

355 [ ( "Main.hs"

369 [ ( "Main.hs"

356 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -365,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

365 , "foo :: Ord a => a -> Int"

379 , "foo :: Ord a => a -> Int"

366 , "foo a = 1"

380 , "foo a = 1"

367 ]

381 ]

368− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

369 expectDiagnostics

383 expectDiagnostics

370 [ ( "Foo.hs"

384 [ ( "Foo.hs"

371 -- The test is to make sure that warnings contain unqualified names

385 -- The test is to make sure that warnings contain unqualified names

@@ -390,14 +404,14 @@ diagnosticTests = testGroup "diagnostics"

390 Just pathB <- pure $ uriToFilePath uriB

404 Just pathB <- pure $ uriToFilePath uriB

391 uriB <- pure $

405 uriB <- pure $

392 let (drive, suffix) = splitDrive pathB

406 let (drive, suffix) = splitDrive pathB

393− in filePathToUri (joinDrive (map toLower drive ) suffix)

407+ in filePathToUri (joinDrive (lower drive) suffix)

394 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

395 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

396 uriA <- getDocUri "A/A.hs"

410 uriA <- getDocUri "A/A.hs"

397 Just pathA <- pure $ uriToFilePath uriA

411 Just pathA <- pure $ uriToFilePath uriA

398 uriA <- pure $

412 uriA <- pure $

399 let (drive, suffix) = splitDrive pathA

413 let (drive, suffix) = splitDrive pathA

400− in filePathToUri (joinDrive (map toLower drive ) suffix)

414+ in filePathToUri (joinDrive (lower drive) suffix)

401 let itemA = TextDocumentItem uriA "haskell" 0 aContent

415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

402 let a = TextDocumentIdentifier uriA

416 let a = TextDocumentIdentifier uriA

403 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

@@ -410,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"

410 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

411 assertFailure ("Expected redundant import but got " <> T.unpack msg)

425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

412 closeDoc a

426 closeDoc a

427+ , testSessionWait "haddock parse error" $ do

428+ let fooContent = T.unlines

429+ [ "module Foo where"

430+ , "foo :: Int"

431+ , "foo = 1 {-|-}"

432+ ]

433+ _ <- createDoc "Foo.hs" "haskell" fooContent

434+ expectDiagnostics

435+ [ ( "Foo.hs"

436+ , [(DsError, (2, 8), "Parse error on input")

437+ ]

438+ )

439+ ]

440+ , testSessionWait "strip file path" $ do

441+ let

442+ name = "Testing"

443+ content = T.unlines

444+ [ "module " <> name <> " where"

445+ , "value :: Maybe ()"

446+ , "value = [()]"

447+ ]

448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content

449+ notification <- skipManyTill anyMessage diagnostic

450+ let

451+ offenders =

452+ Lsp.params .

453+ Lsp.diagnostics .

454+ Lens.folded .

455+ Lsp.message .

456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))

457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg

458+ Lens.mapMOf_ offenders failure notification

413 ]

459 ]

414

460

415codeActionTests :: TestTree

461codeActionTests :: TestTree

@@ -435,26 +481,26 @@ codeLensesTests = testGroup "code lenses"

435watchedFilesTests :: TestTree

481watchedFilesTests :: TestTree

436watchedFilesTests = testGroup "watched files"

482watchedFilesTests = testGroup "watched files"

437 [ testSession' "workspace files" $ \sessionDir -> do

483 [ testSession' "workspace files" $ \sessionDir -> do

438− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"

484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

439− _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"

485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

440− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

441−

487+

442− -- 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):

443− -- - /path-to-workspace/B.hs

489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

444− -- - /path-to-workspace/B.lhs

490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

445− -- - B.hs

491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

446− -- - B.lhs

492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

447− -- - src/B.hs

448− -- - src/B.lhs

449− liftIO $ length watchedFileRegs @?= 6

493+ liftIO $ length watchedFileRegs @?= 4

450

494

451 , testSession' "non workspace file" $ \sessionDir -> do

495 , testSession' "non workspace file" $ \sessionDir -> do

452− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

453− _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"

497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

454− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

455

499

456− -- Expect 4 subscriptions:

500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

457− liftIO $ length watchedFileRegs @?= 4

503+ liftIO $ length watchedFileRegs @?= 2

458

504

459 -- TODO add a test for didChangeWorkspaceFolder

505 -- TODO add a test for didChangeWorkspaceFolder

460 ]

506 ]

@@ -467,7 +513,7 @@ renameActionTests = testGroup "rename actions"

467 , "foo :: Int -> Int"

513 , "foo :: Int -> Int"

468 , "foo argName = argNme"

514 , "foo argName = argNme"

469 ]

515 ]

470− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

471 _ <- waitForDiagnostics

517 _ <- waitForDiagnostics

472 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

473 executeCodeAction action

519 executeCodeAction action

@@ -485,7 +531,7 @@ renameActionTests = testGroup "rename actions"

485 , "foo :: Maybe a -> [a]"

531 , "foo :: Maybe a -> [a]"

486 , "foo = maybToList"

532 , "foo = maybToList"

487 ]

533 ]

488− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

489 _ <- waitForDiagnostics

535 _ <- waitForDiagnostics

490 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

491 executeCodeAction action

537 executeCodeAction action

@@ -503,7 +549,7 @@ renameActionTests = testGroup "rename actions"

503 , "foo :: Char -> Char -> Char -> Char"

549 , "foo :: Char -> Char -> Char -> Char"

504 , "foo argument1 argument2 argument3 = argumentX"

550 , "foo argument1 argument2 argument3 = argumentX"

505 ]

551 ]

506− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

507 _ <- waitForDiagnostics

553 _ <- waitForDiagnostics

508 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

509 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -515,7 +561,7 @@ renameActionTests = testGroup "rename actions"

515 , "monus x y = max 0 (x - y)"

561 , "monus x y = max 0 (x - y)"

516 , "foo x y = x `monnus` y"

562 , "foo x y = x `monnus` y"

517 ]

563 ]

518− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

519 _ <- waitForDiagnostics

565 _ <- waitForDiagnostics

520 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

521 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -538,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

538 , "func :: _"

584 , "func :: _"

539 , "func x = x"

585 , "func x = x"

540 ]

586 ]

541− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

542 _ <- waitForDiagnostics

588 _ <- waitForDiagnostics

543 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

544 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -558,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

558 , "func :: _"

604 , "func :: _"

559 , "func x y = x + y"

605 , "func x y = x + y"

560 ]

606 ]

561− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

562 _ <- waitForDiagnostics

608 _ <- waitForDiagnostics

563 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

564 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -581,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

581 , " y = x * 2"

627 , " y = x * 2"

582 , " in y"

628 , " in y"

583 ]

629 ]

584− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

585 _ <- waitForDiagnostics

631 _ <- waitForDiagnostics

586 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

587 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -606,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

606 let contentA = T.unlines

652 let contentA = T.unlines

607 [ "module ModuleA where"

653 [ "module ModuleA where"

608 ]

654 ]

609− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

610 let contentB = T.unlines

656 let contentB = T.unlines

611 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

612 , "module ModuleB where"

658 , "module ModuleB where"

@@ -614,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

614 , "stuffB :: Integer"

660 , "stuffB :: Integer"

615 , "stuffB = 123"

661 , "stuffB = 123"

616 ]

662 ]

617− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

618 _ <- waitForDiagnostics

664 _ <- waitForDiagnostics

619 [CACodeAction action@CodeAction { _title = actionTitle }]

665 [CACodeAction action@CodeAction { _title = actionTitle }]

620 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -632,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

632 let contentA = T.unlines

678 let contentA = T.unlines

633 [ "module ModuleA where"

679 [ "module ModuleA where"

634 ]

680 ]

635− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

636 let contentB = T.unlines

682 let contentB = T.unlines

637 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

638 , "module ModuleB where"

684 , "module ModuleB where"

@@ -640,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

640 , "stuffB :: Integer"

686 , "stuffB :: Integer"

641 , "stuffB = 123"

687 , "stuffB = 123"

642 ]

688 ]

643− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

644 _ <- waitForDiagnostics

690 _ <- waitForDiagnostics

645 [CACodeAction action@CodeAction { _title = actionTitle }]

691 [CACodeAction action@CodeAction { _title = actionTitle }]

646 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -662,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

662 , "stuffB = 123"

708 , "stuffB = 123"

663 , "stuffC = ()"

709 , "stuffC = ()"

664 ]

710 ]

665− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

666 let contentB = T.unlines

712 let contentB = T.unlines

667 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

668 , "module ModuleB where"

714 , "module ModuleB where"

669 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

670 , "main = print stuffB"

716 , "main = print stuffB"

671 ]

717 ]

672− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

673 _ <- waitForDiagnostics

719 _ <- waitForDiagnostics

674 [CACodeAction action@CodeAction { _title = actionTitle }]

720 [CACodeAction action@CodeAction { _title = actionTitle }]

675 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -691,22 +737,18 @@ removeImportTests = testGroup "remove import actions"

691 , "stuffB :: Integer"

737 , "stuffB :: Integer"

692 , "stuffB = 123"

738 , "stuffB = 123"

693 ]

739 ]

694− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

695 let contentB = T.unlines

741 let contentB = T.unlines

696 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

697 , "module ModuleB where"

743 , "module ModuleB where"

698 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

699 , "main = print A.stuffB"

745 , "main = print A.stuffB"

700 ]

746 ]

701− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

702 _ <- waitForDiagnostics

748 _ <- waitForDiagnostics

703 [CACodeAction action@CodeAction { _title = actionTitle }]

749 [CACodeAction action@CodeAction { _title = actionTitle }]

704 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

705−#if MIN_GHC_API_VERSION(8,6,0)

706 liftIO $ "Remove !!, <?> from import" @=? actionTitle

751 liftIO $ "Remove !!, <?> from import" @=? actionTitle

707−#else

708− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle

709−#endif

710 executeCodeAction action

752 executeCodeAction action

711 contentAfterAction <- documentContents docB

753 contentAfterAction <- documentContents docB

712 let expectedContentAfterAction = T.unlines

754 let expectedContentAfterAction = T.unlines

@@ -723,14 +765,14 @@ removeImportTests = testGroup "remove import actions"

723 , "stuffB :: Integer"

765 , "stuffB :: Integer"

724 , "stuffB = 123"

766 , "stuffB = 123"

725 ]

767 ]

726− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

727 let contentB = T.unlines

769 let contentB = T.unlines

728 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

729 , "module ModuleB where"

771 , "module ModuleB where"

730 , "import ModuleA (A(..), stuffB)"

772 , "import ModuleA (A(..), stuffB)"

731 , "main = print stuffB"

773 , "main = print stuffB"

732 ]

774 ]

733− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

734 _ <- waitForDiagnostics

776 _ <- waitForDiagnostics

735 [CACodeAction action@CodeAction { _title = actionTitle }]

777 [CACodeAction action@CodeAction { _title = actionTitle }]

736 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -750,14 +792,14 @@ removeImportTests = testGroup "remove import actions"

750 , "data D = A | B"

792 , "data D = A | B"

751 , "data E = F"

793 , "data E = F"

752 ]

794 ]

753− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

754 let contentB = T.unlines

796 let contentB = T.unlines

755 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

756 , "module ModuleB where"

798 , "module ModuleB where"

757 , "import ModuleA (D(A,B), E(F))"

799 , "import ModuleA (D(A,B), E(F))"

758 , "main = B"

800 , "main = B"

759 ]

801 ]

760− docB <- openDoc' "ModuleB.hs" "haskell" contentB

802+ docB <- createDoc "ModuleB.hs" "haskell" contentB

761 _ <- waitForDiagnostics

803 _ <- waitForDiagnostics

762 [CACodeAction action@CodeAction { _title = actionTitle }]

804 [CACodeAction action@CodeAction { _title = actionTitle }]

763 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -898,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

898 ]

940 ]

899 where

941 where

900 template contentA contentB range expectedAction expectedContentB = do

942 template contentA contentB range expectedAction expectedContentB = do

901− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

902− docB <- openDoc' "ModuleB.hs" "haskell" contentB

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

903 _ <- waitForDiagnostics

945 _ <- waitForDiagnostics

904 CACodeAction action@CodeAction { _title = actionTitle } : _

946 CACodeAction action@CodeAction { _title = actionTitle } : _

905 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -939,6 +981,8 @@ suggestImportTests = testGroup "suggest import actions"

939 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"

981 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"

940 , test True [] "f = pack" [] "import Data.Text (pack)"

982 , test True [] "f = pack" [] "import Data.Text (pack)"

941 , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"

983 , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"

984+ , test True [] "f = [] & id" [] "import Data.Function ((&))"

985+ , test True [] "f = (&) [] id" [] "import Data.Function ((&))"

942 ]

986 ]

943 ]

987 ]

944 where

988 where

@@ -947,19 +991,20 @@ suggestImportTests = testGroup "suggest import actions"

947 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

948 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

949 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

950− doc <- openDoc' "Test.hs" "haskell" before

994+ doc <- createDoc "Test.hs" "haskell" before

951 _diags <- waitForDiagnostics

995 _diags <- waitForDiagnostics

952 let defLine = length imps + 1

996 let defLine = length imps + 1

953 range = Range (Position defLine 0) (Position defLine maxBound)

997 range = Range (Position defLine 0) (Position defLine maxBound)

954 actions <- getCodeActions doc range

998 actions <- getCodeActions doc range

955− case wanted of

999+ if wanted

956− False ->

1000+ then do

1001+ action <- liftIO $ pickActionWithTitle newImp actions

1002+ executeCodeAction action

1003+ contentAfterAction <- documentContents doc

1004+ liftIO $ after @=? contentAfterAction

1005+ else

957− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

958− True -> do

1007+

959− action <- liftIO $ pickActionWithTitle newImp actions

960− executeCodeAction action

961− contentAfterAction <- documentContents doc

962− liftIO $ after @=? contentAfterAction

963

1008

964addExtensionTests :: TestTree

1009addExtensionTests :: TestTree

965addExtensionTests = testGroup "add language extension actions"

1010addExtensionTests = testGroup "add language extension actions"

@@ -1006,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

1006 ]

1051 ]

1007 where

1052 where

1008 template initialContent range expectedAction expectedContents = do

1053 template initialContent range expectedAction expectedContents = do

1009− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

1010 _ <- waitForDiagnostics

1055 _ <- waitForDiagnostics

1011 CACodeAction action@CodeAction { _title = actionTitle } : _

1056 CACodeAction action@CodeAction { _title = actionTitle } : _

1012 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1029,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

1029 [""

1074 [""

1030 ,"someOtherCode = ()"

1075 ,"someOtherCode = ()"

1031 ]

1076 ]

1032− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1033 _ <- waitForDiagnostics

1078 _ <- waitForDiagnostics

1034 CACodeAction action@CodeAction { _title = actionTitle } : _

1079 CACodeAction action@CodeAction { _title = actionTitle } : _

1035 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1053,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

1053 [""

1098 [""

1054 ,"someOtherCode = ()"

1099 ,"someOtherCode = ()"

1055 ]

1100 ]

1056− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1057 _ <- waitForDiagnostics

1102 _ <- waitForDiagnostics

1058 CACodeAction action@CodeAction { _title = actionTitle } : _

1103 CACodeAction action@CodeAction { _title = actionTitle } : _

1059 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1092,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

1092 ]

1137 ]

1093 where

1138 where

1094 template contentA contentB range expectedAction expectedContentB = do

1139 template contentA contentB range expectedAction expectedContentB = do

1095− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1096− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

1097 _diags <- waitForDiagnostics

1142 _diags <- waitForDiagnostics

1098 CACodeAction action@CodeAction { _title = actionTitle } : _

1143 CACodeAction action@CodeAction { _title = actionTitle } : _

1099 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1112,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

1112 [ "module Testing where"

1157 [ "module Testing where"

1113 , "import Data.Mape"

1158 , "import Data.Mape"

1114 ]

1159 ]

1115− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

1116 _ <- waitForDiagnostics

1161 _ <- waitForDiagnostics

1117 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1118 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1149,7 +1194,7 @@ fillTypedHoleTests = let

1149 newA newB newC = testSession (T.unpack actionTitle) $ do

1194 newA newB newC = testSession (T.unpack actionTitle) $ do

1150 let originalCode = sourceCode oldA oldB oldC

1195 let originalCode = sourceCode oldA oldB oldC

1151 let expectedCode = sourceCode newA newB newC

1196 let expectedCode = sourceCode newA newB newC

1152− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

1153 _ <- waitForDiagnostics

1198 _ <- waitForDiagnostics

1154 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1155 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

1200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

@@ -1197,7 +1242,7 @@ addSigActionTests = let

1197 def >:: sig = testSession (T.unpack def) $ do

1242 def >:: sig = testSession (T.unpack def) $ do

1198 let originalCode = before def

1243 let originalCode = before def

1199 let expectedCode = after' def sig

1244 let expectedCode = after' def sig

1200− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1201 _ <- waitForDiagnostics

1246 _ <- waitForDiagnostics

1202 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1203 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

@@ -1229,7 +1274,7 @@ addSigLensesTests = let

1229 sigSession withMissing def sig = testSession (T.unpack def) $ do

1274 sigSession withMissing def sig = testSession (T.unpack def) $ do

1230 let originalCode = before withMissing def

1275 let originalCode = before withMissing def

1231 let expectedCode = after' withMissing def sig

1276 let expectedCode = after' withMissing def sig

1232− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1233 [CodeLens {_command = Just c}] <- getCodeLenses doc

1278 [CodeLens {_command = Just c}] <- getCodeLenses doc

1234 executeCommand c

1279 executeCommand c

1235 modifiedCode <- getDocumentEdit doc

1280 modifiedCode <- getDocumentEdit doc

@@ -1251,27 +1296,19 @@ addSigLensesTests = let

1251 ]

1296 ]

1252 ]

1297 ]

1253

1298

1254−findDefinitionAndHoverTests :: TestTree

1255−findDefinitionAndHoverTests = let

1256−

1257− tst (get, check) pos targetRange title = testSession title $ do

1258− doc <- openTestDataDoc sourceFilePath

1259− found <- get doc pos

1260− check found targetRange

1261−

1262− checkDefs :: [Location] -> Session [Expect] -> Session ()

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1263− checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1264

1301

1265− check (ExpectRange expectedRange) = do

1302+ check (ExpectRange expectedRange) = do

1266− assertNDefinitionsFound 1 defs

1303+ assertNDefinitionsFound 1 defs

1267− assertRangeCorrect (head defs) expectedRange

1304+ assertRangeCorrect (head defs) expectedRange

1268− check (ExpectLocation expectedLocation) = do

1305+ check (ExpectLocation expectedLocation) = do

1269− assertNDefinitionsFound 1 defs

1306+ assertNDefinitionsFound 1 defs

1270− liftIO $ head defs @?= expectedLocation

1307+ liftIO $ head defs @?= expectedLocation

1271− check ExpectNoDefinitions = do

1308+ check ExpectNoDefinitions = do

1272− assertNDefinitionsFound 0 defs

1309+ assertNDefinitionsFound 0 defs

1273− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1274− check _ = pure () -- all other expectations not relevant to getDefinition

1311+ check _ = pure () -- all other expectations not relevant to getDefinition

1275

1312

1276 assertNDefinitionsFound :: Int -> [a] -> Session ()

1313 assertNDefinitionsFound :: Int -> [a] -> Session ()

1277 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1279,6 +1316,17 @@ findDefinitionAndHoverTests = let

1279 assertRangeCorrect Location{_range = foundRange} expectedRange =

1316 assertRangeCorrect Location{_range = foundRange} expectedRange =

1280 liftIO $ expectedRange @=? foundRange

1317 liftIO $ expectedRange @=? foundRange

1281

1318

1319+

1320+findDefinitionAndHoverTests :: TestTree

1321+findDefinitionAndHoverTests = let

1322+

1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324+ doc <- openTestDataDoc (dir </> sourceFilePath)

1325+ found <- get doc pos

1326+ check found targetRange

1327+

1328+

1329+

1282 checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1330 checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1283 checkHover hover expectations = traverse_ check =<< expectations where

1331 checkHover hover expectations = traverse_ check =<< expectations where

1284

1332

@@ -1323,7 +1371,8 @@ findDefinitionAndHoverTests = let

1323

1371

1324 mkFindTests tests = testGroup "get"

1372 mkFindTests tests = testGroup "get"

1325 [ testGroup "definition" $ mapMaybe fst tests

1373 [ testGroup "definition" $ mapMaybe fst tests

1326− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

1327

1376

1328 test runDef runHover look expect = testM runDef runHover look (return expect)

1377 test runDef runHover look expect = testM runDef runHover look (return expect)

1329

1378

@@ -1418,8 +1467,17 @@ findDefinitionAndHoverTests = let

1418 broken = Just . (`xfail` "known broken")

1467 broken = Just . (`xfail` "known broken")

1419 no = const Nothing -- don't run this test at all

1468 no = const Nothing -- don't run this test at all

1420

1469

1470+checkFileCompiles :: FilePath -> TestTree

1471+checkFileCompiles fp =

1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do

1473+ void (openTestDataDoc (dir </> fp))

1474+ expectNoMoreDiagnostics 0.5

1475+

1476+

1477+

1421pluginTests :: TestTree

1478pluginTests :: TestTree

1479+pluginTests = (`xfail8101` "known broken (#556)")

1422−pluginTests = testSessionWait "plugins" $ do

1480+ $ testSessionWait "plugins" $ do

1423 let content =

1481 let content =

1424 T.unlines

1482 T.unlines

1425 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1433,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do

1433 , "foo :: Int -> Int -> Int"

1491 , "foo :: Int -> Int -> Int"

1434 , "foo a b = a + c"

1492 , "foo a b = a + c"

1435 ]

1493 ]

1436− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

1437 expectDiagnostics

1495 expectDiagnostics

1438 [ ( "Testing.hs",

1496 [ ( "Testing.hs",

1439 [(DsError, (8, 14), "Variable not in scope: c")]

1497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1460,7 +1518,7 @@ cppTests =

1460 run $ expectError content (2, 1)

1518 run $ expectError content (2, 1)

1461 )

1519 )

1462 , testSessionWait "cpp-ghcide" $ do

1520 , testSessionWait "cpp-ghcide" $ do

1463− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

1464 ["{-# LANGUAGE CPP #-}"

1522 ["{-# LANGUAGE CPP #-}"

1465 ,"main ="

1523 ,"main ="

1466 ,"#ifdef __GHCIDE__"

1524 ,"#ifdef __GHCIDE__"

@@ -1474,7 +1532,7 @@ cppTests =

1474 where

1532 where

1475 expectError :: T.Text -> Cursor -> Session ()

1533 expectError :: T.Text -> Cursor -> Session ()

1476 expectError content cursor = do

1534 expectError content cursor = do

1477− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

1478 expectDiagnostics

1536 expectDiagnostics

1479 [ ( "Testing.hs",

1537 [ ( "Testing.hs",

1480 [(DsError, cursor, "error: unterminated")]

1538 [(DsError, cursor, "error: unterminated")]

@@ -1490,7 +1548,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do

1490 , "module Testing where"

1548 , "module Testing where"

1491 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1492 ]

1550 ]

1493− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

1494 expectDiagnostics

1552 expectDiagnostics

1495 [ ( "Testing.hs",

1553 [ ( "Testing.hs",

1496 [(DsError, (2, 8), "Variable not in scope: z")]

1554 [(DsError, (2, 8), "Variable not in scope: z")]

@@ -1523,8 +1581,8 @@ safeTests =

1523 ,"safeId = trustWorthyId"

1581 ,"safeId = trustWorthyId"

1524 ]

1582 ]

1525

1583

1526− _ <- openDoc' "A.hs" "haskell" sourceA

1584+ _ <- createDoc "A.hs" "haskell" sourceA

1527− _ <- openDoc' "B.hs" "haskell" sourceB

1585+ _ <- createDoc "B.hs" "haskell" sourceB

1528 expectNoMoreDiagnostics 1 ]

1586 expectNoMoreDiagnostics 1 ]

1529

1587

1530thTests :: TestTree

1588thTests :: TestTree

@@ -1552,8 +1610,8 @@ thTests =

1552 "b :: Integer",

1610 "b :: Integer",

1553 "b = $(litE $ IntegerL $ a) + n"

1611 "b = $(litE $ IntegerL $ a) + n"

1554 ]

1612 ]

1555− _ <- openDoc' "A.hs" "haskell" sourceA

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1556− _ <- openDoc' "B.hs" "haskell" sourceB

1614+ _ <- createDoc "B.hs" "haskell" sourceB

1557 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1558 , testSessionWait "newtype-closure" $ do

1616 , testSessionWait "newtype-closure" $ do

1559 let sourceA =

1617 let sourceA =

@@ -1573,8 +1631,8 @@ thTests =

1573 ,"import A"

1631 ,"import A"

1574 ,"b :: Int"

1632 ,"b :: Int"

1575 ,"b = $( a )" ]

1633 ,"b = $( a )" ]

1576− _ <- openDoc' "A.hs" "haskell" sourceA

1634+ _ <- createDoc "A.hs" "haskell" sourceA

1577− _ <- openDoc' "B.hs" "haskell" sourceB

1635+ _ <- createDoc "B.hs" "haskell" sourceB

1578 return ()

1636 return ()

1579 ]

1637 ]

1580

1638

@@ -1583,7 +1641,7 @@ completionTests

1583 = testGroup "completion"

1641 = testGroup "completion"

1584 [ testSessionWait "variable" $ do

1642 [ testSessionWait "variable" $ do

1585 let source = T.unlines ["module A where", "f = hea"]

1643 let source = T.unlines ["module A where", "f = hea"]

1586− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

1587 compls <- getCompletions docId (Position 1 7)

1645 compls <- getCompletions docId (Position 1 7)

1588 liftIO $ map dropDocs compls @?=

1646 liftIO $ map dropDocs compls @?=

1589 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1595,7 +1653,7 @@ completionTests

1595 ]

1653 ]

1596 , testSessionWait "constructor" $ do

1654 , testSessionWait "constructor" $ do

1597 let source = T.unlines ["module A where", "f = Tru"]

1655 let source = T.unlines ["module A where", "f = Tru"]

1598− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

1599 compls <- getCompletions docId (Position 1 7)

1657 compls <- getCompletions docId (Position 1 7)

1600 liftIO $ map dropDocs compls @?=

1658 liftIO $ map dropDocs compls @?=

1601 [ complItem "True" (Just CiConstructor) (Just "Bool")

1659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1607,7 +1665,7 @@ completionTests

1607 ]

1665 ]

1608 , testSessionWait "type" $ do

1666 , testSessionWait "type" $ do

1609 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1610− docId <- openDoc' "A.hs" "haskell" source

1668+ docId <- createDoc "A.hs" "haskell" source

1611 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1612 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1613 compls <- getCompletions docId (Position 2 7)

1671 compls <- getCompletions docId (Position 2 7)

@@ -1624,7 +1682,7 @@ completionTests

1624 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1625 , testSessionWait "qualified" $ do

1683 , testSessionWait "qualified" $ do

1626 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1627− docId <- openDoc' "A.hs" "haskell" source

1685+ docId <- createDoc "A.hs" "haskell" source

1628 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1629 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1630 compls <- getCompletions docId (Position 2 15)

1688 compls <- getCompletions docId (Position 2 15)

@@ -1638,7 +1696,7 @@ completionTests

1638 ]

1696 ]

1639 , testSessionWait "keyword" $ do

1697 , testSessionWait "keyword" $ do

1640 let source = T.unlines ["module A where", "f = newty"]

1698 let source = T.unlines ["module A where", "f = newty"]

1641− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

1642 compls <- getCompletions docId (Position 1 9)

1700 compls <- getCompletions docId (Position 1 9)

1643 liftIO $ compls @?= [keywordItem "newtype"]

1701 liftIO $ compls @?= [keywordItem "newtype"]

1644 , testSessionWait "type context" $ do

1702 , testSessionWait "type context" $ do

@@ -1647,7 +1705,7 @@ completionTests

1647 , "module A () where"

1705 , "module A () where"

1648 , "f = f"

1706 , "f = f"

1649 ]

1707 ]

1650− docId <- openDoc' "A.hs" "haskell" source

1708+ docId <- createDoc "A.hs" "haskell" source

1651 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

1709 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

1652 changeDoc docId

1710 changeDoc docId

1653 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

1711 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

@@ -1715,7 +1773,7 @@ outlineTests = testGroup

1715 "outline"

1773 "outline"

1716 [ testSessionWait "type class" $ do

1774 [ testSessionWait "type class" $ do

1717 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1718− docId <- openDoc' "A.hs" "haskell" source

1776+ docId <- createDoc "A.hs" "haskell" source

1719 symbols <- getDocumentSymbols docId

1777 symbols <- getDocumentSymbols docId

1720 liftIO $ symbols @?= Left

1778 liftIO $ symbols @?= Left

1721 [ moduleSymbol

1779 [ moduleSymbol

@@ -1728,7 +1786,7 @@ outlineTests = testGroup

1728 ]

1786 ]

1729 , testSessionWait "type class instance " $ do

1787 , testSessionWait "type class instance " $ do

1730 let source = T.unlines ["class A a where", "instance A () where"]

1788 let source = T.unlines ["class A a where", "instance A () where"]

1731− docId <- openDoc' "A.hs" "haskell" source

1789+ docId <- createDoc "A.hs" "haskell" source

1732 symbols <- getDocumentSymbols docId

1790 symbols <- getDocumentSymbols docId

1733 liftIO $ symbols @?= Left

1791 liftIO $ symbols @?= Left

1734 [ classSymbol "A a" (R 0 0 0 15) []

1792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1736,7 +1794,7 @@ outlineTests = testGroup

1736 ]

1794 ]

1737 , testSessionWait "type family" $ do

1795 , testSessionWait "type family" $ do

1738 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1739− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

1740 symbols <- getDocumentSymbols docId

1798 symbols <- getDocumentSymbols docId

1741 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1742 , testSessionWait "type family instance " $ do

1800 , testSessionWait "type family instance " $ do

@@ -1745,7 +1803,7 @@ outlineTests = testGroup

1745 , "type family A a"

1803 , "type family A a"

1746 , "type instance A () = ()"

1804 , "type instance A () = ()"

1747 ]

1805 ]

1748− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

1749 symbols <- getDocumentSymbols docId

1807 symbols <- getDocumentSymbols docId

1750 liftIO $ symbols @?= Left

1808 liftIO $ symbols @?= Left

1751 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1753,7 +1811,7 @@ outlineTests = testGroup

1753 ]

1811 ]

1754 , testSessionWait "data family" $ do

1812 , testSessionWait "data family" $ do

1755 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1756− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

1757 symbols <- getDocumentSymbols docId

1815 symbols <- getDocumentSymbols docId

1758 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1759 , testSessionWait "data family instance " $ do

1817 , testSessionWait "data family instance " $ do

@@ -1762,7 +1820,7 @@ outlineTests = testGroup

1762 , "data family A a"

1820 , "data family A a"

1763 , "data instance A () = A ()"

1821 , "data instance A () = A ()"

1764 ]

1822 ]

1765− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

1766 symbols <- getDocumentSymbols docId

1824 symbols <- getDocumentSymbols docId

1767 liftIO $ symbols @?= Left

1825 liftIO $ symbols @?= Left

1768 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1770,36 +1828,36 @@ outlineTests = testGroup

1770 ]

1828 ]

1771 , testSessionWait "constant" $ do

1829 , testSessionWait "constant" $ do

1772 let source = T.unlines ["a = ()"]

1830 let source = T.unlines ["a = ()"]

1773− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

1774 symbols <- getDocumentSymbols docId

1832 symbols <- getDocumentSymbols docId

1775 liftIO $ symbols @?= Left

1833 liftIO $ symbols @?= Left

1776 [docSymbol "a" SkFunction (R 0 0 0 6)]

1834 [docSymbol "a" SkFunction (R 0 0 0 6)]

1777 , testSessionWait "pattern" $ do

1835 , testSessionWait "pattern" $ do

1778 let source = T.unlines ["Just foo = Just 21"]

1836 let source = T.unlines ["Just foo = Just 21"]

1779− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

1780 symbols <- getDocumentSymbols docId

1838 symbols <- getDocumentSymbols docId

1781 liftIO $ symbols @?= Left

1839 liftIO $ symbols @?= Left

1782 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1783 , testSessionWait "pattern with type signature" $ do

1841 , testSessionWait "pattern with type signature" $ do

1784 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1785− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

1786 symbols <- getDocumentSymbols docId

1844 symbols <- getDocumentSymbols docId

1787 liftIO $ symbols @?= Left

1845 liftIO $ symbols @?= Left

1788 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1789 , testSessionWait "function" $ do

1847 , testSessionWait "function" $ do

1790 let source = T.unlines ["a x = ()"]

1848 let source = T.unlines ["a x = ()"]

1791− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

1792 symbols <- getDocumentSymbols docId

1850 symbols <- getDocumentSymbols docId

1793 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1794 , testSessionWait "type synonym" $ do

1852 , testSessionWait "type synonym" $ do

1795 let source = T.unlines ["type A = Bool"]

1853 let source = T.unlines ["type A = Bool"]

1796− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

1797 symbols <- getDocumentSymbols docId

1855 symbols <- getDocumentSymbols docId

1798 liftIO $ symbols @?= Left

1856 liftIO $ symbols @?= Left

1799 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1800 , testSessionWait "datatype" $ do

1858 , testSessionWait "datatype" $ do

1801 let source = T.unlines ["data A = C"]

1859 let source = T.unlines ["data A = C"]

1802− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

1803 symbols <- getDocumentSymbols docId

1861 symbols <- getDocumentSymbols docId

1804 liftIO $ symbols @?= Left

1862 liftIO $ symbols @?= Left

1805 [ docSymbolWithChildren "A"

1863 [ docSymbolWithChildren "A"

@@ -1807,9 +1865,21 @@ outlineTests = testGroup

1807 (R 0 0 0 10)

1865 (R 0 0 0 10)

1808 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1809 ]

1867 ]

1868+ , testSessionWait "record fields" $ do

1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]

1870+ docId <- createDoc "A.hs" "haskell" source

1871+ symbols <- getDocumentSymbols docId

1872+ liftIO $ symbols @=? Left

1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)

1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)

1875+ [ docSymbol "x" SkField (R 1 2 1 3)

1876+ , docSymbol "y" SkField (R 2 4 2 5)

1877+ ]

1878+ ]

1879+ ]

1810 , testSessionWait "import" $ do

1880 , testSessionWait "import" $ do

1811 let source = T.unlines ["import Data.Maybe"]

1881 let source = T.unlines ["import Data.Maybe"]

1812− docId <- openDoc' "A.hs" "haskell" source

1882+ docId <- createDoc "A.hs" "haskell" source

1813 symbols <- getDocumentSymbols docId

1883 symbols <- getDocumentSymbols docId

1814 liftIO $ symbols @?= Left

1884 liftIO $ symbols @?= Left

1815 [docSymbolWithChildren "imports"

1885 [docSymbolWithChildren "imports"

@@ -1820,7 +1890,7 @@ outlineTests = testGroup

1820 ]

1890 ]

1821 , testSessionWait "multiple import" $ do

1891 , testSessionWait "multiple import" $ do

1822 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1823− docId <- openDoc' "A.hs" "haskell" source

1893+ docId <- createDoc "A.hs" "haskell" source

1824 symbols <- getDocumentSymbols docId

1894 symbols <- getDocumentSymbols docId

1825 liftIO $ symbols @?= Left

1895 liftIO $ symbols @?= Left

1826 [docSymbolWithChildren "imports"

1896 [docSymbolWithChildren "imports"

@@ -1835,7 +1905,7 @@ outlineTests = testGroup

1835 [ "{-# language ForeignFunctionInterface #-}"

1905 [ "{-# language ForeignFunctionInterface #-}"

1836 , "foreign import ccall \"a\" a :: Int"

1906 , "foreign import ccall \"a\" a :: Int"

1837 ]

1907 ]

1838− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

1839 symbols <- getDocumentSymbols docId

1909 symbols <- getDocumentSymbols docId

1840 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1841 , testSessionWait "foreign export" $ do

1911 , testSessionWait "foreign export" $ do

@@ -1843,7 +1913,7 @@ outlineTests = testGroup

1843 [ "{-# language ForeignFunctionInterface #-}"

1913 [ "{-# language ForeignFunctionInterface #-}"

1844 , "foreign export ccall odd :: Int -> Bool"

1914 , "foreign export ccall odd :: Int -> Bool"

1845 ]

1915 ]

1846− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

1847 symbols <- getDocumentSymbols docId

1917 symbols <- getDocumentSymbols docId

1848 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1849 ]

1919 ]

@@ -1856,6 +1926,8 @@ outlineTests = testGroup

1856 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1857 docSymbolWithChildren name kind loc cc =

1927 docSymbolWithChildren name kind loc cc =

1858 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1928 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1929+ docSymbolWithChildren' name kind loc selectionLoc cc =

1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)

1859 moduleSymbol name loc cc = DocumentSymbol name

1931 moduleSymbol name loc cc = DocumentSymbol name

1860 Nothing

1932 Nothing

1861 SkFile

1933 SkFile

@@ -1877,6 +1949,13 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

1877xfail :: TestTree -> String -> TestTree

1949xfail :: TestTree -> String -> TestTree

1878xfail = flip expectFailBecause

1950xfail = flip expectFailBecause

1879

1951

1952+xfail8101 :: TestTree -> String -> TestTree

1953+#if MIN_GHC_API_VERSION(8,10,0)

1954+xfail8101 = flip expectFailBecause

1955+#else

1956+xfail8101 t _ = t

1957+#endif

1958+

1880data Expect

1959data Expect

1881 = ExpectRange Range -- Both gotoDef and hover should report this range

1960 = ExpectRange Range -- Both gotoDef and hover should report this range

1882 | ExpectLocation Location

1961 | ExpectLocation Location

@@ -1954,6 +2033,7 @@ cradleTests :: TestTree

1954cradleTests = testGroup "cradle"

2033cradleTests = testGroup "cradle"

1955 [testGroup "dependencies" [sessionDepsArePickedUp]

2034 [testGroup "dependencies" [sessionDepsArePickedUp]

1956 ,testGroup "loading" [loadCradleOnlyonce]

2035 ,testGroup "loading" [loadCradleOnlyonce]

2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

1957 ]

2037 ]

1958

2038

1959loadCradleOnlyonce :: TestTree

2039loadCradleOnlyonce :: TestTree

@@ -1968,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"

1968 test dir

2048 test dir

1969 implicit dir = test dir

2049 implicit dir = test dir

1970 test _dir = do

2050 test _dir = do

1971− doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"

2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

1972 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1973 liftIO $ length msgs @?= 1

2053 liftIO $ length msgs @?= 1

1974 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

2054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

1975 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1976 liftIO $ length msgs @?= 0

2056 liftIO $ length msgs @?= 0

1977− _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

1978 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

1979 liftIO $ length msgs @?= 0

2059 liftIO $ length msgs @?= 0

1980

2060

1981

2061

2062+dependentFileTest :: TestTree

2063+dependentFileTest = testGroup "addDependentFile"

2064+ [testGroup "file-changed" [testSession' "test" test]

2065+ ]

2066+ where

2067+ test dir = do

2068+ -- If the file contains B then no type error

2069+ -- otherwise type error

2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"

2071+ let fooContent = T.unlines

2072+ [ "{-# LANGUAGE TemplateHaskell #-}"

2073+ , "module Foo where"

2074+ , "import Language.Haskell.TH.Syntax"

2075+ , "foo :: Int"

2076+ , "foo = 1 + $(do"

2077+ , " qAddDependentFile \"dep-file.txt\""

2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"

2079+ , " if f == \"B\" then [| 1 |] else lift f)"

2080+ ]

2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]

2082+ _ <-createDoc "Foo.hs" "haskell" fooContent

2083+ doc <- createDoc "Baz.hs" "haskell" bazContent

2084+ expectDiagnostics

2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]

2086+ -- Now modify the dependent file

2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"

2088+ let change = TextDocumentContentChangeEvent

2089+ { _range = Just (Range (Position 2 0) (Position 2 6))

2090+ , _rangeLength = Nothing

2091+ , _text = "f = ()"

2092+ }

2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well

2094+ changeDoc doc [change]

2095+ expectDiagnostics [("Foo.hs", [])]

2096+

2097+

1982cradleLoadedMessage :: Session FromServerMessage

2098cradleLoadedMessage :: Session FromServerMessage

1983cradleLoadedMessage = satisfy $ \case

2099cradleLoadedMessage = satisfy $ \case

1984 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

2100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

@@ -1987,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case

1987cradleLoadedMethod :: T.Text

2103cradleLoadedMethod :: T.Text

1988cradleLoadedMethod = "ghcide/cradle/loaded"

2104cradleLoadedMethod = "ghcide/cradle/loaded"

1989

2105

2106+-- Stack sets this which trips up cabal in the multi-component tests.

2107+-- However, our plugin tests rely on those env vars so we unset it locally.

2108+withoutStackEnv :: IO a -> IO a

2109+withoutStackEnv s =

2110+ bracket

2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)

2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))

2113+ (const s)

2114+ where vars =

2115+ [ "GHC_PACKAGE_PATH"

2116+ , "GHC_ENVIRONMENT"

2117+ , "HASKELL_DIST_DIR"

2118+ , "HASKELL_PACKAGE_SANDBOX"

2119+ , "HASKELL_PACKAGE_SANDBOXES"

2120+ ]

2121+ restore var Nothing = unsetEnv var

2122+ restore var (Just val) = setEnv var val True

2123+

2124+simpleMultiTest :: TestTree

2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2126+ let aPath = dir </> "a/A.hs"

2127+ bPath = dir </> "b/B.hs"

2128+ aSource <- liftIO $ readFileUtf8 aPath

2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2130+ expectNoMoreDiagnostics 0.5

2131+ bSource <- liftIO $ readFileUtf8 bPath

2132+ bdoc <- createDoc bPath "haskell" bSource

2133+ expectNoMoreDiagnostics 0.5

2134+ locs <- getDefinitions bdoc (Position 2 7)

2135+ let fooL = mkL adoc 2 0 2 3

2136+ checkDefs locs (pure [fooL])

2137+ expectNoMoreDiagnostics 0.5

2138+

2139+-- Like simpleMultiTest but open the files in the other order

2140+simpleMultiTest2 :: TestTree

2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2142+ let aPath = dir </> "a/A.hs"

2143+ bPath = dir </> "b/B.hs"

2144+ bSource <- liftIO $ readFileUtf8 bPath

2145+ bdoc <- createDoc bPath "haskell" bSource

2146+ expectNoMoreDiagnostics 5

2147+ aSource <- liftIO $ readFileUtf8 aPath

2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2149+ -- Need to have some delay here or the test fails

2150+ expectNoMoreDiagnostics 5

2151+ locs <- getDefinitions bdoc (Position 2 7)

2152+ let fooL = mkL adoc 2 0 2 3

2153+ checkDefs locs (pure [fooL])

2154+ expectNoMoreDiagnostics 0.5

2155+

1990sessionDepsArePickedUp :: TestTree

2156sessionDepsArePickedUp :: TestTree

1991sessionDepsArePickedUp = testSession'

2157sessionDepsArePickedUp = testSession'

1992 "session-deps-are-picked-up"

2158 "session-deps-are-picked-up"

@@ -1996,7 +2162,7 @@ sessionDepsArePickedUp = testSession'

1996 (dir </> "hie.yaml")

2162 (dir </> "hie.yaml")

1997 "cradle: {direct: {arguments: []}}"

2163 "cradle: {direct: {arguments: []}}"

1998 -- Open without OverloadedStrings and expect an error.

2164 -- Open without OverloadedStrings and expect an error.

1999− doc <- openDoc' "Foo.hs" "haskell" fooContent

2165+ doc <- createDoc "Foo.hs" "haskell" fooContent

2000 expectDiagnostics

2166 expectDiagnostics

2001 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2002 -- Update hie.yaml to enable OverloadedStrings.

2168 -- Update hie.yaml to enable OverloadedStrings.

@@ -2031,6 +2197,9 @@ sessionDepsArePickedUp = testSession'

2031testSession :: String -> Session () -> TestTree

2197testSession :: String -> Session () -> TestTree

2032testSession name = testCase name . run

2198testSession name = testCase name . run

2033

2199

2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202+

2034testSession' :: String -> (FilePath -> Session ()) -> TestTree

2203testSession' :: String -> (FilePath -> Session ()) -> TestTree

2035testSession' name = testCase name . run'

2204testSession' name = testCase name . run'

2036

2205

@@ -2065,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)

2065run :: Session a -> IO a

2234run :: Session a -> IO a

2066run s = withTempDir $ \dir -> runInDir dir s

2235run s = withTempDir $ \dir -> runInDir dir s

2067

2236

2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a

2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do

2239+ copyTestDataFiles dir prefix

2240+ runInDir dir (s dir)

2241+

2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()

2243+copyTestDataFiles dir prefix = do

2244+ -- Copy all the test data files to the temporary workspace

2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]

2246+ for_ testDataFiles $ \f -> do

2247+ createDirectoryIfMissing True $ dir </> takeDirectory f

2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)

2249+

2068run' :: (FilePath -> Session a) -> IO a

2250run' :: (FilePath -> Session a) -> IO a

2069run' s = withTempDir $ \dir -> runInDir dir (s dir)

2251run' s = withTempDir $ \dir -> runInDir dir (s dir)

2070

2252

@@ -2076,11 +2258,6 @@ runInDir dir s = do

2076 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2077 createDirectoryIfMissing True $ dir ++ "/Data"

2259 createDirectoryIfMissing True $ dir ++ "/Data"

2078

2260

2079− -- Copy all the test data files to the temporary workspace

2080− testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]

2081− for_ testDataFiles $ \f -> do

2082− createDirectoryIfMissing True $ dir </> takeDirectory f

2083− copyFile ("test/data" </> f) (dir </> f)

2084

2261

2085 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

2262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

2086 -- HIE calls getXgdDirectory which assumes that HOME is set.

2263 -- HIE calls getXgdDirectory which assumes that HOME is set.

@@ -2099,7 +2276,7 @@ runInDir dir s = do

2099openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2100openTestDataDoc path = do

2277openTestDataDoc path = do

2101 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2102− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

2103

2280

2104findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2105findCodeActions doc range expectedTitles = do

2282findCodeActions doc range expectedTitles = do

@@ -2140,20 +2317,6 @@ unitTests = do

2140 uriToFilePath' uri @?= Just ""

2317 uriToFilePath' uri @?= Just ""

2141 ]

2318 ]

2142

2319

2143−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

2144−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2145−openDoc' fp name contents = do

2146− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

2147− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

2148− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

2149− return res

2150−

2151−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

2152−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2153−-- At the moment this is just LSPTest.openDoc' but it may change in the future

2154−-- when/if lsp-test implements WatchedFiles

2155−openDoc'' = LSPTest.openDoc'

2156−

2157positionMappingTests :: TestTree

2320positionMappingTests :: TestTree

2158positionMappingTests =

2321positionMappingTests =

2159 testGroup "position mapping"

2322 testGroup "position mapping"

@@ -2323,11 +2486,11 @@ nthLine i r

2323 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

2486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

2324 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

2487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

2325

2488

2326−getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]

2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2327−getWatchedFilesSubscriptionsUntilProgressEnd = do

2490+getWatchedFilesSubscriptionsUntil = do

2328− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

2329 return

2492 return

2330 [ args

2493 [ args

2331− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs

2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs

2332 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

2495 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

2333 ]

2496 ]

test/src/Development/IDE/Test.hs+4−21

@@ -16,10 +16,9 @@ import Control.Applicative.Combinators

16import Control.Lens hiding (List)

17import Control.Monad

18import Control.Monad.IO.Class

19−import Data.Foldable

20import qualified Data.Map.Strict as Map

19import qualified Data.Map.Strict as Map

21import qualified Data.Text as T

20import qualified Data.Text as T

22−import Language.Haskell.LSP.Test hiding (message, openDoc')

21+import Language.Haskell.LSP.Test hiding (message)

23import qualified Language.Haskell.LSP.Test as LspTest

22import qualified Language.Haskell.LSP.Test as LspTest

24import Language.Haskell.LSP.Types

23import Language.Haskell.LSP.Types

25import Language.Haskell.LSP.Types.Lens as Lsp

24import Language.Haskell.LSP.Types.Lens as Lsp

@@ -74,17 +73,14 @@ expectNoMoreDiagnostics timeout = do

74 ignoreOthers = void anyMessage >> handleMessages

73 ignoreOthers = void anyMessage >> handleMessages

76expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

75expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

77−expectDiagnostics = expectDiagnostics' diagnostic

76+expectDiagnostics expected = do

78−

79−expectDiagnostics' :: Session PublishDiagnosticsNotification -> [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

80−expectDiagnostics' messageParser expected = do

81 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

77 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

82 go expected'

78 go expected'

83 where

79 where

84 go m

80 go m

85 | Map.null m = pure ()

81 | Map.null m = pure ()

86 | otherwise = do

82 | otherwise = do

87− diagsNot <- skipManyTill anyMessage messageParser

83+ diagsNot <- skipManyTill anyMessage diagnostic

88 let fileUri = diagsNot ^. params . uri

84 let fileUri = diagsNot ^. params . uri

89 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

90 Nothing -> do

86 Nothing -> do

@@ -103,21 +99,8 @@ expectDiagnostics' messageParser expected = do

103 " but got " <> show actual

99 " but got " <> show actual

104 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

105

101

106−-- | Matches all diagnostic messages expect those from interface loading files

107diagnostic :: Session PublishDiagnosticsNotification

102diagnostic :: Session PublishDiagnosticsNotification

108−diagnostic = do

109− m <- LspTest.message

103+diagnostic = LspTest.message

110− let PublishDiagnosticsParams uri diags = _params (m :: PublishDiagnosticsNotification)

111− let diags' = filter (\d -> _source (d:: Diagnostic) /= Just "interface file loading") (toList diags)

112− -- interface loading warnings get sent on a first message,

113− -- followed up by a second message including all other warnings.

114− -- unless the debouncer merges them.

115− -- This can lead to a test matching on the first message and missing

116− -- the interesting warnings.

117− -- Therefore we do not match messages containing only interface loading warnings,

118− -- but, importantly, do match messages containing no warnings.

119− guard (null diags || not (null diags'))

120− return $ (m :: PublishDiagnosticsNotification){_params = PublishDiagnosticsParams uri (List diags')}

121

104

122standardizeQuotes :: T.Text -> T.Text

105standardizeQuotes :: T.Text -> T.Text

123standardizeQuotes msg = let

106standardizeQuotes msg = let