master..a2e091c · ghcide

git.iko.soy/ghcide

44 files changed+712−1638

unifiedsplit

.azure/linux-stack.yml+2−6 .azure/windows-stack.yml−1 .ghci+25 .gitignore−1 .hlint.yaml+1 CHANGELOG.md−20 README.md+1−32 bench/Main.hs−287 exe/Main.hs+62−520 exe/RuleTypes.hs+33 exe/Rules.hs+142 exe/Util.hs+62 exe/Utils.hs−9 ghcide.cabal+8−54 hie.yaml+1−12 src/Development/IDE/Core/Compile.hs+5−23 src/Development/IDE/Core/FileExists.hs+11−15 src/Development/IDE/Core/PositionMapping.hs+10−48 src/Development/IDE/Core/Rules.hs+82−141 src/Development/IDE/Core/Shake.hs+27−38 src/Development/IDE/GHC/Compat.hs+1−19 src/Development/IDE/GHC/Util.hs+8−16 src/Development/IDE/Import/DependencyInformation.hs+2−2 src/Development/IDE/Import/FindImports.hs+14−40 src/Development/IDE/LSP/Outline.hs−12 src/Development/IDE/Types/Diagnostics.hs−4 src/Development/IDE/Types/Options.hs+5−4 stack-ghc-lib.yaml+1−1 stack.yaml+2−2 stack810.yaml+1−2 stack84.yaml+2−2 stack88.yaml+2−2 test/data/Bar.hs+3 test/data/hover/Foo.hs → test/data/Foo.hs test/data/hover/GotoHover.hs → test/data/GotoHover.hs+1−1 test/data/hover/Bar.hs−3 test/data/multi/a/A.hs−3 test/data/multi/a/a.cabal−9 test/data/multi/b/B.hs−3 test/data/multi/b/b.cabal−9 test/data/multi/cabal.project−1 test/data/multi/hie.yaml−6 test/exe/Main.hs+177−286 test/src/Development/IDE/Test.hs+21−4

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

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

3232 ./fmt.sh

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

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

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

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

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

4038 fi

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

4341 displayName: 'stack setup'

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

4543 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

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

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

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

5147 - bash: |

.azure/windows-stack.yml−1

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

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

4747 stack install happy --stack-yaml $STACK_YAML

4848 stack install alex --stack-yaml $STACK_YAML

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

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

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

5251 - 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−1

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

77/.tasty-rerun-log

88.vscode

99/.hlint-*

10−bench/example

.hlint.yaml+1

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

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

7474

7575 # Shady extensions

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

7677 - name: CPP

7778 within:

7879 - Development.IDE.Compat

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+1−32

@@ -25,23 +25,6 @@ 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`

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

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

284267using `stack install ghcide` within a project.

285268

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−

300269## Hacking on ghcide

301270

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

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

325294

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

327296

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

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

329298

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

331300

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+62−520

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

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

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

12298 t <- t

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

124− let options = (defaultIdeOptions $ loadSessionShake dir)

100+ let options = (defaultIdeOptions $ loadSession dir)

125101 { optReportProgress = clientSupportsProgress caps

126102 , optShakeProfiling = argsShakeProfiling

127103 , optTesting = argsTesting

128104 , optThreads = argsThreads

105+ , optInterfaceLoadingDiagnostics = argsTesting

129106 }

130107 debouncer <- newAsyncDebouncer

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

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

132109 getLspId event (logger minBound) debouncer options vfs

133110 else do

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

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

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

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

140117

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

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

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

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

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

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

146123

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

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

148125 cradles <- mapM findCradle files

149126 let ucradles = nubOrd cradles

150127 let n = length ucradles

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

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

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

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

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

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

133+ when (isNothing x) $ print cradle

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

135+ opts <- getComponentOptions cradle

136+ createSession opts

137+

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

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

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

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

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

143+ cradle <- Map.lookup file filesToCradles

144+ Map.lookup cradle cradlesToSessions

145+

146+ let options =

147+ (defaultIdeOptions $ return $ return . grab)

148+ { optShakeProfiling = argsShakeProfiling }

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

150+

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

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

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

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

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

161155 when (failed /= []) $

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

163157

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

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

166− return ()

160+

161+ unless (null failed) exitFailure

162+

163+cradleRules :: Rules ()

164+cradleRules = do

165+ loadGhcSession

166+ cradleToSession

167167

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

169169expandFiles = concatMapM $ \x -> do

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

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

191191showEvent lock e = withLock lock $ print e

192192

193−

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)

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

194+loadSession dir = liftIO $ do

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

196+ res <- findCradle v

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

198+ -- try and normalise that

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

200+ res' <- traverse IO.makeAbsolute res

201+ return $ normalise <$> res'

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

203+ session file = do

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

205+ let cradle = toNormalizedFilePath' $ fromMaybe dir file

206+ use_ LoadCradle cradle

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

403208

404209

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−

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

593211--

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

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

605223 res <- onceFork $ op k

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

607225 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+142

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

1+{-# LANGUAGE TemplateHaskell #-}

2+module Rules

3+ ( loadGhcSession

4+ , cradleToSession

5+ , cradleLoadedMethod

6+ , createSession

7+ , getComponentOptions

8+ )

9+where

10+

11+import Control.Exception

12+import Control.Monad (filterM, when)

13+import qualified Crypto.Hash.SHA1 as H

14+import Data.ByteString.Base16 (encode)

15+import qualified Data.ByteString.Char8 as B

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

17+import Data.Text (Text, pack)

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

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

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

21+import Development.IDE.GHC.Util

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

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

24+import Development.Shake

25+import GHC

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

27+import HIE.Bios

28+import HIE.Bios.Cradle

29+import HIE.Bios.Environment (addCmdOpts)

30+import HIE.Bios.Types

31+import Linker (initDynLinker)

32+import RuleTypes

33+import qualified System.Directory.Extra as IO

34+import System.FilePath.Posix (addTrailingPathSeparator,

35+ (</>))

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

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

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

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

40+import Util

41+

42+-- Prefix for the cache path

43+cacheDir :: String

44+cacheDir = "ghcide"

45+

46+notifyCradleLoaded :: FilePath -> LSP.FromServerMessage

47+notifyCradleLoaded fp =

48+ LSP.NotCustomServer $

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

50+ toJSON fp

51+

52+loadGhcSession :: Rules ()

53+loadGhcSession =

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

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

56+ -- the existing session.

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

58+ liftIO $ createSession $ ComponentOptions opts deps

59+

60+cradleToSession :: Rules ()

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

62+

63+ let f = fromNormalizedFilePath nfp

64+

65+ IdeOptions{optTesting} <- getIdeOptions

66+

67+ logger <- actionLogger

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

69+

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

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

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

73+

74+ when optTesting $

75+ sendEvent $ notifyCradleLoaded f

76+

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

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

79+ let opts = componentOptions cmpOpts

80+ deps = componentDependencies cmpOpts

81+ deps' = case mbYaml of

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

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

84+ _ -> deps

85+ existingDeps <- filterM doesFileExist deps'

86+ need existingDeps

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

88+

89+cradleLoadedMethod :: Text

90+cradleLoadedMethod = "ghcide/cradle/loaded"

91+

92+getComponentOptions :: Cradle a -> IO ComponentOptions

93+getComponentOptions cradle = do

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

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

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

97+ case cradleRes of

98+ CradleSuccess r -> pure r

99+ CradleFail err -> throwIO err

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

101+ -- That will require some more changes.

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

103+

104+ghcVersionChecker :: IO VersionCheck

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

106+

107+checkGhcVersion :: IO (Maybe HscEnvEq)

108+checkGhcVersion = do

109+ res <- ghcVersionChecker

110+ case res of

111+ Failure err -> do

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

113+ return Nothing

114+ Mismatch {..} ->

115+ return $ Just GhcVersionMismatch {..}

116+ _ ->

117+ return Nothing

118+

119+createSession :: ComponentOptions -> IO HscEnvEq

120+createSession (ComponentOptions theOpts _) = do

121+ libdir <- getLibdir

122+

123+ cacheDir <- getCacheDir theOpts

124+

125+ runGhc (Just libdir) $ do

126+ dflags <- getSessionDynFlags

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

128+ setupDynFlags cacheDir dflags'

129+ versionMismatch <- liftIO checkGhcVersion

130+ case versionMismatch of

131+ Just mismatch -> return mismatch

132+ Nothing -> do

133+ env <- getSession

134+ liftIO $ initDynLinker env

135+ liftIO $ newHscEnvEq env

136+

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

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

139+ where

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

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

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

exe/Util.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+8−54

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

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

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

191185 main-is: Main.hs

192186 build-depends:

193− time,

194− async,

195187 hslogger,

196188 aeson,

197189 base == 4.*,

@@ -212,16 +204,18 @@ executable ghcide

212204 hashable,

213205 haskell-lsp,

214206 haskell-lsp-types,

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

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

216208 ghcide,

217209 optparse-applicative,

218210 shake,

219211 text,

220212 unordered-containers

221213 other-modules:

222− Utils

223214 Arguments

224215 Paths_ghcide

216+ Rules

217+ RuleTypes

218+ Util

225219

226220 default-extensions:

227221 BangPatterns

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

269263 haskell-lsp-types,

270264 network-uri,

271265 lens,

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

266+ lsp-test >= 0.8,

273267 parser-combinators,

274268 QuickCheck,

275269 quickcheck-instances,

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

302296 TupleSections

303297 TypeApplications

304298 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/Development/IDE/Core/Compile.hs+5−23

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

9090parseModule

9191 :: IdeOptions

9292 -> HscEnv

93− -> [PackageName]

9493 -> FilePath

9594 -> Maybe SB.StringBuffer

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

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

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

9897 fmap (either (, Nothing) id) $

9998 evalGhcEnv env $ runExceptT $ do

10099 (contents, dflags) <- preprocessor filename mbContents

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

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

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

103102

104103

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

500499 :: GhcMonad m

501500 => (GHC.ParsedSource -> IdePreprocessedSource)

502501 -> DynFlags -- ^ flags to use

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

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

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

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

507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

505+parseFileContents customPreprocessor dflags filename contents = do

508506 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

510508#if MIN_GHC_API_VERSION(8,10,0)

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

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

537535 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539− let parsed' = removePackageImports comp_pkgs parsed

540537 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

541− ms <- getModSummaryFromBuffer filename dflags parsed'

538+ ms <- getModSummaryFromBuffer filename dflags parsed

542539 let pm =

543540 ParsedModule {

544541 pm_mod_summary = ms

545− , pm_parsed_source = parsed'

542+ , pm_parsed_source = parsed

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

547544 , pm_annotations = hpm_annotations

548545 }

549546 warnings = diagFromErrMsgs "parser" dflags warns

550547 pure (warnings ++ preproc_warnings, pm)

551548

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−

567549loadHieFile :: FilePath -> IO GHC.HieFile

568550loadHieFile f = do

569551 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/Rules.hs+82−141

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

2828

2929import Fingerprint

3030

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

32−import Data.Bifunctor (first, second)

31+import Data.Binary

32+import Data.Bifunctor (second)

3333import Control.Monad.Extra

3434import Control.Monad.Trans.Class

3535import Control.Monad.Trans.Maybe

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

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

4747import Development.IDE.GHC.Util

4848import Development.IDE.GHC.WithDynFlags

49+import Data.Coerce

4950import Data.Either.Extra

5051import Data.Maybe

5152import Data.Foldable

5253import qualified Data.IntMap.Strict as IntMap

5354import Data.IntMap.Strict (IntMap)

55+import qualified Data.IntSet as IntSet

5456import Data.List

5557import Data.Ord

5658import qualified Data.Set as Set

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

5961import Development.Shake hiding (Diagnostic)

6062import Development.IDE.Core.RuleTypes

6163import Development.IDE.Spans.Type

62−import qualified Data.ByteString.Char8 as BS

6364

6465import qualified GHC.LanguageExtensions as LangExt

6566import HscTypes

66−import PackageConfig

6767import DynFlags (gopt_set, xopt)

6868import GHC.Generics(Generic)

6969

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

7171import Development.IDE.Core.Service

7272import Development.IDE.Core.Shake

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

73+import Development.Shake.Classes

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

7575import Data.ByteString (ByteString)

7676import Control.Concurrent.Async (concurrently)

7777

78−import Control.Monad.State

79−

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

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

8280-- warnings while also producing a result.

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

143141 hie_f = ml_hie_file $ ms_location ms

144142 mbHieTimestamp <- use GetModificationTime normal_hie_f

145143 srcTimestamp <- use_ GetModificationTime f

144+

146145 let isUpToDate

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

148147 | otherwise = False

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

192191

193192getParsedModuleRule :: Rules ()

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

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

200195 opt <- getIdeOptions

201196 (_, contents) <- getFileContents file

202197

203198 let dflags = hsc_dflags hsc

204− mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

199+ mainParse = getParsedModuleDefinition hsc opt file contents

205200

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

207202 if gopt Opt_Haddock dflags

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

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

212207 haddockParse = do

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

214− getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

209+ getParsedModuleDefinition hscHaddock opt file contents

215210 return diagsHaddock

216211

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

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

222217

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

224219

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)

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

221+getParsedModuleDefinition packageState opt file contents = do

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

228223 case res of

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

230225 Just (contents, modu) -> do

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

238233 define $ \GetLocatedImports file -> do

239234 ms <- use_ GetModSummary file

240235 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

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

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

245238 opt <- getIdeOptions

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

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

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

248241 case diagOrImp of

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

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

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

258251 Nothing -> pure (concat diags, Nothing)

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

260253

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

262−

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

264−execRawDepM act =

265− execStateT act

266− ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty

267− , IntMap.empty

268− )

269−

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

271255-- imports recursively.

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

273−rawDependencyInformation fs = do

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

256+rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

257+rawDependencyInformation f = do

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

259+ (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap

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

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

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

276263 return (rdi { rawBootMap = bm })

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

265+ go fs (rawDepInfo, ss) =

266+ case IntSet.minView fs of

267+ -- Queue is empty

268+ Nothing -> pure (rawDepInfo, ss)

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

270+ Just (f, fs) -> do

271+ let fId = FilePathId f

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

273+ case importsOrErr of

274+ Nothing ->

275+ -- File doesn’t parse

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

277+ in go fs (rawDepInfo', ss)

278+ Just (modImports, pkgImports) -> do

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

280+ -> (a, Maybe ArtifactsLocation)

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

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

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

284+ Just path ->

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

286+ ss' = if isBootLocation path

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

288+ else ss

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

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

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

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

293+ let newFiles =

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

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

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

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

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

299+

300+

346301

347302 updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

348303 if not artifactIsSource

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

360315getDependencyInformationRule :: Rules ()

361316getDependencyInformationRule =

362317 define $ \GetDependencyInformation file -> do

363− rawDepInfo <- rawDependencyInformation [file]

318+ rawDepInfo <- rawDependencyInformation file

364319 pure ([], Just $ processDependencyInformation rawDepInfo)

365320

366321reportImportCyclesRule :: Rules ()

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

471426 setPriority priorityTypeCheck

472427 IdeOptions { optDefer = defer } <- getIdeOptions

473428

474− addUsageDependencies $ liftIO $ do

429+ liftIO $ do

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

476431 case res of

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

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

485440 uses_th_qq dflags =

486441 xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

487442

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−

500443

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

502445generateCore runSimplifier file = do

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

529472instance NFData GhcSessionIO

530473instance Binary GhcSessionIO

531474

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

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

533476instance Show GhcSessionFun where show _ = "GhcSessionFun"

534477instance NFData GhcSessionFun where rnf !_ = ()

535478

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

539482 defineNoFile $ \GhcSessionIO -> do

540483 opts <- getIdeOptions

541484 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

546485 defineEarlyCutoff $ \GhcSession file -> do

547486 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548− alwaysRerun

549487 val <- fun $ fromNormalizedFilePath file

550−

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

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

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

562490

563491getHiFileRule :: Rules ()

564492getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

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

572500 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

573501 _ -> ml_hi_file $ ms_location ms

574502

503+ IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions

504+

505+ let mkInterfaceFilesGenerationDiag f intro

506+ | optInterfaceLoadingDiagnostics = mkDiag $ intro <> msg

507+ | otherwise = []

508+ where

509+ msg =

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

511+ mkDiag = pure

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

513+ . T.pack

514+

575515 case sequence depHis of

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

516+ Nothing -> do

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

518+ pure (Nothing, (d, Nothing))

577519 Just deps -> do

578520 gotHiFile <- getFileExists hiFile

579521 if not gotHiFile

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

522+ then do

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

524+ pure (Nothing, (d, Nothing))

581525 else do

582526 hiVersion <- use_ GetModificationTime hiFile

583527 modVersion <- use_ GetModificationTime f

584528 let sourceModified = modificationTime hiVersion < modificationTime modVersion

585529 if sourceModified

586530 then do

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

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

532+ pure (Nothing, (d, Nothing))

588533 else do

589534 session <- hscEnv <$> use_ GhcSession f

590535 r <- liftIO $ loadInterface session ms deps

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

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

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

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

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

631572 opt <- getIdeOptions

632573 (_, contents) <- getFileContents f

633574 -- Embed --haddocks in the interface file

634575 hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

635− (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents

576+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f contents

636577 case mb_pm of

637578 Nothing -> return (diags, Nothing)

638579 Just pm -> do

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

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

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

513509

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

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

516−newtype A v = A (Value v)

512+-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

513+-- can just remove it?

514+data A v = A (Value v) ShakeValue

517515 deriving Show

518516

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

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

520518

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

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

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

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

527525uses :: IdeRule k v

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

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

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

530528

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

532530usesWithStale :: IdeRule k v

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

534532usesWithStale key files = do

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

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

536534 zipWithM lastValue files values

537535

538536

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

540538withProgress 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

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

545540

546541

547542defineEarlyCutoff

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

558553 case v of

559554 -- No changes in the dependencies and we have

560555 -- an existing result.

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

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

562557 _ -> return Nothing

563558 _ -> return Nothing

564559 case val of

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

589584 return $ RunResult

590585 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

591586 (encodeShakeValue bs) $

592− A res

587+ A res bs

593588

594589

595590-- | Rule type, input file

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

743738newtype Priority = Priority Double

744739

745740setPriority :: Priority -> Action ()

746−setPriority (Priority p) = reschedule p

741+setPriority (Priority p) = deprioritize p

747742

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

749744sendEvent e = do

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

769764type instance RuleResult GetModificationTime = FileVersion

770765

771766data FileVersion

772− = VFSVersion !Int

767+ = VFSVersion Int

773768 | ModificationTime

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

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

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

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

834829

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

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

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

837832 modifyVar_ positionMapping $ \allMappings -> do

838833 let uri = toNormalizedUri _uri

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

835+ let updatedMapping =

836+ Map.insert _version idMapping $

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

847838 pure $! HMap.insert uri updatedMapping allMappings

848− where

849− shared_change = mkDelta changes

src/Development/IDE/GHC/Compat.hs+1−19

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

2626 includePathsQuote,

2727 addIncludePathsQuote,

2828 getModuleHash,

29− getPackageName,

3029 pattern DerivD,

3130 pattern ForD,

3231 pattern InstD,

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

3837 GHC.ModLocation,

3938 Module.addBootSuffix,

4039 pattern ModLocation,

41− getConArgs,

4240

4341 module GHC

4442 ) where

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

4846import FieldLabel

4947import Fingerprint (Fingerprint)

5048import qualified Module

51−import Packages

5249

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

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

6052import qualified HeaderInfo as Hdr

6153import Avail

6254import ErrUtils (ErrorMessages)

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

297289#else

298290getModuleHash = mi_mod_hash

299291#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/Util.hs+8−16

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

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

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

168167data HscEnvEq

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

173169 | GhcVersionMismatch { compileTime :: !Version

174170 , runTime :: !Version

175171 }

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

179175hscEnv = either error id . hscEnv'

180176

181177hscEnv' :: HscEnvEq -> Either String HscEnv

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

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

183179hscEnv' GhcVersionMismatch{..} = Left $

184180 unwords

185181 ["ghcide compiled against GHC"

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

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

190186 ]

191187

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

193−deps (HscEnvEq _ _ u) = u

194−deps GhcVersionMismatch{} = []

195−

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

189+newHscEnvEq :: HscEnv -> IO HscEnvEq

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

199191

200192instance Show HscEnvEq where

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

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

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

203195

204196instance Eq HscEnvEq where

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

197+ HscEnvEq a _ == HscEnvEq b _ = a == b

206198 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207199 _ == _ = False

208200

209201instance NFData HscEnvEq where

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

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

211203 rnf GhcVersionMismatch{} = rnf runTime

212204

213205instance Hashable HscEnvEq where

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

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

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

216208

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

src/Development/IDE/Import/DependencyInformation.hs+2−2

@@ -62,7 +62,7 @@ data ModuleImports = ModuleImports

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

6363 , packageImports :: !(Set InstalledUnitId)

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

65− } deriving Show

65+ }

6666

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

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

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

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

129129 -- appear later in the sort.

130130 , rawBootMap :: !BootIdMap

131− } deriving Show

131+ }

132132

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

134134pkgDependencies RawDependencyInformation{..} =

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/Outline.hs−12

@@ -108,23 +108,11 @@ 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

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

@@ -5,7 +5,7 @@ extra-deps:

55- haskell-lsp-0.22.0.0

66- haskell-lsp-types-0.22.0.0

77- lsp-test-0.10.3.0

8−- hie-bios-0.5.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

stack.yaml+2−2

@@ -4,8 +4,8 @@ packages:

44extra-deps:

55- haskell-lsp-0.22.0.0

66- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.11.0.1

8−- hie-bios-0.5.0

7+- lsp-test-0.10.3.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

stack810.yaml+1−2

@@ -6,9 +6,8 @@ packages:

66extra-deps:

77- haskell-lsp-0.22.0.0

88- haskell-lsp-types-0.22.0.0

9−- lsp-test-0.11.0.1

9+- lsp-test-0.10.3.0

1010- ghc-check-0.3.0.1

11−- hie-bios-0.5.0

1211

1312# for ghc-8.10

1413- Cabal-3.2.0.0

stack84.yaml+2−2

@@ -7,11 +7,11 @@ extra-deps:

77- base-orphans-0.8.2

88- haskell-lsp-0.22.0.0

99- haskell-lsp-types-0.22.0.0

10−- lsp-test-0.11.0.1

10+- lsp-test-0.10.3.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

stack88.yaml+2−2

@@ -4,8 +4,8 @@ packages:

44extra-deps:

55- haskell-lsp-0.22.0.0

66- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.11.0.1

7+- lsp-test-0.10.3.0

88- ghc-check-0.3.0.1

9−- hie-bios-0.5.0

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+177−286

@@ -10,7 +10,7 @@

1010module Main (main) where

1111

1212import Control.Applicative.Combinators

13−import Control.Exception (bracket, catch)

13+import Control.Exception (catch)

1414import qualified Control.Lens as Lens

1515import Control.Monad

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

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

2828import Development.IDE.Test.Runfiles

2929import Development.IDE.Types.Location

3030import Development.Shake (getDirectoryFilesIO)

31−import Language.Haskell.LSP.Test

31+import qualified Language.Haskell.LSP.Test as LSPTest

32+import Language.Haskell.LSP.Test hiding (openDoc')

3233import Language.Haskell.LSP.Messages

3334import Language.Haskell.LSP.Types

3435import Language.Haskell.LSP.Types.Capabilities

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

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

3738import Network.URI

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

39+import System.Environment.Blank (setEnv)

3940import System.FilePath

4041import System.IO.Extra

4142import System.Directory

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

4950import Data.Maybe

5051

5152main :: 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− ]

53+main = defaultMainWithRerun $ testGroup "HIE"

54+ [ testSession "open close" $ do

55+ doc <- openDoc' "Testing.hs" "haskell" ""

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

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

58+ closeDoc doc

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

60+ , initializeResponseTests

61+ , completionTests

62+ , cppTests

63+ , diagnosticTests

64+ , codeActionTests

65+ , codeLensesTests

66+ , outlineTests

67+ , findDefinitionAndHoverTests

68+ , pluginTests

69+ , preprocessorTests

70+ , thTests

71+ , safeTests

72+ , unitTests

73+ , haddockTests

74+ , positionMappingTests

75+ , watchedFilesTests

76+ , cradleTests

77+ ]

8178

8279initializeResponseTests :: TestTree

8380initializeResponseTests = withResource acquire release tests where

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

152149diagnosticTests = testGroup "diagnostics"

153150 [ testSessionWait "fix syntax error" $ do

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

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

152+ doc <- openDoc' "Testing.hs" "haskell" content

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

157154 let change = TextDocumentContentChangeEvent

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

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

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

164161 , testSessionWait "introduce syntax error" $ do

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

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

163+ doc <- openDoc' "Testing.hs" "haskell" content

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

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

169166 let change = TextDocumentContentChangeEvent

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

181178 , "bar :: Int -> Int -> Int"

182179 , "bar a b = cd + b"

183180 ]

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

181+ _ <- openDoc' "Testing.hs" "haskell" content

185182 expectDiagnostics

186183 [ ( "Testing.hs"

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

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

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

196193 , "foo a b = a + b"

197194 ]

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

195+ _ <- openDoc' "Testing.hs" "haskell" content

199196 expectDiagnostics

200197 [ ( "Testing.hs"

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

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

207204 , "foo :: Int -> String"

208205 , "foo a = _ a"

209206 ]

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

207+ _ <- openDoc' "Testing.hs" "haskell" content

211208 expectDiagnostics

212209 [ ( "Testing.hs"

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

@@ -229,8 +226,8 @@ diagnosticTests = testGroup "diagnostics"

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

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

231228 deferralTest title binding msg = testSessionWait title $ do

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

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

229+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding

230+ _ <- openDoc' "B.hs" "haskell" sourceB

234231 expectDiagnostics $ expectedDs msg

235232 in

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

@@ -240,12 +237,12 @@ diagnosticTests = testGroup "diagnostics"

240237

241238 , testSessionWait "remove required module" $ do

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

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

240+ docA <- openDoc' "ModuleA.hs" "haskell" contentA

244241 let contentB = T.unlines

245242 [ "module ModuleB where"

246243 , "import ModuleA"

247244 ]

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

245+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

249246 let change = TextDocumentContentChangeEvent

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

251248 , _rangeLength = Nothing

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

258255 [ "module ModuleB where"

259256 , "import ModuleA"

260257 ]

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

258+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

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

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

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

261+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

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

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

267264 let contentB = T.unlines

268265 [ "module ModuleB where"

269266 , "import ModuleA"

270267 ]

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

268+ _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

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

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

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

271+ _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

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

276273 , testSessionWait "cyclic module dependency" $ do

277274 let contentA = T.unlines

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

282279 [ "module ModuleB where"

283280 , "import ModuleA"

284281 ]

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

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

282+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

283+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

287284 expectDiagnostics

288285 [ ( "ModuleA.hs"

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

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

304301 let contentBboot = T.unlines

305302 [ "module ModuleB where"

306303 ]

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

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

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

304+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

305+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

306+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

310307 expectDiagnostics []

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

312309 let contentB = T.unlines

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

328325 -- resolved to the hs-boot file

329326 , "y = x"

330327 ]

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

328+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

329+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

330+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

331+ _ <- openDoc' "ModuleC.hs" "haskell" contentC

335332 expectDiagnostics []

336333 , testSessionWait "redundant import" $ do

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

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

340337 , "module ModuleB where"

341338 , "import ModuleA"

342339 ]

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

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

340+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

341+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

345342 expectDiagnostics

346343 [ ( "ModuleB.hs"

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

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

363360 , "wrong1 = ThisList.map"

364361 , "wrong2 = BaseList.x"

365362 ]

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

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

363+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

364+ _ <- openDoc' "Main.hs" "haskell" mainContent

368365 expectDiagnostics

369366 [ ( "Main.hs"

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

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

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

380377 , "foo a = 1"

381378 ]

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

379+ _ <- openDoc' "Foo.hs" "haskell" fooContent

383380 expectDiagnostics

384381 [ ( "Foo.hs"

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

@@ -430,7 +427,7 @@ diagnosticTests = testGroup "diagnostics"

430427 , "foo :: Int"

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

432429 ]

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

430+ _ <- openDoc' "Foo.hs" "haskell" fooContent

434431 expectDiagnostics

435432 [ ( "Foo.hs"

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

@@ -445,7 +442,7 @@ diagnosticTests = testGroup "diagnostics"

445442 , "value :: Maybe ()"

446443 , "value = [()]"

447444 ]

448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content

445+ _ <- openDoc' (T.unpack name <> ".hs") "haskell" content

449446 notification <- skipManyTill anyMessage diagnostic

450447 let

451448 offenders =

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

482479watchedFilesTests = testGroup "watched files"

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

484481 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

482+ _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

486483 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

487484

488− -- Expect 4 subscriptions (A does not get any because it's VFS):

485+ -- Expect 6 subscriptions (A does not get any because it's VFS):

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

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

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

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

493− liftIO $ length watchedFileRegs @?= 4

488+ -- - WatchedFilesMissingModule.hs

489+ -- - WatchedFilesMissingModule.lhs

490+ -- - src/WatchedFilesMissingModule.hs

491+ -- - src/WatchedFilesMissingModule.lhs

492+ liftIO $ length watchedFileRegs @?= 6

494493

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

496495 liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

496+ _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

498497 watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

499498

500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

499+ -- Expect 4 subscriptions (/tmp does not get any as it is out of the workspace):

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

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

503− liftIO $ length watchedFileRegs @?= 2

502+ -- - WatchedFilesMissingModule.hs

503+ -- - WatchedFilesMissingModule.lhs

504+ liftIO $ length watchedFileRegs @?= 4

504505

505506 -- TODO add a test for didChangeWorkspaceFolder

506507 ]

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

513514 , "foo :: Int -> Int"

514515 , "foo argName = argNme"

515516 ]

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

517+ doc <- openDoc' "Testing.hs" "haskell" content

517518 _ <- waitForDiagnostics

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

519520 executeCodeAction action

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

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

532533 , "foo = maybToList"

533534 ]

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

535+ doc <- openDoc' "Testing.hs" "haskell" content

535536 _ <- waitForDiagnostics

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

537538 executeCodeAction action

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

549550 , "foo :: Char -> Char -> Char -> Char"

550551 , "foo argument1 argument2 argument3 = argumentX"

551552 ]

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

553+ doc <- openDoc' "Testing.hs" "haskell" content

553554 _ <- waitForDiagnostics

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

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

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

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

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

563564 ]

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

565+ doc <- openDoc' "Testing.hs" "haskell" content

565566 _ <- waitForDiagnostics

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

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

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

584585 , "func :: _"

585586 , "func x = x"

586587 ]

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

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

588589 _ <- waitForDiagnostics

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

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

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

604605 , "func :: _"

605606 , "func x y = x + y"

606607 ]

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

608+ doc <- openDoc' "Testing.hs" "haskell" content

608609 _ <- waitForDiagnostics

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

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

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

627628 , " y = x * 2"

628629 , " in y"

629630 ]

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

631+ doc <- openDoc' "Testing.hs" "haskell" content

631632 _ <- waitForDiagnostics

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

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

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

652653 let contentA = T.unlines

653654 [ "module ModuleA where"

654655 ]

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

656+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

656657 let contentB = T.unlines

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

658659 , "module ModuleB where"

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

660661 , "stuffB :: Integer"

661662 , "stuffB = 123"

662663 ]

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

664+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

664665 _ <- waitForDiagnostics

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

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

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

678679 let contentA = T.unlines

679680 [ "module ModuleA where"

680681 ]

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

682+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

682683 let contentB = T.unlines

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

684685 , "module ModuleB where"

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

686687 , "stuffB :: Integer"

687688 , "stuffB = 123"

688689 ]

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

690+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

690691 _ <- waitForDiagnostics

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

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

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

708709 , "stuffB = 123"

709710 , "stuffC = ()"

710711 ]

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

712+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

712713 let contentB = T.unlines

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

714715 , "module ModuleB where"

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

716717 , "main = print stuffB"

717718 ]

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

719+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

719720 _ <- waitForDiagnostics

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

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

@@ -737,14 +738,14 @@ removeImportTests = testGroup "remove import actions"

737738 , "stuffB :: Integer"

738739 , "stuffB = 123"

739740 ]

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

741+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

741742 let contentB = T.unlines

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

743744 , "module ModuleB where"

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

745746 , "main = print A.stuffB"

746747 ]

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

748+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

748749 _ <- waitForDiagnostics

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

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

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

765766 , "stuffB :: Integer"

766767 , "stuffB = 123"

767768 ]

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

769+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

769770 let contentB = T.unlines

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

771772 , "module ModuleB where"

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

773774 , "main = print stuffB"

774775 ]

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

776+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

776777 _ <- waitForDiagnostics

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

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

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

792793 , "data D = A | B"

793794 , "data E = F"

794795 ]

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

796+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

796797 let contentB = T.unlines

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

798799 , "module ModuleB where"

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

800801 , "main = B"

801802 ]

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

803+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

803804 _ <- waitForDiagnostics

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

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

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

940941 ]

941942 where

942943 template contentA contentB range expectedAction expectedContentB = do

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

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

944+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

945+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

945946 _ <- waitForDiagnostics

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

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

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

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

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

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

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

995+ doc <- openDoc' "Test.hs" "haskell" before

995996 _diags <- waitForDiagnostics

996997 let defLine = length imps + 1

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

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

10511052 ]

10521053 where

10531054 template initialContent range expectedAction expectedContents = do

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

1055+ doc <- openDoc' "Module.hs" "haskell" initialContent

10551056 _ <- waitForDiagnostics

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

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

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

10741075 [""

10751076 ,"someOtherCode = ()"

10761077 ]

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

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

10781079 _ <- waitForDiagnostics

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

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

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

10981099 [""

10991100 ,"someOtherCode = ()"

11001101 ]

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

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

11021103 _ <- waitForDiagnostics

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

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

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

11371138 ]

11381139 where

11391140 template contentA contentB range expectedAction expectedContentB = do

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

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

1141+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1142+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

11421143 _diags <- waitForDiagnostics

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

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

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

11571158 [ "module Testing where"

11581159 , "import Data.Mape"

11591160 ]

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

1161+ doc <- openDoc' "Testing.hs" "haskell" content

11611162 _ <- waitForDiagnostics

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

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

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

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

11951196 let originalCode = sourceCode oldA oldB oldC

11961197 let expectedCode = sourceCode newA newB newC

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

1198+ doc <- openDoc' "Testing.hs" "haskell" originalCode

11981199 _ <- waitForDiagnostics

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

12001201 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

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

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

12431244 let originalCode = before def

12441245 let expectedCode = after' def sig

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

1246+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

12461247 _ <- waitForDiagnostics

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

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

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

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

12751276 let originalCode = before withMissing def

12761277 let expectedCode = after' withMissing def sig

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

1278+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

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

12791280 executeCommand c

12801281 modifiedCode <- getDocumentEdit doc

@@ -1296,36 +1297,33 @@ addSigLensesTests = let

12961297 ]

12971298 ]

12981299

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−

13201300findDefinitionAndHoverTests :: TestTree

13211301findDefinitionAndHoverTests = let

13221302

1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324− doc <- openTestDataDoc (dir </> sourceFilePath)

1303+ tst (get, check) pos targetRange title = testSession title $ do

1304+ doc <- openTestDataDoc sourceFilePath

13251305 found <- get doc pos

13261306 check found targetRange

13271307

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

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

1310+

1311+ check (ExpectRange expectedRange) = do

1312+ assertNDefinitionsFound 1 defs

1313+ assertRangeCorrect (head defs) expectedRange

1314+ check (ExpectLocation expectedLocation) = do

1315+ assertNDefinitionsFound 1 defs

1316+ liftIO $ head defs @?= expectedLocation

1317+ check ExpectNoDefinitions = do

1318+ assertNDefinitionsFound 0 defs

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

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

13281321

1322+ assertNDefinitionsFound :: Int -> [a] -> Session ()

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

1324+

1325+ assertRangeCorrect Location{_range = foundRange} expectedRange =

1326+ liftIO $ expectedRange @=? foundRange

13291327

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

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

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

13711369

13721370 mkFindTests tests = testGroup "get"

13731371 [ testGroup "definition" $ mapMaybe fst tests

1374− , testGroup "hover" $ mapMaybe snd tests

1375− , checkFileCompiles sourceFilePath ]

1372+ , testGroup "hover" $ mapMaybe snd tests ]

13761373

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

13781375

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

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

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

14691466

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−

14781467pluginTests :: TestTree

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

14801469 $ testSessionWait "plugins" $ do

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

14911480 , "foo :: Int -> Int -> Int"

14921481 , "foo a b = a + c"

14931482 ]

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

1483+ _ <- openDoc' "Testing.hs" "haskell" content

14951484 expectDiagnostics

14961485 [ ( "Testing.hs",

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

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

15181507 run $ expectError content (2, 1)

15191508 )

15201509 , testSessionWait "cpp-ghcide" $ do

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

1510+ _ <- openDoc' "A.hs" "haskell" $ T.unlines

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

15231512 ,"main ="

15241513 ,"#ifdef __GHCIDE__"

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

15321521 where

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

15341523 expectError content cursor = do

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

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

15361525 expectDiagnostics

15371526 [ ( "Testing.hs",

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

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

15481537 , "module Testing where"

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

15501539 ]

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

1540+ _ <- openDoc' "Testing.hs" "haskell" content

15521541 expectDiagnostics

15531542 [ ( "Testing.hs",

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

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

15811570 ,"safeId = trustWorthyId"

15821571 ]

15831572

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

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

1573+ _ <- openDoc' "A.hs" "haskell" sourceA

1574+ _ <- openDoc' "B.hs" "haskell" sourceB

15861575 expectNoMoreDiagnostics 1 ]

15871576

15881577thTests :: TestTree

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

16101599 "b :: Integer",

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

16121601 ]

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

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

1602+ _ <- openDoc' "A.hs" "haskell" sourceA

1603+ _ <- openDoc' "B.hs" "haskell" sourceB

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

16161605 , testSessionWait "newtype-closure" $ do

16171606 let sourceA =

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

16311620 ,"import A"

16321621 ,"b :: Int"

16331622 ,"b = $( a )" ]

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

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

1623+ _ <- openDoc' "A.hs" "haskell" sourceA

1624+ _ <- openDoc' "B.hs" "haskell" sourceB

16361625 return ()

16371626 ]

16381627

@@ -1641,7 +1630,7 @@ completionTests

16411630 = testGroup "completion"

16421631 [ testSessionWait "variable" $ do

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

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

1633+ docId <- openDoc' "A.hs" "haskell" source

16451634 compls <- getCompletions docId (Position 1 7)

16461635 liftIO $ map dropDocs compls @?=

16471636 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1653,7 +1642,7 @@ completionTests

16531642 ]

16541643 , testSessionWait "constructor" $ do

16551644 let source = T.unlines ["module A where", "f = Tru"]

1656− docId <- createDoc "A.hs" "haskell" source

1645+ docId <- openDoc' "A.hs" "haskell" source

16571646 compls <- getCompletions docId (Position 1 7)

16581647 liftIO $ map dropDocs compls @?=

16591648 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1665,7 +1654,7 @@ completionTests

16651654 ]

16661655 , testSessionWait "type" $ do

16671656 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1668− docId <- createDoc "A.hs" "haskell" source

1657+ docId <- openDoc' "A.hs" "haskell" source

16691658 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

16701659 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

16711660 compls <- getCompletions docId (Position 2 7)

@@ -1682,7 +1671,7 @@ completionTests

16821671 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

16831672 , testSessionWait "qualified" $ do

16841673 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1685− docId <- createDoc "A.hs" "haskell" source

1674+ docId <- openDoc' "A.hs" "haskell" source

16861675 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

16871676 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

16881677 compls <- getCompletions docId (Position 2 15)

@@ -1696,7 +1685,7 @@ completionTests

16961685 ]

16971686 , testSessionWait "keyword" $ do

16981687 let source = T.unlines ["module A where", "f = newty"]

1699− docId <- createDoc "A.hs" "haskell" source

1688+ docId <- openDoc' "A.hs" "haskell" source

17001689 compls <- getCompletions docId (Position 1 9)

17011690 liftIO $ compls @?= [keywordItem "newtype"]

17021691 , testSessionWait "type context" $ do

@@ -1705,7 +1694,7 @@ completionTests

17051694 , "module A () where"

17061695 , "f = f"

17071696 ]

1708− docId <- createDoc "A.hs" "haskell" source

1697+ docId <- openDoc' "A.hs" "haskell" source

17091698 expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

17101699 changeDoc docId

17111700 [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

@@ -1773,7 +1762,7 @@ outlineTests = testGroup

17731762 "outline"

17741763 [ testSessionWait "type class" $ do

17751764 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1776− docId <- createDoc "A.hs" "haskell" source

1765+ docId <- openDoc' "A.hs" "haskell" source

17771766 symbols <- getDocumentSymbols docId

17781767 liftIO $ symbols @?= Left

17791768 [ moduleSymbol

@@ -1786,7 +1775,7 @@ outlineTests = testGroup

17861775 ]

17871776 , testSessionWait "type class instance " $ do

17881777 let source = T.unlines ["class A a where", "instance A () where"]

1789− docId <- createDoc "A.hs" "haskell" source

1778+ docId <- openDoc' "A.hs" "haskell" source

17901779 symbols <- getDocumentSymbols docId

17911780 liftIO $ symbols @?= Left

17921781 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1794,7 +1783,7 @@ outlineTests = testGroup

17941783 ]

17951784 , testSessionWait "type family" $ do

17961785 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1797− docId <- createDoc "A.hs" "haskell" source

1786+ docId <- openDoc' "A.hs" "haskell" source

17981787 symbols <- getDocumentSymbols docId

17991788 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

18001789 , testSessionWait "type family instance " $ do

@@ -1803,7 +1792,7 @@ outlineTests = testGroup

18031792 , "type family A a"

18041793 , "type instance A () = ()"

18051794 ]

1806− docId <- createDoc "A.hs" "haskell" source

1795+ docId <- openDoc' "A.hs" "haskell" source

18071796 symbols <- getDocumentSymbols docId

18081797 liftIO $ symbols @?= Left

18091798 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1811,7 +1800,7 @@ outlineTests = testGroup

18111800 ]

18121801 , testSessionWait "data family" $ do

18131802 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1814− docId <- createDoc "A.hs" "haskell" source

1803+ docId <- openDoc' "A.hs" "haskell" source

18151804 symbols <- getDocumentSymbols docId

18161805 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

18171806 , testSessionWait "data family instance " $ do

@@ -1820,7 +1809,7 @@ outlineTests = testGroup

18201809 , "data family A a"

18211810 , "data instance A () = A ()"

18221811 ]

1823− docId <- createDoc "A.hs" "haskell" source

1812+ docId <- openDoc' "A.hs" "haskell" source

18241813 symbols <- getDocumentSymbols docId

18251814 liftIO $ symbols @?= Left

18261815 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1828,36 +1817,36 @@ outlineTests = testGroup

18281817 ]

18291818 , testSessionWait "constant" $ do

18301819 let source = T.unlines ["a = ()"]

1831− docId <- createDoc "A.hs" "haskell" source

1820+ docId <- openDoc' "A.hs" "haskell" source

18321821 symbols <- getDocumentSymbols docId

18331822 liftIO $ symbols @?= Left

18341823 [docSymbol "a" SkFunction (R 0 0 0 6)]

18351824 , testSessionWait "pattern" $ do

18361825 let source = T.unlines ["Just foo = Just 21"]

1837− docId <- createDoc "A.hs" "haskell" source

1826+ docId <- openDoc' "A.hs" "haskell" source

18381827 symbols <- getDocumentSymbols docId

18391828 liftIO $ symbols @?= Left

18401829 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

18411830 , testSessionWait "pattern with type signature" $ do

18421831 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1843− docId <- createDoc "A.hs" "haskell" source

1832+ docId <- openDoc' "A.hs" "haskell" source

18441833 symbols <- getDocumentSymbols docId

18451834 liftIO $ symbols @?= Left

18461835 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

18471836 , testSessionWait "function" $ do

18481837 let source = T.unlines ["a x = ()"]

1849− docId <- createDoc "A.hs" "haskell" source

1838+ docId <- openDoc' "A.hs" "haskell" source

18501839 symbols <- getDocumentSymbols docId

18511840 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

18521841 , testSessionWait "type synonym" $ do

18531842 let source = T.unlines ["type A = Bool"]

1854− docId <- createDoc "A.hs" "haskell" source

1843+ docId <- openDoc' "A.hs" "haskell" source

18551844 symbols <- getDocumentSymbols docId

18561845 liftIO $ symbols @?= Left

18571846 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

18581847 , testSessionWait "datatype" $ do

18591848 let source = T.unlines ["data A = C"]

1860− docId <- createDoc "A.hs" "haskell" source

1849+ docId <- openDoc' "A.hs" "haskell" source

18611850 symbols <- getDocumentSymbols docId

18621851 liftIO $ symbols @?= Left

18631852 [ docSymbolWithChildren "A"

@@ -1865,21 +1854,9 @@ outlineTests = testGroup

18651854 (R 0 0 0 10)

18661855 [docSymbol "C" SkConstructor (R 0 9 0 10)]

18671856 ]

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

18801857 , testSessionWait "import" $ do

18811858 let source = T.unlines ["import Data.Maybe"]

1882− docId <- createDoc "A.hs" "haskell" source

1859+ docId <- openDoc' "A.hs" "haskell" source

18831860 symbols <- getDocumentSymbols docId

18841861 liftIO $ symbols @?= Left

18851862 [docSymbolWithChildren "imports"

@@ -1890,7 +1867,7 @@ outlineTests = testGroup

18901867 ]

18911868 , testSessionWait "multiple import" $ do

18921869 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1893− docId <- createDoc "A.hs" "haskell" source

1870+ docId <- openDoc' "A.hs" "haskell" source

18941871 symbols <- getDocumentSymbols docId

18951872 liftIO $ symbols @?= Left

18961873 [docSymbolWithChildren "imports"

@@ -1905,7 +1882,7 @@ outlineTests = testGroup

19051882 [ "{-# language ForeignFunctionInterface #-}"

19061883 , "foreign import ccall \"a\" a :: Int"

19071884 ]

1908− docId <- createDoc "A.hs" "haskell" source

1885+ docId <- openDoc' "A.hs" "haskell" source

19091886 symbols <- getDocumentSymbols docId

19101887 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

19111888 , testSessionWait "foreign export" $ do

@@ -1913,7 +1890,7 @@ outlineTests = testGroup

19131890 [ "{-# language ForeignFunctionInterface #-}"

19141891 , "foreign export ccall odd :: Int -> Bool"

19151892 ]

1916− docId <- createDoc "A.hs" "haskell" source

1893+ docId <- openDoc' "A.hs" "haskell" source

19171894 symbols <- getDocumentSymbols docId

19181895 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

19191896 ]

@@ -1926,8 +1903,6 @@ outlineTests = testGroup

19261903 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

19271904 docSymbolWithChildren name kind loc cc =

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

19311906 moduleSymbol name loc cc = DocumentSymbol name

19321907 Nothing

19331908 SkFile

@@ -2033,7 +2008,6 @@ cradleTests :: TestTree

20332008cradleTests = testGroup "cradle"

20342009 [testGroup "dependencies" [sessionDepsArePickedUp]

20352010 ,testGroup "loading" [loadCradleOnlyonce]

2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

20372011 ]

20382012

20392013loadCradleOnlyonce :: TestTree

@@ -2048,53 +2022,17 @@ loadCradleOnlyonce = testGroup "load cradle only once"

20482022 test dir

20492023 implicit dir = test dir

20502024 test _dir = do

2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

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

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

20532027 liftIO $ length msgs @?= 1

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

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

20562030 liftIO $ length msgs @?= 0

2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2031+ _ <- openDoc' "A.hs" "haskell" "module A where\nimport LoadCradleBar"

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

20592033 liftIO $ length msgs @?= 0

20602034

20612035

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−

20982036cradleLoadedMessage :: Session FromServerMessage

20992037cradleLoadedMessage = satisfy $ \case

21002038 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

@@ -2103,56 +2041,6 @@ cradleLoadedMessage = satisfy $ \case

21032041cradleLoadedMethod :: T.Text

21042042cradleLoadedMethod = "ghcide/cradle/loaded"

21052043

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−

21562044sessionDepsArePickedUp :: TestTree

21572045sessionDepsArePickedUp = testSession'

21582046 "session-deps-are-picked-up"

@@ -2162,7 +2050,7 @@ sessionDepsArePickedUp = testSession'

21622050 (dir </> "hie.yaml")

21632051 "cradle: {direct: {arguments: []}}"

21642052 -- Open without OverloadedStrings and expect an error.

2165− doc <- createDoc "Foo.hs" "haskell" fooContent

2053+ doc <- openDoc' "Foo.hs" "haskell" fooContent

21662054 expectDiagnostics

21672055 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

21682056 -- Update hie.yaml to enable OverloadedStrings.

@@ -2197,9 +2085,6 @@ sessionDepsArePickedUp = testSession'

21972085testSession :: String -> Session () -> TestTree

21982086testSession name = testCase name . run

21992087

2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202−

22032088testSession' :: String -> (FilePath -> Session ()) -> TestTree

22042089testSession' name = testCase name . run'

22052090

@@ -2234,19 +2119,6 @@ mkRange a b c d = Range (Position a b) (Position c d)

22342119run :: Session a -> IO a

22352120run s = withTempDir $ \dir -> runInDir dir s

22362121

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−

22502122run' :: (FilePath -> Session a) -> IO a

22512123run' s = withTempDir $ \dir -> runInDir dir (s dir)

22522124

@@ -2258,6 +2130,11 @@ runInDir dir s = do

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

22592131 createDirectoryIfMissing True $ dir ++ "/Data"

22602132

2133+ -- Copy all the test data files to the temporary workspace

2134+ testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]

2135+ for_ testDataFiles $ \f -> do

2136+ createDirectoryIfMissing True $ dir </> takeDirectory f

2137+ copyFile ("test/data" </> f) (dir </> f)

22612138

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

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

@@ -2276,7 +2153,7 @@ runInDir dir s = do

22762153openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

22772154openTestDataDoc path = do

22782155 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2279− createDoc path "haskell" source

2156+ openDoc' path "haskell" source

22802157

22812158findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

22822159findCodeActions doc range expectedTitles = do

@@ -2317,6 +2194,20 @@ unitTests = do

23172194 uriToFilePath' uri @?= Just ""

23182195 ]

23192196

2197+-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

2198+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2199+openDoc' fp name contents = do

2200+ res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

2201+ -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

2202+ sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

2203+ return res

2204+

2205+-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

2206+openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

2207+-- At the moment this is just LSPTest.openDoc' but it may change in the future

2208+-- when/if lsp-test implements WatchedFiles

2209+openDoc'' = LSPTest.openDoc'

2210+

23202211positionMappingTests :: TestTree

23212212positionMappingTests =

23222213 testGroup "position mapping"

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