master..3973238 · ghcide

git.iko.soy/ghcide

59 files changed+871−4109

unifiedsplit

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

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

55 vmImage: 'ubuntu-latest'

66 strategy:

77 matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

108 stack_88:

119 STACK_YAML: "stack88.yaml"

1210 stack_86:

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

3230 ./fmt.sh

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

3432 - bash: |

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

36− sudo apt-get update

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

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

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

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

4036 fi

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

4339 displayName: 'stack setup'

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

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

46− - bash: |

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

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

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

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

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

5145 - bash: |

.azure/windows-stack.yml−3

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

55 vmImage: 'windows-2019'

66 strategy:

77 matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

108 stack_88:

119 STACK_YAML: "stack88.yaml"

1210 stack_86:

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

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

4745 stack install happy --stack-yaml $STACK_YAML

4846 stack install alex --stack-yaml $STACK_YAML

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

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

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

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

.ghcinew file+25

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

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

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,5 +6,3 @@ cabal.project.local

66*.lock

77/.tasty-rerun-log

88.vscode

9−/.hlint-*

10−bench/example

.hlint.yaml+1−5

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

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

7474

7575 # Shady extensions

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

7677 - name: CPP

7778 within:

78− - Development.IDE.Compat

7979 - Development.IDE.Core.FileStore

8080 - Development.IDE.Core.Compile

81− - Development.IDE.Core.Rules

8281 - Development.IDE.GHC.Compat

83− - Development.IDE.GHC.Orphans

8482 - Development.IDE.GHC.Util

8583 - Development.IDE.Import.FindImports

86− - Development.IDE.LSP.Outline

8784 - Development.IDE.Spans.Calculate

8885 - Development.IDE.Spans.Documentation

8986 - Development.IDE.Spans.Common

9087 - Development.IDE.Plugin.CodeAction

91− - Development.IDE.Plugin.Completions

9288 - Development.IDE.Plugin.Completions.Logic

9389 - Main

9490

CHANGELOG.md−20

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

11### unreleased

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

4−

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−

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

244

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

README.md+3−48

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

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

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

2727

28−

29−## Limitations to Multi-Component support

30−

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

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

33−some limitations to this.

34−

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

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

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

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

39−from each component.

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

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

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

43−a simple reproduction of the bug.

44−

4528## Using it

4629

4730### Install `ghcide`

4831

4932#### With Nix

5033

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

52−

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

54− ```

55− nix-env -iA haskellPackages.ghcide

56− ```

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

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

59−

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

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

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

6235

6336#### With Cabal or Stack

6437

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

234207```

235208

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

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

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

242211

243212### SpaceVim

244213

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

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

284253using `stack install ghcide` within a project.

285254

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−

300255## Hacking on ghcide

301256

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

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

325280

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

327282

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

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

329284

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

331286

bench/Main.hsdeleted−287

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

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE ImplicitParams #-}

4−

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

6−

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

8−

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+63−522

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

88module Main(main) where

10−import Linker (initDynLinker)

11−import Data.IORef

12−import NameCache

13−import Packages

14−import Module

1510import Arguments

16−import Control.Concurrent.Async

11+import Data.Maybe

12+import Data.List.Extra

13+import System.FilePath

1714import Control.Concurrent.Extra

1815import Control.Exception

1916import Control.Monad.Extra

2017import Control.Monad.IO.Class

2118import Data.Default

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

19+import System.Time.Extra

3020import Development.IDE.Core.Debouncer

3121import Development.IDE.Core.FileStore

3222import Development.IDE.Core.OfInterest

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

4333import Development.IDE.Plugin

4434import Development.IDE.Plugin.Completions as Completions

4535import Development.IDE.Plugin.CodeAction as CodeAction

36+import qualified Data.Text as T

37+import qualified Data.Text.IO as T

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

4739import Language.Haskell.LSP.Messages

48−import Language.Haskell.LSP.Types

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

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

41+import Data.Version

5042import Development.IDE.LSP.LanguageServer

5143import qualified System.Directory.Extra as IO

5244import System.Environment

5345import System.IO

5446import System.Exit

55−import System.FilePath

56−import System.Directory

57−import System.Time.Extra

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

5947import Paths_ghcide

6048import Development.GitRev

61−import Development.Shake (Action, action)

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

6250import qualified Data.HashSet as HashSet

63−import qualified Data.HashMap.Strict as HM

6451import 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−

75−import HIE.Bios.Cradle

76−import HIE.Bios.Types

77−

78−import Utils

52+import HIE.Bios

53+import Rules

54+import RuleTypes

7955

8056ghcideVersion :: IO String

8157ghcideVersion = do

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

10581 whenJust argsCwd IO.setCurrentDirectory

10682

10783 dir <- IO.getCurrentDirectory

108− command <- makeLspCommandId "typesignature.add"

10984

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

11186 onInitialConfiguration = const $ Right ()

11287 onConfigurationChange = const $ Right ()

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

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

11489 , LSP.completionTriggerCharacters = Just "."

11590 }

11691

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

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

12297 t <- t

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

124− let options = (defaultIdeOptions $ loadSessionShake dir)

99+ let options = (defaultIdeOptions $ loadSession dir)

125100 { optReportProgress = clientSupportsProgress caps

126101 , optShakeProfiling = argsShakeProfiling

127102 , optTesting = argsTesting

128103 , optThreads = argsThreads

104+ , optInterfaceLoadingDiagnostics = argsTesting

129105 }

130106 debouncer <- newAsyncDebouncer

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

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

132108 getLspId event (logger minBound) debouncer options vfs

133109 else do

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

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

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

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

140116

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

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

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

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

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

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

146122

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

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

148124 cradles <- mapM findCradle files

149125 let ucradles = nubOrd cradles

150126 let n = length ucradles

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

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

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"

153138 vfs <- makeVFSHandle

154− debouncer <- newAsyncDebouncer

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

156−

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

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

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

149+

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

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

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

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

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

161154 when (failed /= []) $

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

163156

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

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

166− return ()

159+

160+ unless (null failed) exitFailure

161+

162+cradleRules :: Rules ()

163+cradleRules = do

164+ loadGhcSession

165+ cradleToSession

167166

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

169168expandFiles = concatMapM $ \x -> do

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

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

191190showEvent lock e = withLock lock $ print e

192191

193−

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

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

196−cradleToSessionOpts cradle file = do

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

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

199− case cradleRes of

200− CradleSuccess r -> pure (Right r)

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

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

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

204− CradleNone -> return (Left [])

205−

206−emptyHscEnv :: IO HscEnv

207−emptyHscEnv = do

208− libdir <- getLibdir

209− env <- runGhc (Just libdir) getSession

210− initDynLinker env

211− pure env

212−

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

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

215−-- directories

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

217−-- to canonicalise it.

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

219−targetToFile is (TargetModule mod) = do

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

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

222− mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223−targetToFile _ (TargetFile f _) = do

224− f' <- canonicalizePath f

225− return [toNormalizedFilePath' f']

226−

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

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

229−

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

231−loadSessionShake fp = do

232− se <- getShakeExtras

233− IdeOptions{optTesting} <- getIdeOptions

234− res <- liftIO $ loadSession optTesting se fp

235− return (fmap liftIO res)

236−

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

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

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

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

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

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

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

244− -- Mapping from a Filepath to HscEnv

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

246−

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

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

249− res <- findCradle v

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

251− -- try and normalise that

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

253− res' <- traverse IO.makeAbsolute res

254− return $ normalise <$> res'

255−

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

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

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

259− -- which contains the union.

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

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

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

263− -- Parse DynFlags for the newly discovered component

264− hscEnv <- emptyHscEnv

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

266− setOptions opts (hsc_dflags hscEnv)

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

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

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

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

271− -- (unitId, DynFlag, Targets)

272− modifyVar hscEnvs $ \m -> do

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

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

275− let oldDeps = Map.lookup hieYaml m

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

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

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

279− -- information.

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

281− : maybe [] snd oldDeps

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

283− inplace = map rawComponentUnitId new_deps

284−

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

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

287− -- components in this HscEnv

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

289− let prefix = show rawComponentUnitId

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

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

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

293− -- contain any packages which are also loaded

294− -- into the same component.

295− pure $ ComponentInfo rawComponentUnitId

296− processed_df

297− uids

298− rawComponentTargets

299− rawComponentFP

300− rawComponentCOptions

301− rawComponentDependencyInfo

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

303− -- scratch again (for now)

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

305− -- that I do not fully understand

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

307− hscEnv <- case oldDeps of

308− Nothing -> emptyHscEnv

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

310− newHscEnv <-

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

312− evalGhcEnv hscEnv $ do

313− _ <- setSessionDynFlags df

314− getSession

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

316− -- HscEnv

317− -- Returns

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

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

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

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

322− -- existing packages

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

324−

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

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

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

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

329− -- resolve imports. (especially PackageImports)

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

331−

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

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

334−

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

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

337− let new_cache = newComponentCache logger hscEnv uids

338− (cs, res) <- new_cache new

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

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

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

342− modifyVar_ fileToFlags $ \var -> do

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

344−

345− return (fst res)

346−

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

348− consultCradle hieYaml cfp = do

349− when optTesting $ eventer $ notifyCradleLoaded cfp

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

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

352− eopts <- cradleToSessionOpts cradle cfp

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

354− case eopts of

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

356− -- into and HscEnv.

357− Right opts -> do

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

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

360− Left err -> do

361− dep_info <- getDependencyInfo (maybeToList hieYaml)

362− let ncfp = toNormalizedFilePath' cfp

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

364− modifyVar_ fileToFlags $ \var -> do

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

366− return res

367−

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

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

370− sessionOpts (hieYaml, file) = do

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

372− cfp <- canonicalizePath file

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

374− Just (opts, old_di) -> do

375− deps_ok <- checkDependencyInfo old_di

376− if not deps_ok

377− then do

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

379− -- again.

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

381− -- Keep the same name cache

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

383− consultCradle hieYaml cfp

384− else return opts

385− Nothing -> consultCradle hieYaml cfp

386−

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

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

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

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

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

392− -- before attempting to do so.

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

394− getOptions file = do

395− hieYaml <- cradleLoc file

396− sessionOpts (hieYaml, file)

397− return $ \file -> do

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

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

400− void $ wait as

401− as <- async $ getOptions file

402− return (as, wait as)

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

193+loadSession dir = liftIO $ do

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

195+ res <- findCradle v

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

197+ -- try and normalise that

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

199+ res' <- traverse IO.makeAbsolute res

200+ return $ normalise <$> res'

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

202+ session file = do

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

204+ let cradle = toNormalizedFilePath' $ fromMaybe dir file

205+ use_ LoadCradle cradle

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

403207

404208

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−

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

593210--

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

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

605222 res <- onceFork $ op k

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

607224 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.hsnew file+33

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

1+{-# LANGUAGE TypeFamilies #-}

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

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.hsnew file+138

@@ -0,0 +1,138 @@

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.hsnew file+62

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

1+module Util (setupDynFlags, getLibdir) where

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.hsdeleted−9

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

1−module Utils (getLibdir) where

2−

3−import qualified GHC.Paths

4−import System.Environment

5−import Data.Maybe

6−

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

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

22build-type: Simple

33category: Development

44name: ghcide

5−version: 0.2.0

5+version: 0.1.0

66license: Apache-2.0

77license-file: LICENSE

88author: Digital Asset

99maintainer: Digital Asset

10−copyright: Digital Asset 2018-2020

10+copyright: Digital Asset 2018-2019

1111synopsis: The core of an IDE

1212description:

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

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

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

1616tested-with: GHC==8.6.5

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

18− test/data/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

18+ test/data/GotoHover.hs

2519

2620source-repository head

2721 type: git

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

5044 filepath,

5145 haddock-library >= 1.8,

5246 hashable,

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

54− haskell-lsp == 0.22.*,

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

48+ haskell-lsp == 0.21.*,

5549 mtl,

5650 network-uri,

5751 prettyprinter-ansi-terminal,

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

8074 ghc-boot-th,

8175 ghc-boot,

8276 ghc >= 8.4

83− if os(windows)

84− build-depends:

85− Win32

86− else

77+ if !os(windows)

8778 build-depends:

8879 unix

8980 c-sources:

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

109100 include-dirs:

110101 include

111102 exposed-modules:

112− Development.IDE.Compat

113103 Development.IDE.Core.Debouncer

114104 Development.IDE.Core.FileStore

115105 Development.IDE.Core.IdeConfiguration

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

143133 Development.IDE.GHC.CPP

144134 Development.IDE.GHC.Orphans

145135 Development.IDE.GHC.Warnings

146− Development.IDE.GHC.WithDynFlags

147136 Development.IDE.Import.FindImports

148137 Development.IDE.LSP.Notifications

149138 Development.IDE.Spans.AtPoint

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

155144 Development.IDE.Plugin.CodeAction.RuleTypes

156145 Development.IDE.Plugin.Completions.Logic

157146 Development.IDE.Plugin.Completions.Types

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

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

164148 other-modules:

165149 Development.IDE.GHC.HieAst

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

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

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

191175 main-is: Main.hs

192176 build-depends:

193− time,

194− async,

195177 hslogger,

196178 aeson,

197179 base == 4.*,

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

205187 directory,

206188 extra,

207189 filepath,

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

190+ ghc-check >= 0.1.0.3,

209191 ghc-paths,

210192 ghc,

211193 gitrev,

212194 hashable,

213195 haskell-lsp,

214196 haskell-lsp-types,

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

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

216198 ghcide,

217199 optparse-applicative,

218200 shake,

219201 text,

220202 unordered-containers

221203 other-modules:

222− Utils

223204 Arguments

224205 Paths_ghcide

206+ Rules

207+ RuleTypes

208+ Util

225209

226210 default-extensions:

227211 BangPatterns

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

269253 haskell-lsp-types,

270254 network-uri,

271255 lens,

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

256+ lsp-test >= 0.8,

273257 parser-combinators,

274258 QuickCheck,

275259 quickcheck-instances,

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

302286 TupleSections

303287 TypeApplications

304288 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+1−12

@@ -1,12 +1 @@

1−cradle:

2− cabal:

3− - path: "./src"

4− component: "ghcide:lib:ghcide"

5− - path: "./exe"

6− component: "ghcide:exe:ghcide"

7− - path: "./test"

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

9− - path: "./bench"

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

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

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

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

src-ghc810/Development/IDE/GHC/HieAst.hsdeleted−1928

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

1−

2−

3−{-

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

5−

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/Compat.hsdeleted−19

@@ -1,19 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Development.IDE.Compat

3− (

4− getProcessID

5− ) where

6−

7−#ifdef mingw32_HOST_OS

8−

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+14−77

@@ -19,7 +19,6 @@ module Development.IDE.Core.Compile

1919 , generateByteCode

2020 , generateAndWriteHieFile

2121 , generateAndWriteHiFile

22− , getModSummaryFromImports

2322 , loadHieFile

2423 , loadInterface

2524 , loadDepModule

@@ -71,34 +70,30 @@ import Control.Exception.Safe

7170import Control.Monad.Extra

7271import Control.Monad.Except

7372import Control.Monad.Trans.Except

74−import Data.Bifunctor (first, second)

7573import qualified Data.Text as T

7674import Data.IORef

7775import Data.List.Extra

7876import Data.Maybe

77+import Data.Tuple.Extra

7978import qualified Data.Map.Strict as Map

8079import System.FilePath

8180import System.Directory

8281import System.IO.Extra

8382import Data.Either.Extra (maybeToEither)

84−import Control.DeepSeq (rnf)

85−import Control.Exception (evaluate)

86−import Exception (ExceptionMonad)

8783

8884

8985-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

9086parseModule

9187 :: IdeOptions

9288 -> HscEnv

93− -> [PackageName]

9489 -> FilePath

9590 -> Maybe SB.StringBuffer

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

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

92+parseModule IdeOptions{..} env filename mbContents =

9893 fmap (either (, Nothing) id) $

9994 evalGhcEnv env $ runExceptT $ do

10095 (contents, dflags) <- preprocessor filename mbContents

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

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

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

10398

10499

@@ -120,7 +115,7 @@ typecheckModule :: IdeDefer

120115 -> ParsedModule

121116 -> IO (IdeResult (HscEnv, TcModuleResult))

122117typecheckModule (IdeDefer defer) hsc depsIn pm = do

123− fmap (either (, Nothing) (second Just . sequence) . sequence) $

118+ fmap (either (, Nothing) (second Just) . fmap sequence . sequence) $

124119 runGhcEnv hsc $

125120 catchSrcErrors "typecheck" $ do

126121 -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

@@ -255,7 +250,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

255250 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

256251hideDiag _originalFlags t = t

257252

258−addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags

253+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

259254addRelativeImport fp modu dflags = dflags

260255 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

261256

@@ -412,14 +407,16 @@ getImportsParsed dflags (L loc parsed) = do

412407 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

413408 ])

414409

410+

415411-- | Produce a module summary from a StringBuffer.

416412getModSummaryFromBuffer

417413 :: GhcMonad m

418414 => FilePath

415+ -> SB.StringBuffer

419416 -> DynFlags

420417 -> GHC.ParsedSource

421418 -> ExceptT [FileDiagnostic] m ModSummary

422−getModSummaryFromBuffer fp dflags parsed = do

419+getModSummaryFromBuffer fp contents dflags parsed = do

423420 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

424421

425422 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

@@ -435,7 +432,7 @@ getModSummaryFromBuffer fp dflags parsed = do

435432 , ms_textual_imps = [imp | (False, imp) <- imports]

436433 , ms_hspp_file = fp

437434 , ms_hspp_opts = dflags

438− , ms_hspp_buf = Nothing

435+ , ms_hspp_buf = Just contents

439436

440437 -- defaults:

441438 , ms_hsc_src = sourceType

@@ -450,61 +447,17 @@ getModSummaryFromBuffer fp dflags parsed = do

450447 where

451448 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

452449

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−

497−-- | Given a buffer, flags, and file path, produce a

450+

451+-- | Given a buffer, flags, file path and module summary, produce a

498452-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

499453parseFileContents

500454 :: GhcMonad m

501455 => (GHC.ParsedSource -> IdePreprocessedSource)

502456 -> DynFlags -- ^ flags to use

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

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

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

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

507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

460+parseFileContents customPreprocessor dflags filename contents = do

508461 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

510463#if MIN_GHC_API_VERSION(8,10,0)

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

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

537490 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539− let parsed' = removePackageImports comp_pkgs parsed

540492 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

541− ms <- getModSummaryFromBuffer filename dflags parsed'

493+ ms <- getModSummaryFromBuffer filename contents dflags parsed

542494 let pm =

543495 ParsedModule {

544496 pm_mod_summary = ms

545− , pm_parsed_source = parsed'

497+ , pm_parsed_source = parsed

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

547499 , pm_annotations = hpm_annotations

548500 }

549501 warnings = diagFromErrMsgs "parser" dflags warns

550502 pure (warnings ++ preproc_warnings, pm)

551503

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−

567504loadHieFile :: FilePath -> IO GHC.HieFile

568505loadHieFile f = do

569506 u <- mkSplitUniqSupply 'a'

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

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

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

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

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

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

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

99− case () of

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

101− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

102− , Just True <- _dynamicRegistration

103− -> fileExistsRulesFast getLspId vfs

104− | otherwise -> do

105− logger <- logger <$> getShakeExtrasRules

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

107− fileExistsRulesSlow vfs

94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs

95+ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

96+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

97+ , Just True <- _dynamicRegistration

98+ = fileExistsRulesFast getLspId vfs

99+ | otherwise = do

100+ logger <- logger <$> getShakeExtrasRules

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

102+ fileExistsRulesSlow vfs

108103

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

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

111−fileExistsRulesFast getLspId vfs =

106+fileExistsRulesFast getLspId vfs = do

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

112108 defineEarlyCutoff $ \GetFileExists file -> do

113109 isWf <- isWorkspaceFile file

114110 if isWf

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

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

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

33module Development.IDE.Core.PositionMapping

44 ( PositionMapping(..)

5− , fromCurrentPosition

6− , toCurrentPosition

7− , PositionDelta(..)

8− , addDelta

9− , mkDelta

105 , toCurrentRange

116 , fromCurrentRange

127 , applyChange

13− , zeroMapping

8+ , idMapping

149 -- toCurrent and fromCurrent are mainly exposed for testing

1510 , toCurrent

1611 , fromCurrent

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

1914import Control.Monad

2015import qualified Data.Text as T

2116import Language.Haskell.LSP.Types

22−import Data.List

2317

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

25−data PositionDelta = PositionDelta

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

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

18+data PositionMapping = PositionMapping

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

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

2821 }

2922

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−

4123toCurrentRange :: PositionMapping -> Range -> Maybe Range

4224toCurrentRange mapping (Range a b) =

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

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

4628fromCurrentRange mapping (Range a b) =

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

4830

49−zeroMapping :: PositionMapping

50−zeroMapping = PositionMapping idDelta

51−

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

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

54−composeDelta :: PositionDelta

55− -> PositionDelta

56− -> PositionDelta

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

58− PositionDelta (to1 <=< to2)

59− (from1 >=> from2)

60−

61−idDelta :: PositionDelta

62−idDelta = PositionDelta Just Just

63−

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

65−mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66−mkDelta cs = foldl' applyChange idDelta cs

67−

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

69−addDelta :: PositionDelta -> PositionMapping -> PositionMapping

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

31+idMapping :: PositionMapping

32+idMapping = PositionMapping Just Just

7133

72−applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

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

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

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

34+applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping

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

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

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

7638 }

7739applyChange posMapping _ = posMapping

7840

src/Development/IDE/Core/Preprocessor.hs+3−11

@@ -29,15 +29,11 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

2929import Data.Text (Text)

3030import qualified Data.Text as T

3131import Outputable (showSDoc)

32−import Control.DeepSeq (NFData(rnf))

33−import Control.Exception (evaluate)

34−import Control.Monad.IO.Class (MonadIO)

35−import Exception (ExceptionMonad)

3632

3733

3834-- | Given a file and some contents, apply any necessary preprocessors,

3935-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

40−preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

36+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

4137preprocessor filename mbContents = do

4238 -- Perform unlit

4339 (isOnDisk, contents) <-

@@ -133,17 +129,13 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

133129

134130-- | This reads the pragma information directly from the provided buffer.

135131parsePragmasIntoDynFlags

136− :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

132+ :: GhcMonad m

137133 => FilePath

138134 -> SB.StringBuffer

139135 -> m (Either [FileDiagnostic] DynFlags)

140136parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

141− dflags0 <- getDynFlags

137+ dflags0 <- getSessionDynFlags

142138 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−

147139 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

148140 return dflags

149141

src/Development/IDE/Core/RuleTypes.hs+1−10

@@ -105,10 +105,6 @@ type instance RuleResult GetModIface = HiFileResult

105105

106106type instance RuleResult IsFileOfInterest = Bool

107107

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−

112108data GetParsedModule = GetParsedModule

113109 deriving (Eq, Show, Typeable, Generic)

114110instance Hashable GetParsedModule

@@ -181,14 +177,9 @@ instance Hashable GetModIface

181177instance NFData GetModIface

182178instance Binary GetModIface

183179

180+

184181data IsFileOfInterest = IsFileOfInterest

185182 deriving (Eq, Show, Typeable, Generic)

186183instance Hashable IsFileOfInterest

187184instance NFData IsFileOfInterest

188185instance 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+119−229

@@ -1,11 +1,10 @@

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

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE FlexibleInstances #-}

76{-# LANGUAGE DuplicateRecordFields #-}

8−#include "ghc-api-version.h"

7+{-# LANGUAGE PatternSynonyms #-}

109-- | A Shake implementation of the compiler service, built

1110-- using the "Shaker" abstraction layer for in-memory use.

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

2827

2928import Fingerprint

3029

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

32−import Data.Bifunctor (first, second)

30+import Data.Binary

31+import Data.Bifunctor (second)

3332import Control.Monad.Extra

3433import Control.Monad.Trans.Class

3534import Control.Monad.Trans.Maybe

@@ -45,12 +44,13 @@ import Development.IDE.Types.Diagnostics

4544import Development.IDE.Types.Location

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

4746import Development.IDE.GHC.Util

48−import Development.IDE.GHC.WithDynFlags

47+import Data.Coerce

4948import Data.Either.Extra

5049import Data.Maybe

5150import Data.Foldable

5251import qualified Data.IntMap.Strict as IntMap

5352import Data.IntMap.Strict (IntMap)

53+import qualified Data.IntSet as IntSet

5454import Data.List

5555import Data.Ord

5656import qualified Data.Set as Set

@@ -59,23 +59,16 @@ import Development.IDE.GHC.Error

5959import Development.Shake hiding (Diagnostic)

6060import Development.IDE.Core.RuleTypes

6161import Development.IDE.Spans.Type

62−import qualified Data.ByteString.Char8 as BS

6362

6463import qualified GHC.LanguageExtensions as LangExt

6564import HscTypes

66−import PackageConfig

67−import DynFlags (gopt_set, xopt)

65+import DynFlags (xopt)

6866import GHC.Generics(Generic)

6967

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

7169import Development.IDE.Core.Service

7270import Development.IDE.Core.Shake

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

71+import Development.Shake.Classes

7972

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

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

@@ -138,11 +131,12 @@ getHieFile file mod = do

138131

139132getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

140133getHomeHieFile f = do

141− ms <- use_ GetModSummary f

134+ pm <- use_ GetParsedModule f

142135 let normal_hie_f = toNormalizedFilePath' hie_f

143− hie_f = ml_hie_file $ ms_location ms

136+ hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm

144137 mbHieTimestamp <- use GetModificationTime normal_hie_f

145138 srcTimestamp <- use_ GetModificationTime f

139+

146140 let isUpToDate

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

148142 | otherwise = False

@@ -150,7 +144,7 @@ getHomeHieFile f = do

150144 unless isUpToDate $

151145 void $ use_ TypeCheck f

152146

153− hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)

147+ hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing

154148 return ([], hf)

155149

156150getPackageHieFile :: Module -- ^ Package Module to load .hie file for

@@ -191,60 +185,31 @@ priorityFilesOfInterest :: Priority

191185priorityFilesOfInterest = Priority (-2)

192186

193187getParsedModuleRule :: Rules ()

194−getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

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)

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

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

228− case res of

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

230− Just (contents, modu) -> do

231− mbFingerprint <- if isNothing $ optShakeFiles opt

232− then pure Nothing

233− else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

234− pure (mbFingerprint, (diag, Just modu))

188+getParsedModuleRule =

189+ defineEarlyCutoff $ \GetParsedModule file -> do

190+ (_, contents) <- getFileContents file

191+ packageState <- hscEnv <$> use_ GhcSession file

192+ opt <- getIdeOptions

193+ (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

194+ case res of

195+ Nothing -> pure (Nothing, (diag, Nothing))

196+ Just (contents, modu) -> do

197+ mbFingerprint <- if isNothing $ optShakeFiles opt

198+ then pure Nothing

199+ else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

200+ pure (mbFingerprint, (diag, Just modu))

235201

236202getLocatedImportsRule :: Rules ()

237203getLocatedImportsRule =

238204 define $ \GetLocatedImports file -> do

239− ms <- use_ GetModSummary file

205+ pm <- use_ GetParsedModule file

206+ let ms = pm_mod_summary pm

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

241− env_eq <- use_ GhcSession file

242− let env = hscEnv env_eq

243− let import_dirs = deps env_eq

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

208+ env <- hscEnv <$> use_ GhcSession file

209+ let dflags = addRelativeImport file pm $ hsc_dflags env

245210 opt <- getIdeOptions

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

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

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

248213 case diagOrImp of

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

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

@@ -258,91 +223,54 @@ getLocatedImportsRule =

258223 Nothing -> pure (concat diags, Nothing)

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

260225

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

269226

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

271228-- imports recursively.

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

273−rawDependencyInformation fs = do

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

229+rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

230+rawDependencyInformation f = do

231+ let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "") False

232+ (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap

233+ (rdi, ss) <- go (IntSet.singleton $ getFilePathId initialId)

234+ ((RawDependencyInformation IntMap.empty initialMap IntMap.empty), IntMap.empty)

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

276236 return (rdi { rawBootMap = bm })

277237 where

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

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

280− go f = do

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

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

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

284− checkAlreadyProcessed f $ do

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

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

287− fId <- getFreshFid al

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

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

290− addBootMap al fId

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

292− importsOrErr <- lift $ use GetLocatedImports f

293− case importsOrErr of

294− Nothing -> do

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

296− -- dependency information, continue processing the other

297− -- elements in the queue

298− modifyRawDepInfo (insertImport fId (Left ModuleParseError))

299− return fId

300− Just (modImports, pkgImports) -> do

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

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

303− let (no_file, with_file) = splitImports modImports

304− (mns, ls) = unzip with_file

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

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

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

308− -- Associate together the ModuleName with the FilePathId

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

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

311− -- imports.

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

313− return fId

314−

315−

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

317− checkAlreadyProcessed nfp k = do

318− (rawDepInfo, _) <- get

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

320−

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

322− modifyRawDepInfo f = modify (first f)

323−

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

325− addBootMap al fId =

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

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

328− else ss))

329−

330− getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331− getFreshFid al = do

332− (rawDepInfo, ss) <- get

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

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

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

336− put (rawDepInfo', ss)

337− return fId

338−

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

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

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

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

343−

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

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

238+ go fs (rawDepInfo, ss) =

239+ case IntSet.minView fs of

240+ -- Queue is empty

241+ Nothing -> pure (rawDepInfo, ss)

242+ -- Pop f from the queue and process it

243+ Just (f, fs) -> do

244+ let fId = FilePathId f

245+ importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId

246+ case importsOrErr of

247+ Nothing ->

248+ -- File doesn’t parse

249+ let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo

250+ in go fs (rawDepInfo', ss)

251+ Just (modImports, pkgImports) -> do

252+ let f :: (PathIdMap, IntMap ArtifactsLocation)

253+ -> (a, Maybe ArtifactsLocation)

254+ -> ((PathIdMap, IntMap ArtifactsLocation), (a, Maybe FilePathId))

255+ f (pathMap, ss) (imp, mbPath) = case mbPath of

256+ Nothing -> ((pathMap, ss), (imp, Nothing))

257+ Just path ->

258+ let (pathId, pathMap') = getPathId path pathMap

259+ ss' = if isBootLocation path

260+ then IntMap.insert (getFilePathId pathId) path ss

261+ else ss

262+ in ((pathMap', ss'), (imp, Just pathId))

263+ -- Convert paths in imports to ids and update the path map

264+ let ((pathIdMap, ss'), modImports') = mapAccumL f (rawPathIdMap rawDepInfo, ss) modImports

265+ -- Files that we haven’t seen before are added to the queue.

266+ let newFiles =

267+ IntSet.fromList (coerce $ mapMaybe snd modImports')

268+ IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)

269+ let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo

270+ go (newFiles `IntSet.union` fs)

271+ (rawDepInfo' { rawPathIdMap = pathIdMap }, ss')

272+

273+

346274

347275 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

348276 if not artifactIsSource

@@ -360,7 +288,7 @@ rawDependencyInformation fs = do

360288getDependencyInformationRule :: Rules ()

361289getDependencyInformationRule =

362290 define $ \GetDependencyInformation file -> do

363− rawDepInfo <- rawDependencyInformation [file]

291+ rawDepInfo <- rawDependencyInformation file

364292 pure ([], Just $ processDependencyInformation rawDepInfo)

365293

366294reportImportCyclesRule :: Rules ()

@@ -393,8 +321,8 @@ reportImportCyclesRule =

393321 where loc = srcSpanToLocation (getLoc imp)

394322 fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

395323 getModuleName file = do

396− ms <- use_ GetModSummary file

397− pure (moduleNameString . moduleName . ms_mod $ ms)

324+ pm <- use_ GetParsedModule file

325+ pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

398326 showCycle mods = T.intercalate ", " (map T.pack mods)

399327

400328-- returns all transitive dependencies in topological order.

@@ -414,31 +342,22 @@ getSpanInfoRule :: Rules ()

414342getSpanInfoRule =

415343 define $ \GetSpanInfo file -> do

416344 tc <- use_ TypeCheck file

417− packageState <- hscEnv <$> use_ GhcSession file

418345 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

419346 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

426347 parsedDeps <- uses_ GetParsedModule tdeps

427−#endif

428−

429348 ifaces <- uses_ GetModIface tdeps

430349 (fileImports, _) <- use_ GetLocatedImports file

350+ packageState <- hscEnv <$> use_ GhcSession file

431351 let imports = second (fmap artifactFilePath) <$> fileImports

432− x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

352+ x <- liftIO $ getSrcSpanInfos packageState imports tc (zip parsedDeps $ map hirModIface ifaces)

433353 return ([], Just x)

434354

435355-- Typechecks a module.

436356typeCheckRule :: Rules ()

437−typeCheckRule = define $ \TypeCheck file -> do

438− pm <- use_ GetParsedModule file

357+typeCheckRule = define $ \TypeCheck file ->

439358 -- do not generate interface files as this rule is called

440359 -- for files of interest on every keystroke

441− typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

360+ typeCheckRuleDefinition file SkipGenerationOfInterfaceFiles

442361

443362data GenerateInterfaceFiles

444363 = DoGenerateInterfaceFiles

@@ -451,10 +370,10 @@ data GenerateInterfaceFiles

451370-- retain the information forever in the shake graph.

452371typeCheckRuleDefinition

453372 :: NormalizedFilePath -- ^ Path to source file

454− -> ParsedModule

455373 -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

456374 -> Action (IdeResult TcModuleResult)

457−typeCheckRuleDefinition file pm generateArtifacts = do

375+typeCheckRuleDefinition file generateArtifacts = do

376+ pm <- use_ GetParsedModule file

458377 deps <- use_ GetDependencies file

459378 hsc <- hscEnv <$> use_ GhcSession file

460379 -- Figure out whether we need TemplateHaskell or QuasiQuotes support

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

471390 setPriority priorityTypeCheck

472391 IdeOptions { optDefer = defer } <- getIdeOptions

473392

474− addUsageDependencies $ liftIO $ do

393+ liftIO $ do

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

476395 case res of

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

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

485404 uses_th_qq dflags =

486405 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

487406

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−

500407

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

502409generateCore runSimplifier file = do

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

529436instance NFData GhcSessionIO

530437instance Binary GhcSessionIO

531438

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

439+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

533440instance Show GhcSessionFun where show _ = "GhcSessionFun"

534441instance NFData GhcSessionFun where rnf !_ = ()

535442

@@ -539,70 +446,69 @@ loadGhcSession = do

539446 defineNoFile $ \GhcSessionIO -> do

540447 opts <- getIdeOptions

541448 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

546449 defineEarlyCutoff $ \GhcSession file -> do

547450 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548− alwaysRerun

549451 val <- fun $ fromNormalizedFilePath file

550−

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

552452 opts <- getIdeOptions

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)

453+ return ("" <$ optShakeFiles opts, ([], Just val))

562454

563455getHiFileRule :: Rules ()

564456getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

457+ session <- hscEnv <$> use_ GhcSession f

565458 -- get all dependencies interface files, to check for freshness

566459 (deps,_) <- use_ GetLocatedImports f

567460 depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

568461

569− ms <- use_ GetModSummary f

570− let hiFile = toNormalizedFilePath'

571− $ case ms_hsc_src ms of

462+ -- TODO find the hi file without relying on the parsed module

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' $

467+ case ms_hsc_src ms of

572468 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

573469 _ -> 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

574483

575484 case sequence depHis of

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

485+ Nothing -> do

486+ let d = mkInterfaceFilesGenerationDiag f "Missing interface file dependencies"

487+ pure (Nothing, (d, Nothing))

577488 Just deps -> do

578489 gotHiFile <- getFileExists hiFile

579490 if not gotHiFile

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

491+ then do

492+ let d = mkInterfaceFilesGenerationDiag f "Missing interface file"

493+ pure (Nothing, (d, Nothing))

581494 else do

582495 hiVersion <- use_ GetModificationTime hiFile

583496 modVersion <- use_ GetModificationTime f

584497 let sourceModified = modificationTime hiVersion < modificationTime modVersion

585498 if sourceModified

586499 then do

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

500+ let d = mkInterfaceFilesGenerationDiag f "Stale interface file"

501+ pure (Nothing, (d, Nothing))

588502 else do

589− session <- hscEnv <$> use_ GhcSession f

590503 r <- liftIO $ loadInterface session ms deps

591504 case r of

592505 Right iface -> do

593506 let result = HiFileResult ms iface

594− return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))

507+ return (Just (fingerprintToBS (mi_mod_hash iface)), ([], Just result))

595508 Left err -> do

596509 let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

597510 return (Nothing, (pure diag, Nothing))

598511

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

606512

607513getModIfaceRule :: Rules ()

608514getModIfaceRule = define $ \GetModIface f -> do

@@ -620,26 +526,11 @@ getModIfaceRule = define $ \GetModIface f -> do

620526 tmr <- use TypeCheck f

621527 return ([], extract tmr)

622528 | otherwise -> do

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

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

639− (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles

640− -- Bang pattern is important to avoid leaking 'tmr'

641− let !res = extract tmr

642− return (diags <> diags', res)

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.

530+ (diags, tmr) <- typeCheckRuleDefinition f DoGenerateInterfaceFiles

531+ -- Bang pattern is important to avoid leaking 'tmr'

532+ let !res = extract tmr

533+ return (diags, res)

643534 where

644535 extract Nothing = Nothing

645536 extract (Just tmr) =

@@ -668,4 +559,3 @@ mainRule = do

668559 getHiFileRule

669560 getModIfaceRule

670561 isFileOfInterestRule

671− getModSummaryRule

src/Development/IDE/Core/Shake.hs+34−44

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

5353import Data.Dynamic

5454import Data.Maybe

5555import Data.Map.Strict (Map)

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

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

5757import qualified Data.Set as Set

5858import qualified Data.Text as T

5959import Data.Traversable (for)

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

6969import Development.IDE.Types.Options

7070import Control.Concurrent.Async

7171import Control.Concurrent.Extra

72−import Control.Exception.Extra

72+import Control.Exception

7373import Control.DeepSeq

7474import System.Time.Extra

7575import Data.Typeable

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

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

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

9999 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))

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

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

103− -- First mapping is delta from previous version and second one is an

104− -- accumlation of all previous mappings.

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

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

107105 }

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

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

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

128126 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

129− Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

127+ Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

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

131129

132130

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

134132getIdeGlobalExtras ShakeExtras{globals} = do

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

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

137− case x of

138− Just x

139− | Just x <- fromDynamic x -> pure x

140− | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141− Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

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

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

142135

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

144137getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

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

161154 | otherwise = False

162155

163156instance Hashable Key where

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

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

165158

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

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

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

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

172165-- errors but still failed.

173166--

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)

174170

175171data Value v

176172 = Succeeded TextDocumentVersion v

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

205201 Failed -> Nothing

206202

207203mappingForVersion

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

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

209205 -> NormalizedFilePath

210206 -> TextDocumentVersion

211207 -> PositionMapping

212208mappingForVersion allMappings file ver =

213− maybe zeroMapping snd $

209+ fromMaybe idMapping $

214210 Map.lookup ver =<<

215211 HMap.lookup (filePathToUri' file) allMappings

216212

@@ -243,6 +239,7 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

243239 shakeProfileDatabase shakeDb $ dir </> file

244240 return (dir </> file)

245241 return (res, proFile)

242+ where

246243

247244{-# NOINLINE profileStartTime #-}

248245profileStartTime :: String

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

513510

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

515512-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

516−newtype A v = A (Value v)

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

517516 deriving Show

518517

519−instance NFData (A v) where rnf (A v) = v `seq` ()

518+instance NFData (A v) where rnf (A v x) = v `seq` rnf x

520519

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

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

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

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

527526uses :: IdeRule k v

528527 => k -> [NormalizedFilePath] -> Action [Maybe v]

529−uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

528+uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

530529

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

532531usesWithStale :: IdeRule k v

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

534533usesWithStale key files = do

535− values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

536− zipWithM lastValue files values

534+ values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

535+ mapM (uncurry lastValue) (zip files values)

537536

538537

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

540539withProgress 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.

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

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

545541

546542

547543defineEarlyCutoff

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

558554 case v of

559555 -- No changes in the dependencies and we have

560556 -- an existing result.

561− Just v -> return $ Just $ RunResult ChangedNothing old $ A v

557+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

562558 _ -> return Nothing

563559 _ -> return Nothing

564560 case val of

565561 Just res -> return res

566562 Nothing -> do

567563 (bs, (diags, res)) <- actionCatch

568− (do v <- op key file; liftIO $ evaluate $ force v) $

564+ (do v <- op key file; liftIO $ evaluate $ force $ v) $

569565 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

570− modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

566+ modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

571567 (bs, res) <- case res of

572568 Nothing -> do

573569 staleV <- liftIO $ getValues state key file

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

577573 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

578574 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

579575 Failed -> (toShakeValue ShakeResult bs, Failed)

580− Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

576+ Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

581577 liftIO $ setValues state key file res

582578 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

583579 let eq = case (bs, fmap decodeShakeValue old) of

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

589585 return $ RunResult

590586 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

591587 (encodeShakeValue bs) $

592− A res

588+ A res bs

593589

594590

595591-- | Rule type, input file

@@ -704,7 +700,7 @@ updateFileDiagnostics ::

704700 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

705701 -> Action ()

706702updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

707− modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

703+ modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

708704 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

709705 mask_ $ do

710706 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -717,7 +713,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

717713 let newDiags = getFileDiagnostics fp newDiagsStore

718714 _ <- evaluate newDiagsStore

719715 _ <- evaluate newDiags

720− pure (newDiagsStore, newDiags)

716+ pure $! (newDiagsStore, newDiags)

721717 modifyVar_ hiddenDiagnostics $ \old -> do

722718 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

723719 (T.pack $ show k) (map snd currentHidden) old

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

743739newtype Priority = Priority Double

744740

745741setPriority :: Priority -> Action ()

746−setPriority (Priority p) = reschedule p

742+setPriority (Priority p) = deprioritize p

747743

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

749745sendEvent e = do

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

769765type instance RuleResult GetModificationTime = FileVersion

770766

771767data FileVersion

772− = VFSVersion !Int

768+ = VFSVersion Int

773769 | ModificationTime

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

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

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

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

834830

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

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

832+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

837833 modifyVar_ positionMapping $ \allMappings -> do

838834 let uri = toNormalizedUri _uri

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

840− let (_, updatedMapping) =

841− -- Very important to use mapAccum here so that the tails of

842− -- each mapping can be shared, otherwise quadratic space is

843− -- used which is evident in long running sessions.

844− Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845− zeroMapping

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

836+ let updatedMapping =

837+ Map.insert _version idMapping $

838+ Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

847839 pure $! HMap.insert uri updatedMapping allMappings

848− where

849− shared_change = mkDelta changes

src/Development/IDE/GHC/Compat.hs+2−59

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

88-- | Attempt at hiding the GHC version differences we can.

99module Development.IDE.GHC.Compat(

10− getHeaderImports,

1110 HieFileResult(..),

1211 HieFile,

1312 hieExportNames,

@@ -25,8 +24,6 @@ module Development.IDE.GHC.Compat(

2524 includePathsGlobal,

2625 includePathsQuote,

2726 addIncludePathsQuote,

28− getModuleHash,

29− getPackageName,

3027 pattern DerivD,

3128 pattern ForD,

3229 pattern InstD,

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

3835 GHC.ModLocation,

3936 Module.addBootSuffix,

4037 pattern ModLocation,

41− getConArgs,

4238

4339 module GHC

4440 ) where

@@ -46,29 +42,15 @@ module Development.IDE.GHC.Compat(

4642import StringBuffer

4743import DynFlags

4844import FieldLabel

49−import Fingerprint (Fingerprint)

5045import qualified Module

51−import Packages

5246

5347import qualified GHC

54−import GHC hiding (

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

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

57− , getConArgs

58−#endif

59− )

60−import qualified HeaderInfo as Hdr

48+import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)

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

6850

6951#if MIN_GHC_API_VERSION(8,8,0)

7052import Control.Applicative ((<|>))

71−import Development.IDE.GHC.HieAst (mkHieFile)

53+import Development.IDE.GHC.HieAst

7254import HieBin

7355import HieTypes

7456

@@ -87,7 +69,6 @@ import IfaceEnv

8769#endif

8870

8971import Binary

90−import Control.Exception (catch)

9172import Data.ByteString (ByteString)

9273import GhcPlugins hiding (ModLocation)

9374import NameCache

@@ -269,41 +250,3 @@ readHieFile _ _ = return undefined

269250#endif

270251

271252#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+2−24

@@ -9,7 +9,6 @@ module Development.IDE.GHC.Error

99 , diagFromStrings

1010 , diagFromGhcException

1111 , catchSrcErrors

12− , mergeDiagnostics

1312

1413 -- * utilities working with spans

1514 , srcSpanToLocation

@@ -37,7 +36,6 @@ import Panic

3736import ErrUtils

3837import SrcLoc

3938import qualified Outputable as Out

40−import Exception (ExceptionMonad)

4139

4240

4341

@@ -56,33 +54,13 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename

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

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

5856diagFromErrMsg diagSource dflags e =

59− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

60− ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

57+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

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

6259

6360

6461diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

6562diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

6663

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

8664

8765-- | Convert a GHC SrcSpan to a DAML compiler Range

8866srcSpanToRange :: SrcSpan -> Range

@@ -150,7 +128,7 @@ realSpan = \case

150128

151129-- | Run something in a Ghc monad and catch the errors (SourceErrors and

152130-- compiler-internal exceptions like Panic or InstallationError).

153−catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

131+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

154132catchSrcErrors fromWhere ghcM = do

155133 dflags <- getDynFlags

156134 handleGhcException (ghcExceptionToDiagnostics dflags) $

src-ghc88/Development/IDE/GHC/HieAst.hs → src/Development/IDE/GHC/HieAst.hsrenamed

The content is the same.

src/Development/IDE/GHC/Orphans.hs+3−10

@@ -1,10 +1,8 @@

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

4−{-# LANGUAGE CPP #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# OPTIONS_GHC -Wno-orphans #-}

7−#include "ghc-api-version.h"

97-- | Orphan instances for GHC.

108-- Note that the 'NFData' instances may not be law abiding.

@@ -33,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf

3331instance Show InstalledUnitId where

3432 show = installedUnitIdString

3533

36−instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

34+instance NFData InstalledUnitId where rnf = rwhnf

3735

3836instance NFData SB.StringBuffer where rnf = rwhnf

3937

@@ -42,8 +40,8 @@ instance Show Module where

4240

4341instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

4442

45−instance (NFData l, NFData e) => NFData (GenLocated l e) where

46− rnf (L l e) = rnf l `seq` rnf e

43+instance NFData (GenLocated SrcSpan ModuleName) where

44+ rnf = rwhnf

4745

4846instance Show ModSummary where

4947 show = show . ms_mod

@@ -54,11 +52,6 @@ instance Show ParsedModule where

5452instance NFData ModSummary where

5553 rnf = rwhnf

5654

57−#if !MIN_GHC_API_VERSION(8,10,0)

58−instance NFData FastString where

59− rnf = rwhnf

60−#endif

61−

6255instance NFData ParsedModule where

6356 rnf = rwhnf

6457

src/Development/IDE/GHC/Util.hs+15−21

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

88 modifyDynFlags,

99 evalGhcEnv,

1010 runGhcEnv,

11− deps,

1211 -- * GHC wrappers

1312 prettyPrint,

1413 printRdrName,

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

6564import SrcLoc (mkRealSrcLoc)

6665import FastString (mkFastString)

6766import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

68−import Module (moduleNameSlashes, InstalledUnitId)

67+import Module (moduleNameSlashes)

6968import OccName (parenSymOcc)

7069import RdrName (nameRdrName, rdrNameOcc)

7170

@@ -148,30 +147,29 @@ runGhcEnv env act = do

148147-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

149148-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

150149-- @\/usr\/Test@ should be on the include path to find sibling modules.

151−moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

150+moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

152151-- The call to takeDirectory is required since DAML does not require that

153152-- the file name matches the module name in the last component.

154153-- Once that has changed we can get rid of this.

155−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

154+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

156155 -- This happens for single-component modules since takeDirectory "A" == "."

157156 | modDir == "." = Just pathDir

158157 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

159158 where

159+ ms = GHC.pm_mod_summary pm

160+ mod' = GHC.ms_mod ms

160161 -- A for module A.B

161162 modDir =

162163 takeDirectory $

163164 fromNormalizedFilePath $ toNormalizedFilePath' $

164− moduleNameSlashes mn

165+ moduleNameSlashes $ GHC.moduleName mod'

165166

166167-- | An 'HscEnv' with equality. Two values are considered equal

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

168169data HscEnvEq

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

173171 | GhcVersionMismatch { compileTime :: !Version

174− , runTime :: !Version

172+ , runTime :: !(Maybe Version)

175173 }

176174

177175-- | Unwrap an 'HsEnvEq'.

@@ -179,39 +177,35 @@ hscEnv :: HscEnvEq -> HscEnv

179177hscEnv = either error id . hscEnv'

180178

181179hscEnv' :: HscEnvEq -> Either String HscEnv

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

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

183181hscEnv' GhcVersionMismatch{..} = Left $

184182 unwords

185183 ["ghcide compiled against GHC"

186184 ,showVersion compileTime

187185 ,"but currently using"

188− ,showVersion runTime

186+ ,maybe "an unknown version of GHC" (\v -> "GHC " <> showVersion v) runTime

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

190188 ]

191189

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

193−deps (HscEnvEq _ _ u) = u

194−deps GhcVersionMismatch{} = []

195−

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

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

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

191+newHscEnvEq :: HscEnv -> IO HscEnvEq

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

199193

200194instance Show HscEnvEq where

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

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

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

203197

204198instance Eq HscEnvEq where

205− HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

199+ HscEnvEq a _ == HscEnvEq b _ = a == b

206200 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207201 _ == _ = False

208202

209203instance NFData HscEnvEq where

210− rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

204+ rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

211205 rnf GhcVersionMismatch{} = rnf runTime

212206

213207instance Hashable HscEnvEq where

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

208+ hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u

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

216210

217211-- Fake instance needed to persuade Shake to accept this type as a key.

src/Development/IDE/GHC/WithDynFlags.hsdeleted−30

@@ -1,30 +0,0 @@

1−module Development.IDE.GHC.WithDynFlags

2−( WithDynFlags

3−, evalWithDynFlags

4−) where

5−

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+19−23

@@ -62,22 +62,17 @@ data ModuleImports = ModuleImports

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

6363 , packageImports :: !(Set InstalledUnitId)

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

65− } deriving Show

65+ }

6666

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

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

69−-- instead and only convert at the edges.

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

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

69+-- instead and only convert at the edges

70+-- and

7071newtype FilePathId = FilePathId { getFilePathId :: Int }

7172 deriving (Show, NFData, Eq, Ord)

7273

73−-- | Map from 'FilePathId'

74−type FilePathIdMap = IntMap

75−

76−-- | Set of 'FilePathId's

77−type FilePathIdSet = IntSet

78−

7974data PathIdMap = PathIdMap

80− { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

75+ { idToPathMap :: !(IntMap ArtifactsLocation)

8176 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

8277 }

8378 deriving (Show, Generic)

@@ -114,40 +109,41 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap fil

114109idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

115110idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

116111

117−type BootIdMap = FilePathIdMap FilePathId

112+

113+type BootIdMap = IntMap FilePathId

118114

119115insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120116insertBootId k = IntMap.insert (getFilePathId k)

121117

118+

122119-- | Unprocessed results that we find by following imports recursively.

123120data RawDependencyInformation = RawDependencyInformation

124− { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

121+ { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

125122 , rawPathIdMap :: !PathIdMap

126123 -- The rawBootMap maps the FilePathId of a hs-boot file to its

127124 -- corresponding hs file. It is used when topologically sorting as we

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

129126 -- appear later in the sort.

130127 , rawBootMap :: !BootIdMap

131− } deriving Show

128+ }

132129

133−pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

130+pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

134131pkgDependencies RawDependencyInformation{..} =

135132 IntMap.map (either (const Set.empty) packageImports) rawImports

136133

137134data DependencyInformation =

138135 DependencyInformation

139− { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

136+ { depErrorNodes :: !(IntMap (NonEmpty NodeError))

140137 -- ^ Nodes that cannot be processed correctly.

141− , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142− , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

138+ , depModuleNames :: !(IntMap ShowableModuleName)

139+ , depModuleDeps :: !(IntMap IntSet)

143140 -- ^ For a non-error node, this contains the set of module immediate dependencies

144141 -- in the same package.

145− , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

142+ , depPkgDeps :: !(IntMap (Set InstalledUnitId))

146143 -- ^ For a non-error node, this contains the set of immediate pkg deps.

147144 , depPathIdMap :: !PathIdMap

148− -- ^ Map from FilePath to FilePathId

149− , depBootMap :: !BootIdMap

150145 -- ^ Map from hs-boot file to the corresponding hs file

146+ , depBootMap :: !BootIdMap

151147 } deriving (Show, Generic)

152148

153149newtype ShowableModuleName =

@@ -247,7 +243,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

247243-- 2. Mark each node that has a parse error as an error node.

248244-- 3. Mark each node whose immediate children could not be located as an error.

249245-- 4. Recursively propagate errors to parents if they are not already error nodes.

250−buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

246+buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

251247buildResultGraph g = propagatedErrors

252248 where

253249 sccs = stronglyConnComp (graphEdges g)

@@ -294,7 +290,7 @@ buildResultGraph g = propagatedErrors

294290 Right ModuleImports{moduleImports} ->

295291 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

296292

297−graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

293+graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

298294graphEdges g =

299295 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

300296 where deps :: Either e ModuleImports -> [FilePathId]

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

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

88 ( locateModule

99 , Import(..)

1010 , ArtifactsLocation(..)

11− , modSummaryToArtifactsLocation

1211 , isBootLocation

13− , mkImportDirs

1412 ) where

1513

1614import Development.IDE.GHC.Error as ErrUtils

1715import Development.IDE.GHC.Orphans()

1816import Development.IDE.Types.Diagnostics

1917import Development.IDE.Types.Location

20−import Development.IDE.GHC.Compat

2118-- GHC imports

19+import DynFlags

2220import FastString

21+import GHC

2322import qualified Module as M

2423import Packages

2524import Outputable (showSDoc, ppr, pprPanic)

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

3029import Control.Monad.Extra

3130import Control.Monad.IO.Class

3231import System.FilePath

33−import DriverPhases

34−import Data.Maybe

3532

3633data Import

3734 = FileImport !ArtifactsLocation

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

5552 rnf (FileImport x) = rnf x

5653 rnf (PackageImport x) = rnf x

5754

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−

6455

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

6657locateModuleFile :: MonadIO m

67− => [[FilePath]]

58+ => DynFlags

6859 -> [String]

6960 -> (NormalizedFilePath -> m Bool)

7061 -> Bool

7162 -> ModuleName

7263 -> m (Maybe NormalizedFilePath)

73−locateModuleFile import_dirss exts doesExist isSource modName = do

74− let candidates import_dirs =

64+locateModuleFile dflags exts doesExist isSource modName = do

65+ let candidates =

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

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

77− findM doesExist (concatMap candidates import_dirss)

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

68+ findM doesExist candidates

7869 where

7970 maybeBoot ext

8071 | isSource = ext ++ "-boot"

8172 | otherwise = ext

8273

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−

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

9175-- Haskell

9276locateModule

9377 :: MonadIO m

9478 => DynFlags

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

9679 -> [String]

9780 -> (NormalizedFilePath -> m Bool)

9881 -> Located ModuleName

9982 -> Maybe FastString

10083 -> Bool

10184 -> m (Either [FileDiagnostic] Import)

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

85+locateModule dflags exts doesExist modName mbPkgName isSource = do

10386 case mbPkgName of

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

10588 Just "this" -> do

106− lookupLocal [importPaths dflags]

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

90+ case mbFile of

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

92+ Just file -> toModLocation file

10793 -- 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]

111− | otherwise -> lookupInPackageDB dflags

94+ Just _pkgName -> lookupInPackageDB dflags

11295 Nothing -> do

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

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

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

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

11999 case mbFile of

120100 Nothing -> lookupInPackageDB dflags

121101 Just file -> toModLocation file

122102 where

123− import_paths = mapMaybe (mkImportDirs dflags) comp_info

124103 toModLocation file = liftIO $ do

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

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

127106

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

133107

134108 lookupInPackageDB dfs =

135109 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

src/Development/IDE/LSP/LanguageServer.hs+8−8

@@ -144,14 +144,14 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

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

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

146146 \case

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

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

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

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

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

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

151151 \(res, newReq) -> do

152152 case res of

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

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

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

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

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

156156 reqId <- getNextReqId

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

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

175175 Left () -> do

176176 logDebug (ideLogger ide) $ T.pack $

177177 "Cancelled request " <> show _id

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

179− $ ResponseError RequestCancelled "" Nothing

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

179+ Just $ ResponseError RequestCancelled "" Nothing

180180 Right res -> k res

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

182182 logError (ideLogger ide) $ T.pack $

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

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

185185 "Exception: " ++ show e

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

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

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

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

188188

189189initializeRequestHandler :: PartialHandlers config

190190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{

src/Development/IDE/LSP/Outline.hs+4−16

@@ -43,7 +43,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

4343 mb_decls <- runAction ideState $ use GetParsedModule fp

4444 pure $ Right $ case mb_decls of

4545 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 } })

4747 -> let

4848 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

4949 moduleSymbol = hsmodName <&> \(L l m) ->

@@ -108,39 +108,27 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

108108 { _name = showRdrName n

109109 , _kind = SkConstructor

110110 , _selectionRange = srcSpanToRange l'

111− , _children = conArgRecordFields (getConArgs x)

112111 }

113112 | L l x <- dd_cons

114113 , L l' n <- getConNames x

115114 ]

116115 }

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

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

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

130118 , _kind = SkTypeParameter

131119 , _selectionRange = srcSpanToRange l'

132120 }

133−documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

121+documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))

134122 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

135123 , _kind = SkInterface

136124 }

137−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

125+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

138126 = Just (defDocumentSymbol l :: DocumentSymbol)

139127 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

140128 (map pprText feqn_pats)

141129 , _kind = SkInterface

142130 }

143−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

131+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

144132 = Just (defDocumentSymbol l :: DocumentSymbol)

145133 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

146134 (map pprText feqn_pats)

src/Development/IDE/Plugin.hs+1−24

@@ -1,13 +1,11 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where

44import Data.Default

5−import qualified Data.Text as T

65import Development.Shake

76import Development.IDE.LSP.Server

98import Language.Haskell.LSP.Types

10−import Development.IDE.Compat

119import Development.IDE.Core.Rules

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

1311import Language.Haskell.LSP.Messages

@@ -37,24 +35,3 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..}

3735 }

3836 where

3937 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+2−10

@@ -14,7 +14,6 @@ module Development.IDE.Plugin.CodeAction

1414 , codeAction

1515 , codeLens

1616 , rulePackageExports

17− , executeAddSignatureCommand

1817 ) where

1918

2019import Language.Haskell.LSP.Types

@@ -93,14 +92,13 @@ codeLens

9392 -> CodeLensParams

9493 -> IO (Either ResponseError (List CodeLens))

9594codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96− commandId <- makeLspCommandId "typesignature.add"

9795 fmap (Right . List) $ case uriToFilePath' uri of

9896 Just (toNormalizedFilePath' -> filePath) -> do

9997 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

10098 diag <- getDiagnostics ideState

10199 hDiag <- getHiddenDiagnostics ideState

102100 pure

103− [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

101+ [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

104102 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

105103 , dFile == filePath

106104 , (title, tedit) <- suggestSignature False dDiag

@@ -115,11 +113,7 @@ executeAddSignatureCommand

115113 -> ExecuteCommandParams

116114 -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

117115executeAddSignatureCommand _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.

122− | T.isSuffixOf "typesignature.add" _command

116+ | _command == "typesignature.add"

123117 , Just (List [edit]) <- _arguments

124118 , Success wedit <- fromJSON edit

125119 = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

@@ -424,8 +418,6 @@ extractNotInScopeName x

424418 = Just $ NotInScopeDataConstructor name

425419 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

426420 = Just $ NotInScopeTypeConstructorOrClass name

427− | Just [name] <- matchRegex x "ot in scope: \$([^‘ ]+)\$"

428− = Just $ NotInScopeThing name

429421 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

430422 = Just $ NotInScopeThing name

431423 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

src/Development/IDE/Plugin/Completions.hs+2−13

@@ -1,10 +1,9 @@

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE TypeFamilies #-}

3−#include "ghc-api-version.h"

53module Development.IDE.Plugin.Completions(plugin) where

75import Control.Applicative

6+import Data.Maybe

87import Language.Haskell.LSP.Messages

98import Language.Haskell.LSP.Types

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

@@ -23,11 +22,8 @@ import Development.IDE.Core.RuleTypes

2322import Development.IDE.Core.Shake

2423import Development.IDE.GHC.Util

2524import Development.IDE.LSP.Server

26−

27−#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28−import Data.Maybe

2925import Development.IDE.Import.DependencyInformation

30−#endif

26+

3127

3228plugin :: Plugin c

3329plugin = Plugin produceCompletions setHandlersCompletion

@@ -35,15 +31,8 @@ plugin = Plugin produceCompletions setHandlersCompletion

3531produceCompletions :: Rules ()

3632produceCompletions =

3733 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

4434 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

4535 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

46−#endif

4736 tm <- fmap fst <$> useWithStale TypeCheck file

4837 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

4938 case (tm, packageState) of

src/Development/IDE/Plugin/Completions/Logic.hs+2−2

@@ -11,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (

1111import Control.Applicative

1212import Data.Char (isSpace, isUpper)

1313import Data.Generics

14−import Data.List.Extra as List hiding (stripPrefix)

14+import Data.List as List hiding (stripPrefix)

1515import qualified Data.Map as Map

1616import Data.Maybe (fromMaybe, mapMaybe)

1717import qualified Data.Text as T

@@ -162,7 +162,7 @@ getArgText typ = argText

162162 where

163163 argTypes = getArgs typ

164164 argText :: T.Text

165− argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

165+ argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes

166166 snippet :: Int -> Type -> T.Text

167167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168168 getArgs :: Type -> [Type]

src/Development/IDE/Spans/AtPoint.hs+1−1

@@ -123,7 +123,7 @@ locationsAtPoint

123123 -> Position

124124 -> [SpanInfo]

125125 -> m [Location]

126−locationsAtPoint getHieFile _ideOptions pos =

126+locationsAtPoint getHieFile IdeOptions{..} pos =

127127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

128128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

129129 getSpan NoSource = pure Nothing

src/Development/IDE/Spans/Calculate.hs+7−9

@@ -52,31 +52,29 @@ getSrcSpanInfos

5252 :: HscEnv

5353 -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

5454 -> TcModuleResult

55− -> [ParsedModule] -- ^ Dependencies parsed, optional

56− -> [ModIface] -- ^ Dependencies module interfaces, required

55+ -> [(ParsedModule, ModIface)]

5756 -> IO SpansInfo

58−getSrcSpanInfos env imports tc parsedDeps deps =

57+getSrcSpanInfos env imports tc deps =

5958 evalGhcEnv env $

60− getSpanInfo imports (tmrModule tc) parsedDeps deps

59+ getSpanInfo imports (tmrModule tc) deps

6160

6261-- | Get ALL source spans in the module.

6362getSpanInfo :: GhcMonad m

6463 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

6564 -> TypecheckedModule

66− -> [ParsedModule]

67− -> [ModIface]

65+ -> [(ParsedModule, ModIface)]

6866 -> m SpansInfo

69−getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

67+getSpanInfo mods tcm@TypecheckedModule{..} deps =

7068 do let tcs = tm_typechecked_source

7169 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

7270 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

7371 ps = listifyAllSpans' tcs :: [Pat GhcTc]

7472 ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]

75− allModules = tm_parsed_module : parsedDeps

73+ allModules = tm_parsed_module : map fst deps

7674 funBinds = funBindMap tm_parsed_module

7775

7876 -- Load all modules in HPT to make their interface documentation available

79− mapM_ (`loadDepModule` Nothing) (reverse deps)

77+ mapM_ ((`loadDepModule` Nothing) . snd) (reverse deps)

8078 forM_ (modInfoIface tm_checked_module_info) $ \modIface ->

8179 modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)

8280

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

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

66 LSP.Diagnostic(..),

77 ShowDiagnostic(..),

88 FileDiagnostic,

9− IdeResult,

109 LSP.DiagnosticSeverity(..),

1110 DiagnosticStore,

1211 List(..),

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

3231

3332import Development.IDE.Types.Location

3433

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)

3834

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

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

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

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

1212 , clientSupportsProgress

1313 , IdePkgLocationOptions(..)

1414 , defaultIdeOptions

15− , IdeResult

1615 ) where

1716

1817import Development.Shake

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

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

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

2322import qualified Data.Text as T

24−import Development.IDE.Types.Diagnostics

2523

2624data IdeOptions = IdeOptions

2725 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

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

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

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

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

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

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

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

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

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

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

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

61+ , optInterfaceLoadingDiagnostics :: Bool

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

6363 }

6464

6565data IdePreprocessedSource = IdePreprocessedSource

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

7878clientSupportsProgress caps = IdeReportProgress $ Just True ==

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

8080

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

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

8282defaultIdeOptions session = IdeOptions

8383 {optPreprocessor = IdePreprocessedSource [] []

8484 ,optGhcSession = session

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

9393 ,optKeywords = haskellKeywords

9494 ,optDefer = IdeDefer True

9595 ,optTesting = False

96+ ,optInterfaceLoadingDiagnostics = False

9697 }

9798

9899

stack-ghc-lib.yaml+5−5

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

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.10.3.0

8−- hie-bios-0.5.0

5+- haskell-lsp-0.21.0.0

6+- haskell-lsp-types-0.21.0.0

7+- lsp-test-0.10.2.0

8+- hie-bios-0.4.0

99- ghc-lib-parser-8.8.1

1010- ghc-lib-8.8.1

1111- fuzzy-0.1.0.0

@@ -13,7 +13,7 @@ extra-deps:

1313- regex-base-0.94.0.0

1414- regex-tdfa-1.3.1.0

1515- haddock-library-1.8.0

16−- ghc-check-0.3.0.1

16+- ghc-check-0.1.0.3

1717nix:

1818 packages: [zlib]

1919flags:

stack.yaml+5−5

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

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.11.0.1

8−- hie-bios-0.5.0

5+- haskell-lsp-0.21.0.0

6+- haskell-lsp-types-0.21.0.0

7+- lsp-test-0.10.2.0

8+- hie-bios-0.4.0

99- fuzzy-0.1.0.0

1010- regex-pcre-builtin-0.95.1.1.8.43

1111- regex-base-0.94.0.0

@@ -14,6 +14,6 @@ extra-deps:

1414- parser-combinators-1.2.1

1515- haddock-library-1.8.0

1616- tasty-rerun-1.1.17

17−- ghc-check-0.3.0.1

17+- ghc-check-0.1.0.3

1818nix:

1919 packages: [zlib]

stack810.yamldeleted−18

@@ -1,18 +0,0 @@

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+6−5

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

55extra-deps:

66- aeson-1.4.6.0

77- base-orphans-0.8.2

8−- haskell-lsp-0.22.0.0

9−- haskell-lsp-types-0.22.0.0

10−- lsp-test-0.11.0.1

8+- haskell-lsp-0.21.0.0

9+- haskell-lsp-types-0.21.0.0

10+- lsp-test-0.10.2.0

1111- rope-utf16-splay-0.3.1.0

1212- filepattern-0.1.1

1313- js-dgtable-0.5.2

14−- hie-bios-0.5.0

14+- hie-bios-0.4.0

1515- fuzzy-0.1.0.0

1616- shake-0.18.5

1717- time-compat-1.9.2.2

@@ -22,7 +22,8 @@ extra-deps:

2222- unordered-containers-0.2.10.0

2323- file-embed-0.0.11.2

2424- heaps-0.3.6.1

25−- ghc-check-0.3.0.1

25+- ghc-check-0.1.0.3

26+

2627# For tasty-retun

2728- ansi-terminal-0.10.3

2829- ansi-wl-pprint-0.6.9

stack88.yaml+5−5

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

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.11.0.1

8−- ghc-check-0.3.0.1

9−- hie-bios-0.5.0

5+- haskell-lsp-0.21.0.0

6+- haskell-lsp-types-0.21.0.0

7+- lsp-test-0.10.2.0

8+- ghc-check-0.1.0.3

1010nix:

1111 packages: [zlib]

test/data/Bar.hsnew file+3

@@ -0,0 +1,3 @@

1+module Bar (Bar) where

3+data Bar = Bar

test/data/hover/Foo.hs → test/data/Foo.hsrenamed

The content is the same.

test/data/hover/GotoHover.hs → test/data/GotoHover.hsrenamed+1−1

@@ -1,10 +1,10 @@

1−{-# LANGUAGE OverloadedStrings #-}

21{- HLINT ignore -}

32module Testing ( module Testing ) where

43import Data.Text (Text, pack)

54import Foo (Bar, foo)

88data TypeConstructor = DataConstructor

99 { fff :: Text

1010 , ggg :: Int }

test/data/hover/Bar.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Bar (Bar(..)) where

2−

3−data Bar = Bar

test/data/multi/a/A.hsdeleted−3

@@ -1,3 +0,0 @@

1−module A(foo) where

2−

3−foo = ()

test/data/multi/a/a.cabaldeleted−9

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

1−name: a

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base

8− exposed-modules: A

9− hs-source-dirs: .

test/data/multi/b/B.hsdeleted−3

@@ -1,3 +0,0 @@

1−module B(module B) where

2−import A

3−qux = foo

test/data/multi/b/b.cabaldeleted−9

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

1−name: b

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base, a

8− exposed-modules: B

9− hs-source-dirs: .

test/data/multi/cabal.projectdeleted−1

@@ -1 +0,0 @@

1−packages: a b

test/data/multi/hie.yamldeleted−6

@@ -1,6 +0,0 @@

1−cradle:

2− cabal:

3− - path: "./a"

4− component: "lib:a"

5− - path: "./b"

6− component: "lib:b"

test/exe/Main.hs+205−368

@@ -1,7 +1,6 @@

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

4−{-# LANGUAGE AllowAmbiguousTypes #-}

54{-# LANGUAGE DuplicateRecordFields #-}

65{-# LANGUAGE PatternSynonyms #-}

76{-# LANGUAGE CPP #-}

@@ -10,32 +9,31 @@

109module Main (main) where

1110

1211import Control.Applicative.Combinators

13−import Control.Exception (bracket, catch)

14−import qualified Control.Lens as Lens

12+import Control.Exception (catch)

1513import Control.Monad

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

17−import Data.Aeson (FromJSON, Value)

15+import Data.Aeson (Value)

16+import Data.Char (toLower)

1817import Data.Foldable

19−import Data.List.Extra

18+import Data.List

2019import Data.Rope.UTF16 (Rope)

2120import qualified Data.Rope.UTF16 as Rope

2221import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

2322import Development.IDE.GHC.Util

2423import qualified Data.Text as T

25−import Data.Typeable

2624import Development.IDE.Spans.Common

2725import Development.IDE.Test

2826import Development.IDE.Test.Runfiles

2927import Development.IDE.Types.Location

3028import Development.Shake (getDirectoryFilesIO)

31−import Language.Haskell.LSP.Test

29+import qualified Language.Haskell.LSP.Test as LSPTest

30+import Language.Haskell.LSP.Test hiding (openDoc')

3231import Language.Haskell.LSP.Messages

3332import Language.Haskell.LSP.Types

3433import Language.Haskell.LSP.Types.Capabilities

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

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

3735import Network.URI

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

36+import System.Environment.Blank (setEnv)

3937import System.FilePath

4038import System.IO.Extra

4139import System.Directory

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

4947import Data.Maybe

5048

5149main :: IO ()

52−main = do

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

54− setEnv "TASTY_NUM_THREADS" "1" True

55− defaultMainWithRerun $ testGroup "HIE"

56− [ testSession "open close" $ do

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

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

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

60− closeDoc doc

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

62− , initializeResponseTests

63− , completionTests

64− , cppTests

65− , diagnosticTests

66− , codeActionTests

67− , codeLensesTests

68− , outlineTests

69− , findDefinitionAndHoverTests

70− , pluginTests

71− , preprocessorTests

72− , thTests

73− , safeTests

74− , unitTests

75− , haddockTests

76− , positionMappingTests

77− , watchedFilesTests

78− , cradleTests

79− , dependentFileTest

80− ]

50+main = defaultMainWithRerun $ testGroup "HIE"

51+ [ testSession "open close" $ do

52+ doc <- openDoc' "Testing.hs" "haskell" ""

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

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

55+ closeDoc doc

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

57+ , initializeResponseTests

58+ , completionTests

59+ , cppTests

60+ , diagnosticTests

61+ , codeActionTests

62+ , codeLensesTests

63+ , outlineTests

64+ , findDefinitionAndHoverTests

65+ , pluginTests

66+ , preprocessorTests

67+ , thTests

68+ , safeTests

69+ , unitTests

70+ , haddockTests

71+ , positionMappingTests

72+ , watchedFilesTests

73+ , cradleTests

74+ ]

8175

8276initializeResponseTests :: TestTree

8377initializeResponseTests = withResource acquire release tests where

@@ -112,7 +106,7 @@ initializeResponseTests = withResource acquire release tests where

112106 , chk "NO doc link" _documentLinkProvider Nothing

113107 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

114108 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

109+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

116110 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

117111 , chk "NO experimental" _experimental Nothing

118112 ] where

@@ -128,17 +122,8 @@ initializeResponseTests = withResource acquire release tests where

128122 chk title getActual expected =

129123 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

130124

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−

140125 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

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

126+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

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

143128

144129 acquire :: IO InitializeResponse

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

152137diagnosticTests = testGroup "diagnostics"

153138 [ testSessionWait "fix syntax error" $ do

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

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

140+ doc <- openDoc' "Testing.hs" "haskell" content

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

157142 let change = TextDocumentContentChangeEvent

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

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

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

164149 , testSessionWait "introduce syntax error" $ do

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

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

151+ doc <- openDoc' "Testing.hs" "haskell" content

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

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

169154 let change = TextDocumentContentChangeEvent

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

181166 , "bar :: Int -> Int -> Int"

182167 , "bar a b = cd + b"

183168 ]

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

169+ _ <- openDoc' "Testing.hs" "haskell" content

185170 expectDiagnostics

186171 [ ( "Testing.hs"

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

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

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

196181 , "foo a b = a + b"

197182 ]

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

183+ _ <- openDoc' "Testing.hs" "haskell" content

199184 expectDiagnostics

200185 [ ( "Testing.hs"

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

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

207192 , "foo :: Int -> String"

208193 , "foo a = _ a"

209194 ]

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

195+ _ <- openDoc' "Testing.hs" "haskell" content

211196 expectDiagnostics

212197 [ ( "Testing.hs"

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

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

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

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

231216 deferralTest title binding msg = testSessionWait title $ do

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

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

217+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding

218+ _ <- openDoc' "B.hs" "haskell" sourceB

234219 expectDiagnostics $ expectedDs msg

235220 in

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

237222 , deferralTest "typed hole" "_" "Found hole"

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

224+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"

239225 ]

240226

241227 , testSessionWait "remove required module" $ do

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

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

229+ docA <- openDoc' "ModuleA.hs" "haskell" contentA

244230 let contentB = T.unlines

245231 [ "module ModuleB where"

246232 , "import ModuleA"

247233 ]

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

234+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

249235 let change = TextDocumentContentChangeEvent

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

251237 , _rangeLength = Nothing

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

258244 [ "module ModuleB where"

259245 , "import ModuleA"

260246 ]

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

247+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

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

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

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

250+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

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

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

267253 let contentB = T.unlines

268254 [ "module ModuleB where"

269255 , "import ModuleA"

270256 ]

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

257+ _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

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

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

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

260+ _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

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

276262 , testSessionWait "cyclic module dependency" $ do

277263 let contentA = T.unlines

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

282268 [ "module ModuleB where"

283269 , "import ModuleA"

284270 ]

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

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

271+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

272+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

287273 expectDiagnostics

288274 [ ( "ModuleA.hs"

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

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

304290 let contentBboot = T.unlines

305291 [ "module ModuleB where"

306292 ]

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

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

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

293+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

294+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

295+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

310296 expectDiagnostics []

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

312298 let contentB = T.unlines

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

328314 -- resolved to the hs-boot file

329315 , "y = x"

330316 ]

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

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

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

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

317+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

318+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

319+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

320+ _ <- openDoc' "ModuleC.hs" "haskell" contentC

335321 expectDiagnostics []

336322 , testSessionWait "redundant import" $ do

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

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

340326 , "module ModuleB where"

341327 , "import ModuleA"

342328 ]

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

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

329+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

330+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

345331 expectDiagnostics

346332 [ ( "ModuleB.hs"

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

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

363349 , "wrong1 = ThisList.map"

364350 , "wrong2 = BaseList.x"

365351 ]

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

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

352+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

353+ _ <- openDoc' "Main.hs" "haskell" mainContent

368354 expectDiagnostics

369355 [ ( "Main.hs"

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

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

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

380366 , "foo a = 1"

381367 ]

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

368+ _ <- openDoc' "Foo.hs" "haskell" fooContent

383369 expectDiagnostics

384370 [ ( "Foo.hs"

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

@@ -404,14 +390,14 @@ diagnosticTests = testGroup "diagnostics"

404390 Just pathB <- pure $ uriToFilePath uriB

405391 uriB <- pure $

406392 let (drive, suffix) = splitDrive pathB

407− in filePathToUri (joinDrive (lower drive) suffix)

393+ in filePathToUri (joinDrive (map toLower drive ) suffix)

408394 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

409395 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

410396 uriA <- getDocUri "A/A.hs"

411397 Just pathA <- pure $ uriToFilePath uriA

412398 uriA <- pure $

413399 let (drive, suffix) = splitDrive pathA

414− in filePathToUri (joinDrive (lower drive) suffix)

400+ in filePathToUri (joinDrive (map toLower drive ) suffix)

415401 let itemA = TextDocumentItem uriA "haskell" 0 aContent

416402 let a = TextDocumentIdentifier uriA

417403 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

@@ -424,38 +410,6 @@ diagnosticTests = testGroup "diagnostics"

424410 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

425411 assertFailure ("Expected redundant import but got " <> T.unpack msg)

426412 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

459413 ]

460414

461415codeActionTests :: TestTree

@@ -481,26 +435,26 @@ codeLensesTests = testGroup "code lenses"

481435watchedFilesTests :: TestTree

482436watchedFilesTests = testGroup "watched files"

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

484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

487−

488− -- Expect 4 subscriptions (A does not get any because it's VFS):

489− -- - /path-to-workspace/WatchedFilesMissingModule.hs

490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs

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

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

493− liftIO $ length watchedFileRegs @?= 4

438+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"

439+ _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"

440+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

441+

442+ -- Expect 6 subscriptions (A does not get any because it's VFS):

443+ -- - /path-to-workspace/B.hs

444+ -- - /path-to-workspace/B.lhs

445+ -- - B.hs

446+ -- - B.lhs

447+ -- - src/B.hs

448+ -- - src/B.lhs

449+ liftIO $ length watchedFileRegs @?= 6

494450

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

496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

452+ liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

453+ _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"

454+ watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

499455

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

503− liftIO $ length watchedFileRegs @?= 2

456+ -- Expect 4 subscriptions:

457+ liftIO $ length watchedFileRegs @?= 4

504458

505459 -- TODO add a test for didChangeWorkspaceFolder

506460 ]

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

513467 , "foo :: Int -> Int"

514468 , "foo argName = argNme"

515469 ]

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

470+ doc <- openDoc' "Testing.hs" "haskell" content

517471 _ <- waitForDiagnostics

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

519473 executeCodeAction action

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

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

532486 , "foo = maybToList"

533487 ]

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

488+ doc <- openDoc' "Testing.hs" "haskell" content

535489 _ <- waitForDiagnostics

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

537491 executeCodeAction action

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

549503 , "foo :: Char -> Char -> Char -> Char"

550504 , "foo argument1 argument2 argument3 = argumentX"

551505 ]

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

506+ doc <- openDoc' "Testing.hs" "haskell" content

553507 _ <- waitForDiagnostics

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

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

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

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

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

563517 ]

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

518+ doc <- openDoc' "Testing.hs" "haskell" content

565519 _ <- waitForDiagnostics

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

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

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

584538 , "func :: _"

585539 , "func x = x"

586540 ]

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

541+ doc <- openDoc' "Testing.hs" "haskell" content

588542 _ <- waitForDiagnostics

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

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

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

604558 , "func :: _"

605559 , "func x y = x + y"

606560 ]

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

561+ doc <- openDoc' "Testing.hs" "haskell" content

608562 _ <- waitForDiagnostics

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

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

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

627581 , " y = x * 2"

628582 , " in y"

629583 ]

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

584+ doc <- openDoc' "Testing.hs" "haskell" content

631585 _ <- waitForDiagnostics

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

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

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

652606 let contentA = T.unlines

653607 [ "module ModuleA where"

654608 ]

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

609+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

656610 let contentB = T.unlines

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

658612 , "module ModuleB where"

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

660614 , "stuffB :: Integer"

661615 , "stuffB = 123"

662616 ]

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

617+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

664618 _ <- waitForDiagnostics

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

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

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

678632 let contentA = T.unlines

679633 [ "module ModuleA where"

680634 ]

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

635+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

682636 let contentB = T.unlines

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

684638 , "module ModuleB where"

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

686640 , "stuffB :: Integer"

687641 , "stuffB = 123"

688642 ]

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

643+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

690644 _ <- waitForDiagnostics

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

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

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

708662 , "stuffB = 123"

709663 , "stuffC = ()"

710664 ]

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

665+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

712666 let contentB = T.unlines

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

714668 , "module ModuleB where"

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

716670 , "main = print stuffB"

717671 ]

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

672+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

719673 _ <- waitForDiagnostics

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

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

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

737691 , "stuffB :: Integer"

738692 , "stuffB = 123"

739693 ]

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

694+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

741695 let contentB = T.unlines

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

743697 , "module ModuleB where"

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

745699 , "main = print A.stuffB"

746700 ]

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

701+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

748702 _ <- waitForDiagnostics

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

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

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

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

707+#else

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

709+#endif

752710 executeCodeAction action

753711 contentAfterAction <- documentContents docB

754712 let expectedContentAfterAction = T.unlines

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

765723 , "stuffB :: Integer"

766724 , "stuffB = 123"

767725 ]

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

726+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

769727 let contentB = T.unlines

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

771729 , "module ModuleB where"

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

773731 , "main = print stuffB"

774732 ]

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

733+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

776734 _ <- waitForDiagnostics

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

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

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

792750 , "data D = A | B"

793751 , "data E = F"

794752 ]

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

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

796754 let contentB = T.unlines

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

798756 , "module ModuleB where"

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

800758 , "main = B"

801759 ]

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

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

803761 _ <- waitForDiagnostics

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

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

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

940898 ]

941899 where

942900 template contentA contentB range expectedAction expectedContentB = do

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

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

901+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

902+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

945903 _ <- waitForDiagnostics

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

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

@@ -981,8 +939,6 @@ suggestImportTests = testGroup "suggest import actions"

981939 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"

982940 , test True [] "f = pack" [] "import Data.Text (pack)"

983941 , 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 ((&))"

986942 ]

987943 ]

988944 where

@@ -991,20 +947,19 @@ suggestImportTests = testGroup "suggest import actions"

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

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

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

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

950+ doc <- openDoc' "Test.hs" "haskell" before

995951 _diags <- waitForDiagnostics

996952 let defLine = length imps + 1

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

998954 actions <- getCodeActions doc range

999− if wanted

1000− then do

1001− action <- liftIO $ pickActionWithTitle newImp actions

1002− executeCodeAction action

1003− contentAfterAction <- documentContents doc

1004− liftIO $ after @=? contentAfterAction

1005− else

1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

1007−

955+ case wanted of

956+ False ->

957+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

958+ True -> do

959+ action <- liftIO $ pickActionWithTitle newImp actions

960+ executeCodeAction action

961+ contentAfterAction <- documentContents doc

962+ liftIO $ after @=? contentAfterAction

1008963

1009964addExtensionTests :: TestTree

1010965addExtensionTests = testGroup "add language extension actions"

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

10511006 ]

10521007 where

10531008 template initialContent range expectedAction expectedContents = do

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

1009+ doc <- openDoc' "Module.hs" "haskell" initialContent

10551010 _ <- waitForDiagnostics

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

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

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

10741029 [""

10751030 ,"someOtherCode = ()"

10761031 ]

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

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

10781033 _ <- waitForDiagnostics

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

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

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

10981053 [""

10991054 ,"someOtherCode = ()"

11001055 ]

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

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

11021057 _ <- waitForDiagnostics

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

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

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

11371092 ]

11381093 where

11391094 template contentA contentB range expectedAction expectedContentB = do

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

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

1095+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1096+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

11421097 _diags <- waitForDiagnostics

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

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

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

11571112 [ "module Testing where"

11581113 , "import Data.Mape"

11591114 ]

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

1115+ doc <- openDoc' "Testing.hs" "haskell" content

11611116 _ <- waitForDiagnostics

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

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

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

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

11951150 let originalCode = sourceCode oldA oldB oldC

11961151 let expectedCode = sourceCode newA newB newC

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

1152+ doc <- openDoc' "Testing.hs" "haskell" originalCode

11981153 _ <- waitForDiagnostics

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

12001155 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

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

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

12431198 let originalCode = before def

12441199 let expectedCode = after' def sig

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

1200+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

12461201 _ <- waitForDiagnostics

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

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

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

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

12751230 let originalCode = before withMissing def

12761231 let expectedCode = after' withMissing def sig

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

1232+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

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

12791234 executeCommand c

12801235 modifiedCode <- getDocumentEdit doc

@@ -1296,36 +1251,33 @@ addSigLensesTests = let

12961251 ]

12971252 ]

12981253

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

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

1301−

1302− check (ExpectRange expectedRange) = do

1303− assertNDefinitionsFound 1 defs

1304− assertRangeCorrect (head defs) expectedRange

1305− check (ExpectLocation expectedLocation) = do

1306− assertNDefinitionsFound 1 defs

1307− liftIO $ head defs @?= expectedLocation

1308− check ExpectNoDefinitions = do

1309− assertNDefinitionsFound 0 defs

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

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

1312−

1313− assertNDefinitionsFound :: Int -> [a] -> Session ()

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

1315−

1316− assertRangeCorrect Location{_range = foundRange} expectedRange =

1317− liftIO $ expectedRange @=? foundRange

1318−

1319−

13201254findDefinitionAndHoverTests :: TestTree

13211255findDefinitionAndHoverTests = let

13221256

1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324− doc <- openTestDataDoc (dir </> sourceFilePath)

1257+ tst (get, check) pos targetRange title = testSession title $ do

1258+ doc <- openTestDataDoc sourceFilePath

13251259 found <- get doc pos

13261260 check found targetRange

13271261

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

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

13281264

1265+ check (ExpectRange expectedRange) = do

1266+ assertNDefinitionsFound 1 defs

1267+ assertRangeCorrect (head defs) expectedRange

1268+ check (ExpectLocation expectedLocation) = do

1269+ assertNDefinitionsFound 1 defs

1270+ liftIO $ head defs @?= expectedLocation

1271+ check ExpectNoDefinitions = do

1272+ assertNDefinitionsFound 0 defs

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

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

1275+

1276+ assertNDefinitionsFound :: Int -> [a] -> Session ()

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

1278+

1279+ assertRangeCorrect Location{_range = foundRange} expectedRange =

1280+ liftIO $ expectedRange @=? foundRange

13291281

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

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

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

13711323

13721324 mkFindTests tests = testGroup "get"

13731325 [ testGroup "definition" $ mapMaybe fst tests

1374− , testGroup "hover" $ mapMaybe snd tests

1375− , checkFileCompiles sourceFilePath ]

1326+ , testGroup "hover" $ mapMaybe snd tests ]

13761327

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

13781329

@@ -1467,17 +1418,8 @@ findDefinitionAndHoverTests = let

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

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

14691420

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−

14781421pluginTests :: TestTree

1479−pluginTests = (`xfail8101` "known broken (#556)")

1480− $ testSessionWait "plugins" $ do

1422+pluginTests = testSessionWait "plugins" $ do

14811423 let content =

14821424 T.unlines

14831425 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

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

14911433 , "foo :: Int -> Int -> Int"

14921434 , "foo a b = a + c"

14931435 ]

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

1436+ _ <- openDoc' "Testing.hs" "haskell" content

14951437 expectDiagnostics

14961438 [ ( "Testing.hs",

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

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

15181460 run $ expectError content (2, 1)

15191461 )

15201462 , testSessionWait "cpp-ghcide" $ do

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

1463+ _ <- openDoc' "A.hs" "haskell" $ T.unlines

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

15231465 ,"main ="

15241466 ,"#ifdef __GHCIDE__"

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

15321474 where

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

15341476 expectError content cursor = do

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

1477+ _ <- openDoc' "Testing.hs" "haskell" content

15361478 expectDiagnostics

15371479 [ ( "Testing.hs",

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

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

15481490 , "module Testing where"

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

15501492 ]

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

1493+ _ <- openDoc' "Testing.hs" "haskell" content

15521494 expectDiagnostics

15531495 [ ( "Testing.hs",

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

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

15811523 ,"safeId = trustWorthyId"

15821524 ]

15831525

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

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

1526+ _ <- openDoc' "A.hs" "haskell" sourceA

1527+ _ <- openDoc' "B.hs" "haskell" sourceB

15861528 expectNoMoreDiagnostics 1 ]

15871529

15881530thTests :: TestTree

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

16101552 "b :: Integer",

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

16121554 ]

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

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

1555+ _ <- openDoc' "A.hs" "haskell" sourceA

1556+ _ <- openDoc' "B.hs" "haskell" sourceB

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

16161558 , testSessionWait "newtype-closure" $ do

16171559 let sourceA =

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

16311573 ,"import A"

16321574 ,"b :: Int"

16331575 ,"b = $( a )" ]

1634− _ <- createDoc "A.hs" "haskell" sourceA

1635− _ <- createDoc "B.hs" "haskell" sourceB

1576+ _ <- openDoc' "A.hs" "haskell" sourceA

1577+ _ <- openDoc' "B.hs" "haskell" sourceB

16361578 return ()

16371579 ]

16381580

@@ -1641,7 +1583,7 @@ completionTests

16411583 = testGroup "completion"

16421584 [ testSessionWait "variable" $ do

16431585 let source = T.unlines ["module A where", "f = hea"]

1644− docId <- createDoc "A.hs" "haskell" source

1586+ docId <- openDoc' "A.hs" "haskell" source

16451587 compls <- getCompletions docId (Position 1 7)

16461588 liftIO $ map dropDocs compls @?=

16471589 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1653,7 +1595,7 @@ completionTests

16531595 ]

16541596 , testSessionWait "constructor" $ do

16551597 let source = T.unlines ["module A where", "f = Tru"]

1656− docId <- createDoc "A.hs" "haskell" source

1598+ docId <- openDoc' "A.hs" "haskell" source

16571599 compls <- getCompletions docId (Position 1 7)

16581600 liftIO $ map dropDocs compls @?=

16591601 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1665,7 +1607,7 @@ completionTests

16651607 ]

16661608 , testSessionWait "type" $ do

16671609 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1668− docId <- createDoc "A.hs" "haskell" source

1610+ docId <- openDoc' "A.hs" "haskell" source

16691611 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

16701612 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

16711613 compls <- getCompletions docId (Position 2 7)

@@ -1682,7 +1624,7 @@ completionTests

16821624 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

16831625 , testSessionWait "qualified" $ do

16841626 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1685− docId <- createDoc "A.hs" "haskell" source

1627+ docId <- openDoc' "A.hs" "haskell" source

16861628 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

16871629 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

16881630 compls <- getCompletions docId (Position 2 15)

@@ -1696,7 +1638,7 @@ completionTests

16961638 ]

16971639 , testSessionWait "keyword" $ do

16981640 let source = T.unlines ["module A where", "f = newty"]

1699− docId <- createDoc "A.hs" "haskell" source

1641+ docId <- openDoc' "A.hs" "haskell" source

17001642 compls <- getCompletions docId (Position 1 9)

17011643 liftIO $ compls @?= [keywordItem "newtype"]

17021644 , testSessionWait "type context" $ do

@@ -1705,7 +1647,7 @@ completionTests

17051647 , "module A () where"

17061648 , "f = f"

17071649 ]

1708− docId <- createDoc "A.hs" "haskell" source

1650+ docId <- openDoc' "A.hs" "haskell" source

17091651 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

17101652 changeDoc docId

17111653 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

@@ -1773,7 +1715,7 @@ outlineTests = testGroup

17731715 "outline"

17741716 [ testSessionWait "type class" $ do

17751717 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1776− docId <- createDoc "A.hs" "haskell" source

1718+ docId <- openDoc' "A.hs" "haskell" source

17771719 symbols <- getDocumentSymbols docId

17781720 liftIO $ symbols @?= Left

17791721 [ moduleSymbol

@@ -1786,7 +1728,7 @@ outlineTests = testGroup

17861728 ]

17871729 , testSessionWait "type class instance " $ do

17881730 let source = T.unlines ["class A a where", "instance A () where"]

1789− docId <- createDoc "A.hs" "haskell" source

1731+ docId <- openDoc' "A.hs" "haskell" source

17901732 symbols <- getDocumentSymbols docId

17911733 liftIO $ symbols @?= Left

17921734 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1794,7 +1736,7 @@ outlineTests = testGroup

17941736 ]

17951737 , testSessionWait "type family" $ do

17961738 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1797− docId <- createDoc "A.hs" "haskell" source

1739+ docId <- openDoc' "A.hs" "haskell" source

17981740 symbols <- getDocumentSymbols docId

17991741 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

18001742 , testSessionWait "type family instance " $ do

@@ -1803,7 +1745,7 @@ outlineTests = testGroup

18031745 , "type family A a"

18041746 , "type instance A () = ()"

18051747 ]

1806− docId <- createDoc "A.hs" "haskell" source

1748+ docId <- openDoc' "A.hs" "haskell" source

18071749 symbols <- getDocumentSymbols docId

18081750 liftIO $ symbols @?= Left

18091751 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1811,7 +1753,7 @@ outlineTests = testGroup

18111753 ]

18121754 , testSessionWait "data family" $ do

18131755 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1814− docId <- createDoc "A.hs" "haskell" source

1756+ docId <- openDoc' "A.hs" "haskell" source

18151757 symbols <- getDocumentSymbols docId

18161758 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

18171759 , testSessionWait "data family instance " $ do

@@ -1820,7 +1762,7 @@ outlineTests = testGroup

18201762 , "data family A a"

18211763 , "data instance A () = A ()"

18221764 ]

1823− docId <- createDoc "A.hs" "haskell" source

1765+ docId <- openDoc' "A.hs" "haskell" source

18241766 symbols <- getDocumentSymbols docId

18251767 liftIO $ symbols @?= Left

18261768 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1828,36 +1770,36 @@ outlineTests = testGroup

18281770 ]

18291771 , testSessionWait "constant" $ do

18301772 let source = T.unlines ["a = ()"]

1831− docId <- createDoc "A.hs" "haskell" source

1773+ docId <- openDoc' "A.hs" "haskell" source

18321774 symbols <- getDocumentSymbols docId

18331775 liftIO $ symbols @?= Left

18341776 [docSymbol "a" SkFunction (R 0 0 0 6)]

18351777 , testSessionWait "pattern" $ do

18361778 let source = T.unlines ["Just foo = Just 21"]

1837− docId <- createDoc "A.hs" "haskell" source

1779+ docId <- openDoc' "A.hs" "haskell" source

18381780 symbols <- getDocumentSymbols docId

18391781 liftIO $ symbols @?= Left

18401782 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

18411783 , testSessionWait "pattern with type signature" $ do

18421784 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1843− docId <- createDoc "A.hs" "haskell" source

1785+ docId <- openDoc' "A.hs" "haskell" source

18441786 symbols <- getDocumentSymbols docId

18451787 liftIO $ symbols @?= Left

18461788 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

18471789 , testSessionWait "function" $ do

18481790 let source = T.unlines ["a x = ()"]

1849− docId <- createDoc "A.hs" "haskell" source

1791+ docId <- openDoc' "A.hs" "haskell" source

18501792 symbols <- getDocumentSymbols docId

18511793 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

18521794 , testSessionWait "type synonym" $ do

18531795 let source = T.unlines ["type A = Bool"]

1854− docId <- createDoc "A.hs" "haskell" source

1796+ docId <- openDoc' "A.hs" "haskell" source

18551797 symbols <- getDocumentSymbols docId

18561798 liftIO $ symbols @?= Left

18571799 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

18581800 , testSessionWait "datatype" $ do

18591801 let source = T.unlines ["data A = C"]

1860− docId <- createDoc "A.hs" "haskell" source

1802+ docId <- openDoc' "A.hs" "haskell" source

18611803 symbols <- getDocumentSymbols docId

18621804 liftIO $ symbols @?= Left

18631805 [ docSymbolWithChildren "A"

@@ -1865,21 +1807,9 @@ outlineTests = testGroup

18651807 (R 0 0 0 10)

18661808 [docSymbol "C" SkConstructor (R 0 9 0 10)]

18671809 ]

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− ]

18801810 , testSessionWait "import" $ do

18811811 let source = T.unlines ["import Data.Maybe"]

1882− docId <- createDoc "A.hs" "haskell" source

1812+ docId <- openDoc' "A.hs" "haskell" source

18831813 symbols <- getDocumentSymbols docId

18841814 liftIO $ symbols @?= Left

18851815 [docSymbolWithChildren "imports"

@@ -1890,7 +1820,7 @@ outlineTests = testGroup

18901820 ]

18911821 , testSessionWait "multiple import" $ do

18921822 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1893− docId <- createDoc "A.hs" "haskell" source

1823+ docId <- openDoc' "A.hs" "haskell" source

18941824 symbols <- getDocumentSymbols docId

18951825 liftIO $ symbols @?= Left

18961826 [docSymbolWithChildren "imports"

@@ -1905,7 +1835,7 @@ outlineTests = testGroup

19051835 [ "{-# language ForeignFunctionInterface #-}"

19061836 , "foreign import ccall \"a\" a :: Int"

19071837 ]

1908− docId <- createDoc "A.hs" "haskell" source

1838+ docId <- openDoc' "A.hs" "haskell" source

19091839 symbols <- getDocumentSymbols docId

19101840 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

19111841 , testSessionWait "foreign export" $ do

@@ -1913,7 +1843,7 @@ outlineTests = testGroup

19131843 [ "{-# language ForeignFunctionInterface #-}"

19141844 , "foreign export ccall odd :: Int -> Bool"

19151845 ]

1916− docId <- createDoc "A.hs" "haskell" source

1846+ docId <- openDoc' "A.hs" "haskell" source

19171847 symbols <- getDocumentSymbols docId

19181848 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

19191849 ]

@@ -1926,8 +1856,6 @@ outlineTests = testGroup

19261856 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

19271857 docSymbolWithChildren name kind loc cc =

19281858 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)

19311859 moduleSymbol name loc cc = DocumentSymbol name

19321860 Nothing

19331861 SkFile

@@ -1949,13 +1877,6 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

19491877xfail :: TestTree -> String -> TestTree

19501878xfail = flip expectFailBecause

19511879

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−

19591880data Expect

19601881 = ExpectRange Range -- Both gotoDef and hover should report this range

19611882 | ExpectLocation Location

@@ -2033,7 +1954,6 @@ cradleTests :: TestTree

20331954cradleTests = testGroup "cradle"

20341955 [testGroup "dependencies" [sessionDepsArePickedUp]

20351956 ,testGroup "loading" [loadCradleOnlyonce]

2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

20371957 ]

20381958

20391959loadCradleOnlyonce :: TestTree

@@ -2048,53 +1968,17 @@ loadCradleOnlyonce = testGroup "load cradle only once"

20481968 test dir

20491969 implicit dir = test dir

20501970 test _dir = do

2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

1971+ doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"

20521972 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

20531973 liftIO $ length msgs @?= 1

20541974 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

20551975 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

20561976 liftIO $ length msgs @?= 0

2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

1977+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"

20581978 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

20591979 liftIO $ length msgs @?= 0

20601980

20611981

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−

20981982cradleLoadedMessage :: Session FromServerMessage

20991983cradleLoadedMessage = satisfy $ \case

21001984 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

@@ -2103,56 +1987,6 @@ cradleLoadedMessage = satisfy $ \case

21031987cradleLoadedMethod :: T.Text

21041988cradleLoadedMethod = "ghcide/cradle/loaded"

21051989

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−

21561990sessionDepsArePickedUp :: TestTree

21571991sessionDepsArePickedUp = testSession'

21581992 "session-deps-are-picked-up"

@@ -2162,7 +1996,7 @@ sessionDepsArePickedUp = testSession'

21621996 (dir </> "hie.yaml")

21631997 "cradle: {direct: {arguments: []}}"

21641998 -- Open without OverloadedStrings and expect an error.

2165− doc <- createDoc "Foo.hs" "haskell" fooContent

1999+ doc <- openDoc' "Foo.hs" "haskell" fooContent

21662000 expectDiagnostics

21672001 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

21682002 -- Update hie.yaml to enable OverloadedStrings.

@@ -2197,9 +2031,6 @@ sessionDepsArePickedUp = testSession'

21972031testSession :: String -> Session () -> TestTree

21982032testSession name = testCase name . run

21992033

2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202−

22032034testSession' :: String -> (FilePath -> Session ()) -> TestTree

22042035testSession' name = testCase name . run'

22052036

@@ -2234,19 +2065,6 @@ mkRange a b c d = Range (Position a b) (Position c d)

22342065run :: Session a -> IO a

22352066run s = withTempDir $ \dir -> runInDir dir s

22362067

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−

22502068run' :: (FilePath -> Session a) -> IO a

22512069run' s = withTempDir $ \dir -> runInDir dir (s dir)

22522070

@@ -2258,6 +2076,11 @@ runInDir dir s = do

22582076 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

22592077 createDirectoryIfMissing True $ dir ++ "/Data"

22602078

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)

22612084

22622085 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

22632086 -- HIE calls getXgdDirectory which assumes that HOME is set.

@@ -2276,7 +2099,7 @@ runInDir dir s = do

22762099openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

22772100openTestDataDoc path = do

22782101 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2279− createDoc path "haskell" source

2102+ openDoc' path "haskell" source

22802103

22812104findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

22822105findCodeActions doc range expectedTitles = do

@@ -2317,6 +2140,20 @@ unitTests = do

23172140 uriToFilePath' uri @?= Just ""

23182141 ]

23192142

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+

23202157positionMappingTests :: TestTree

23212158positionMappingTests =

23222159 testGroup "position mapping"

@@ -2486,11 +2323,11 @@ nthLine i r

24862323 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

24872324 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

24882325

2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2490−getWatchedFilesSubscriptionsUntil = do

2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

2326+getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]

2327+getWatchedFilesSubscriptionsUntilProgressEnd = do

2328+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

24922329 return

24932330 [ args

2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs

2331+ | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs

24952332 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

24962333 ]

test/src/Development/IDE/Test.hs+21−4

@@ -16,9 +16,10 @@ import Control.Applicative.Combinators

1616import Control.Lens hiding (List)

1717import Control.Monad

1818import Control.Monad.IO.Class

19+import Data.Foldable

1920import qualified Data.Map.Strict as Map

2021import qualified Data.Text as T

21−import Language.Haskell.LSP.Test hiding (message)

22+import Language.Haskell.LSP.Test hiding (message, openDoc')

2223import qualified Language.Haskell.LSP.Test as LspTest

2324import Language.Haskell.LSP.Types

2425import Language.Haskell.LSP.Types.Lens as Lsp

@@ -73,14 +74,17 @@ expectNoMoreDiagnostics timeout = do

7374 ignoreOthers = void anyMessage >> handleMessages

7475

7576expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

76−expectDiagnostics expected = do

77+expectDiagnostics = expectDiagnostics' diagnostic

78+

79+expectDiagnostics' :: Session PublishDiagnosticsNotification -> [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()

80+expectDiagnostics' messageParser expected = do

7781 expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) (fmap toNormalizedUri . getDocUri) expected

7882 go expected'

7983 where

8084 go m

8185 | Map.null m = pure ()

8286 | otherwise = do

83− diagsNot <- skipManyTill anyMessage diagnostic

87+ diagsNot <- skipManyTill anyMessage messageParser

8488 let fileUri = diagsNot ^. params . uri

8589 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

8690 Nothing -> do

@@ -99,8 +103,21 @@ expectDiagnostics expected = do

99103 " but got " <> show actual

100104 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

101105

106+-- | Matches all diagnostic messages expect those from interface loading files

102107diagnostic :: Session PublishDiagnosticsNotification

103−diagnostic = LspTest.message

108+diagnostic = do

109+ m <- LspTest.message

110+ let PublishDiagnosticsParams uri diags = _params (m :: PublishDiagnosticsNotification)

111+ let diags' = filter (\d -> _source (d:: Diagnostic) /= Just "interface file loading") (toList diags)

112+ -- interface loading warnings get sent on a first message,

113+ -- followed up by a second message including all other warnings.

114+ -- unless the debouncer merges them.

115+ -- This can lead to a test matching on the first message and missing

116+ -- the interesting warnings.

117+ -- Therefore we do not match messages containing only interface loading warnings,

118+ -- but, importantly, do match messages containing no warnings.

119+ guard (null diags || not (null diags'))

120+ return $ (m :: PublishDiagnosticsNotification){_params = PublishDiagnosticsParams uri (List diags')}

104121

105122standardizeQuotes :: T.Text -> T.Text

106123standardizeQuotes msg = let