master..95faeeb · ghcide

git.iko.soy/ghcide

on 95faeeb help sign in

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

since splitsnapshots

unifiedsplit

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

32 ./fmt.sh

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

34 - bash: |

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

36− sudo apt-get update

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

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

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

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

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

40 fi

38 fi

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

43 displayName: 'stack setup'

41 displayName: 'stack setup'

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

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

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

43 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

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

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

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

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

51 - bash: |

47 - bash: |

.azure/windows-stack.yml−1

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

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

47 stack install happy --stack-yaml $STACK_YAML

48 stack install alex --stack-yaml $STACK_YAML

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

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

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

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

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

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

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

7/.tasty-rerun-log

8.vscode

9/.hlint-*

10−bench/example

.hlint.yaml+1

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

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

75 # Shady extensions

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

76 - name: CPP

77 - name: CPP

77 within:

78 within:

78 - Development.IDE.Compat

79 - Development.IDE.Compat

CHANGELOG.md−20

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

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

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

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

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

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

README.md+1−18

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

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

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

28−

29−## Limitations to Multi-Component support

30−

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

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

33−some limitations to this.

34−

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

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

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

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

39−from each component.

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

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

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

43−a simple reproduction of the bug.

44−

45## Using it

28## Using it

47### Install `ghcide`

30### Install `ghcide`

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

325

308

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

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

327

310

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

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

329

312

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

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

331

314

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

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

8module Main(main) where

10−import Linker (initDynLinker)

11−import Data.IORef

12−import NameCache

13−import Packages

14−import Module

15import Arguments

10import Arguments

16−import Control.Concurrent.Async

11+import Data.Maybe

12+import Data.List.Extra

13+import System.FilePath

17import Control.Concurrent.Extra

14import Control.Concurrent.Extra

18import Control.Exception

15import Control.Exception

19import Control.Monad.Extra

16import Control.Monad.Extra

20import Control.Monad.IO.Class

17import Control.Monad.IO.Class

21import Data.Default

18import Data.Default

22−import Data.Either

19+import System.Time.Extra

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

30import Development.IDE.Core.Debouncer

20import Development.IDE.Core.Debouncer

31import Development.IDE.Core.FileStore

21import Development.IDE.Core.FileStore

32import Development.IDE.Core.OfInterest

22import Development.IDE.Core.OfInterest

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

43import Development.IDE.Plugin

33import Development.IDE.Plugin

44import Development.IDE.Plugin.Completions as Completions

34import Development.IDE.Plugin.Completions as Completions

45import Development.IDE.Plugin.CodeAction as CodeAction

35import Development.IDE.Plugin.CodeAction as CodeAction

36+import qualified Data.Text as T

37+import qualified Data.Text.IO as T

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

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

47import Language.Haskell.LSP.Messages

39import Language.Haskell.LSP.Messages

48−import Language.Haskell.LSP.Types

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

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

41+import Data.Version

50import Development.IDE.LSP.LanguageServer

42import Development.IDE.LSP.LanguageServer

51import qualified System.Directory.Extra as IO

43import qualified System.Directory.Extra as IO

52import System.Environment

44import System.Environment

53import System.IO

45import System.IO

54import System.Exit

46import System.Exit

55−import System.FilePath

56−import System.Directory

57−import System.Time.Extra

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

59import Paths_ghcide

47import Paths_ghcide

60import Development.GitRev

48import Development.GitRev

61−import Development.Shake (Action, action)

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

62import qualified Data.HashSet as HashSet

50import qualified Data.HashSet as HashSet

63−import qualified Data.HashMap.Strict as HM

64import qualified Data.Map.Strict as Map

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

52+import HIE.Bios

76−import HIE.Bios.Types

53+import Rules

77−

78−import Utils

54+import RuleTypes

80ghcideVersion :: IO String

56ghcideVersion :: IO String

81ghcideVersion = do

57ghcideVersion = do

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

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

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

122 t <- t

98 t <- t

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

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

124− let options = (defaultIdeOptions $ loadSessionShake dir)

100+ let options = (defaultIdeOptions $ loadSession dir)

125 { optReportProgress = clientSupportsProgress caps

101 { optReportProgress = clientSupportsProgress caps

126 , optShakeProfiling = argsShakeProfiling

102 , optShakeProfiling = argsShakeProfiling

127 , optTesting = argsTesting

103 , optTesting = argsTesting

128 , optThreads = argsThreads

104 , optThreads = argsThreads

129 }

105 }

130 debouncer <- newAsyncDebouncer

106 debouncer <- newAsyncDebouncer

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

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

132 getLspId event (logger minBound) debouncer options vfs

108 getLspId event (logger minBound) debouncer options vfs

133 else do

109 else do

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

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

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

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

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

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

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

140

116

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

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

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

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

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

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

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

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

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

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

146

122

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

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

148 cradles <- mapM findCradle files

124 cradles <- mapM findCradle files

149 let ucradles = nubOrd cradles

125 let ucradles = nubOrd cradles

150 let n = length ucradles

126 let n = length ucradles

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

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

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

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

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

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

132+ when (isNothing x) $ print cradle

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

134+ opts <- getComponentOptions cradle

135+ createSession opts

136+

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

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

153 vfs <- makeVFSHandle

138 vfs <- makeVFSHandle

154− debouncer <- newAsyncDebouncer

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

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

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

142+ cradle <- Map.lookup file filesToCradles

143+ Map.lookup cradle cradlesToSessions

144+

145+ let options =

146+ (defaultIdeOptions $ return $ return . grab)

147+ { optShakeProfiling = argsShakeProfiling }

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

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

156−

149+

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

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

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

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

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

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

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

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

161 when (failed /= []) $

154 when (failed /= []) $

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

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

163

156

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

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

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

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

166− return ()

159+

160+ unless (null failed) exitFailure

161+

162+cradleRules :: Rules ()

163+cradleRules = do

164+ loadGhcSession

165+ cradleToSession

167

166

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

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

169expandFiles = concatMapM $ \x -> do

168expandFiles = concatMapM $ \x -> do

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

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

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

191showEvent lock e = withLock lock $ print e

190showEvent lock e = withLock lock $ print e

192

191

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

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

231−loadSessionShake fp = do

193+loadSession dir = liftIO $ 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

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

249− res <- findCradle v

195+ res <- findCradle v

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

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

251− -- try and normalise that

197+ -- try and normalise that

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

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

253− res' <- traverse IO.makeAbsolute res

199+ res' <- traverse IO.makeAbsolute res

254− return $ normalise <$> res'

200+ return $ normalise <$> res'

255−

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

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

202+ session file = do

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

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

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

204+ let cradle = toNormalizedFilePath' $ fromMaybe dir file

259− -- which contains the union.

205+ use_ LoadCradle cradle

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

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

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)

403

207

404

208

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−

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

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

593--

210--

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

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

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

605 res <- onceFork $ op k

222 res <- onceFork $ op k

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

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

607 Just res -> return (mp, res)

224 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+34

@@ -0,0 +1,34 @@

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+ , hscenvRoot :: FilePath -- componentRoot from hie-bios

18+ , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

19+ }

20+ deriving (Eq, Show, Typeable, Generic)

21+

22+instance Hashable GetHscEnv

23+instance NFData GetHscEnv

24+instance Binary GetHscEnv

25+

26+-- Rule type for caching cradle loading

27+type instance RuleResult LoadCradle = HscEnvEq

28+

29+data LoadCradle = LoadCradle

30+ deriving (Eq, Show, Typeable, Generic)

31+

32+instance Hashable LoadCradle

33+instance NFData LoadCradle

34+instance Binary LoadCradle

exe/Rules.hsnew file+147

@@ -0,0 +1,147 @@

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, makeDynFlagsAbsolute)

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+import System.IO (hPutStrLn, stderr)

42+

43+-- Prefix for the cache path

44+cacheDir :: String

45+cacheDir = "ghcide"

46+

47+notifyCradleLoaded :: FilePath -> LSP.FromServerMessage

48+notifyCradleLoaded fp =

49+ LSP.NotCustomServer $

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

51+ toJSON fp

52+

53+loadGhcSession :: Rules ()

54+loadGhcSession =

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

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

57+ -- the existing session.

58+ defineNoFile $ \(GetHscEnv opts optRoot deps) ->

59+ liftIO $ createSession $ ComponentOptions opts optRoot deps

60+

61+cradleToSession :: Rules ()

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

63+

64+ let f = fromNormalizedFilePath nfp

65+

66+ IdeOptions{optTesting} <- getIdeOptions

67+

68+ logger <- actionLogger

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

70+

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

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

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

74+

75+ when optTesting $

76+ sendEvent $ notifyCradleLoaded f

77+

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

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

80+ let opts = componentOptions cmpOpts

81+ deps = componentDependencies cmpOpts

82+ root = componentRoot cmpOpts

83+ deps' = case mbYaml of

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

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

86+ _ -> deps

87+ existingDeps <- filterM doesFileExist deps'

88+ need existingDeps

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

90+

91+cradleLoadedMethod :: Text

92+cradleLoadedMethod = "ghcide/cradle/loaded"

93+

94+getComponentOptions :: Cradle a -> IO ComponentOptions

95+getComponentOptions cradle = do

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

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

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

99+ case cradleRes of

100+ CradleSuccess r -> pure r

101+ CradleFail err -> throwIO err

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

103+ -- That will require some more changes.

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

105+

106+ghcVersionChecker :: IO VersionCheck

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

108+

109+checkGhcVersion :: IO (Maybe HscEnvEq)

110+checkGhcVersion = do

111+ res <- ghcVersionChecker

112+ case res of

113+ Failure err -> do

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

115+ return Nothing

116+ Mismatch {..} ->

117+ return $ Just GhcVersionMismatch {..}

118+ _ ->

119+ return Nothing

120+

121+createSession :: ComponentOptions -> IO HscEnvEq

122+createSession (ComponentOptions theOpts compRoot _) = do

123+ libdir <- getLibdir

124+

125+ cacheDir <- getCacheDir theOpts

126+

127+ hPutStrLn stderr $ "Interface files cache dir: " <> cacheDir

128+

129+ runGhc (Just libdir) $ do

130+ dflags <- getSessionDynFlags

131+ (dflags_, _targets) <- addCmdOpts theOpts dflags

132+ let dflags' = makeDynFlagsAbsolute compRoot dflags_

133+ setupDynFlags cacheDir dflags'

134+ versionMismatch <- liftIO checkGhcVersion

135+ case versionMismatch of

136+ Just mismatch -> return mismatch

137+ Nothing -> do

138+ env <- getSession

139+ liftIO $ initDynLinker env

140+ liftIO $ newHscEnvEq env

141+

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

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

144+ where

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

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

147+ 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+6−52

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

2build-type: Simple

3category: Development

4name: ghcide

5−version: 0.2.0

5+version: 0.1.0

6license: Apache-2.0

7license-file: LICENSE

8author: Digital Asset

9maintainer: Digital Asset

10−copyright: Digital Asset 2018-2020

10+copyright: Digital Asset 2018-2019

11synopsis: The core of an IDE

12description:

13 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

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

16tested-with: GHC==8.6.5

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

18− test/data/hover/*.hs

18+ test/data/GotoHover.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

26source-repository head

20source-repository head

27 type: git

21 type: git

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

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

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

191 main-is: Main.hs

185 main-is: Main.hs

192 build-depends:

186 build-depends:

193− time,

194− async,

195 hslogger,

187 hslogger,

196 aeson,

188 aeson,

197 base == 4.*,

189 base == 4.*,

@@ -219,9 +211,11 @@ executable ghcide

219 text,

211 text,

220 unordered-containers

212 unordered-containers

221 other-modules:

213 other-modules:

222− Utils

223 Arguments

214 Arguments

224 Paths_ghcide

215 Paths_ghcide

216+ Rules

217+ RuleTypes

218+ Util

225

219

226 default-extensions:

220 default-extensions:

227 BangPatterns

221 BangPatterns

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

302 TupleSections

296 TupleSections

303 TypeApplications

297 TypeApplications

304 ViewPatterns

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

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

5− - path: "./exe"

6− component: "ghcide:exe:ghcide"

7− - path: "./test"

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

9− - path: "./bench"

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

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

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

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

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

90parseModule

91 :: IdeOptions

92 -> HscEnv

93− -> [PackageName]

94 -> FilePath

93 -> FilePath

95 -> Maybe SB.StringBuffer

94 -> Maybe SB.StringBuffer

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

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

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

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

98 fmap (either (, Nothing) id) $

97 fmap (either (, Nothing) id) $

99 evalGhcEnv env $ runExceptT $ do

98 evalGhcEnv env $ runExceptT $ do

100 (contents, dflags) <- preprocessor filename mbContents

99 (contents, dflags) <- preprocessor filename mbContents

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

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

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

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

103

102

104

103

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

500 :: GhcMonad m

499 :: GhcMonad m

501 => (GHC.ParsedSource -> IdePreprocessedSource)

500 => (GHC.ParsedSource -> IdePreprocessedSource)

502 -> DynFlags -- ^ flags to use

501 -> DynFlags -- ^ flags to use

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

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

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

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

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

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

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

507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

505+parseFileContents customPreprocessor dflags filename contents = do

508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

506 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

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

510#if MIN_GHC_API_VERSION(8,10,0)

508#if MIN_GHC_API_VERSION(8,10,0)

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

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

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

537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

535 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

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

539− let parsed' = removePackageImports comp_pkgs parsed

540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

537 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

541− ms <- getModSummaryFromBuffer filename dflags parsed'

538+ ms <- getModSummaryFromBuffer filename dflags parsed

542 let pm =

539 let pm =

543 ParsedModule {

540 ParsedModule {

544 pm_mod_summary = ms

541 pm_mod_summary = ms

545− , pm_parsed_source = parsed'

542+ , pm_parsed_source = parsed

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

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

547 , pm_annotations = hpm_annotations

544 , pm_annotations = hpm_annotations

548 }

545 }

549 warnings = diagFromErrMsgs "parser" dflags warns

546 warnings = diagFromErrMsgs "parser" dflags warns

550 pure (warnings ++ preproc_warnings, pm)

547 pure (warnings ++ preproc_warnings, pm)

551

548

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−

567loadHieFile :: FilePath -> IO GHC.HieFile

549loadHieFile :: FilePath -> IO GHC.HieFile

568loadHieFile f = do

550loadHieFile f = do

569 u <- mkSplitUniqSupply 'a'

551 u <- mkSplitUniqSupply 'a'

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

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

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs

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

95+ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

101− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

96+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

102− , Just True <- _dynamicRegistration

97+ , Just True <- _dynamicRegistration

103− -> fileExistsRulesFast getLspId vfs

98+ = fileExistsRulesFast getLspId vfs

104− | otherwise -> do

99+ | otherwise = do

105− logger <- logger <$> getShakeExtrasRules

100+ logger <- logger <$> getShakeExtrasRules

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

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

107− fileExistsRulesSlow vfs

102+ fileExistsRulesSlow vfs

108

103

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

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

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

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

111−fileExistsRulesFast getLspId vfs =

106+fileExistsRulesFast getLspId vfs = do

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

112 defineEarlyCutoff $ \GetFileExists file -> do

108 defineEarlyCutoff $ \GetFileExists file -> do

113 isWf <- isWorkspaceFile file

109 isWf <- isWorkspaceFile file

114 if isWf

110 if isWf

src/Development/IDE/Core/Rules.hs+13−39

@@ -59,11 +59,9 @@ import Development.IDE.GHC.Error

59import Development.Shake hiding (Diagnostic)

60import Development.IDE.Core.RuleTypes

61import Development.IDE.Spans.Type

62−import qualified Data.ByteString.Char8 as BS

64import qualified GHC.LanguageExtensions as LangExt

63import qualified GHC.LanguageExtensions as LangExt

65import HscTypes

64import HscTypes

66−import PackageConfig

67import DynFlags (gopt_set, xopt)

65import DynFlags (gopt_set, xopt)

68import GHC.Generics(Generic)

66import GHC.Generics(Generic)

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

143 hie_f = ml_hie_file $ ms_location ms

141 hie_f = ml_hie_file $ ms_location ms

144 mbHieTimestamp <- use GetModificationTime normal_hie_f

142 mbHieTimestamp <- use GetModificationTime normal_hie_f

145 srcTimestamp <- use_ GetModificationTime f

143 srcTimestamp <- use_ GetModificationTime f

144+

146 let isUpToDate

145 let isUpToDate

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

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

148 | otherwise = False

147 | otherwise = False

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

192

191

193getParsedModuleRule :: Rules ()

192getParsedModuleRule :: Rules ()

194getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

193getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

195− sess <- use_ GhcSession file

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

196− let hsc = hscEnv sess

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

198− -- parsed module

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

200 opt <- getIdeOptions

195 opt <- getIdeOptions

201 (_, contents) <- getFileContents file

196 (_, contents) <- getFileContents file

202

197

203 let dflags = hsc_dflags hsc

198 let dflags = hsc_dflags hsc

204− mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

199+ mainParse = getParsedModuleDefinition hsc opt file contents

205

200

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

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

207 if gopt Opt_Haddock dflags

202 if gopt Opt_Haddock dflags

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

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

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

212 haddockParse = do

207 haddockParse = do

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

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

214− getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

209+ getParsedModuleDefinition hscHaddock opt file contents

215 return diagsHaddock

210 return diagsHaddock

216

211

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

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

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

222

217

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

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

224

219

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

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

226−getParsedModuleDefinition packageState opt comp_pkgs file contents = do

221+getParsedModuleDefinition packageState opt file contents = do

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

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

228 case res of

223 case res of

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

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

230 Just (contents, modu) -> do

225 Just (contents, modu) -> do

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

238 define $ \GetLocatedImports file -> do

233 define $ \GetLocatedImports file -> do

239 ms <- use_ GetModSummary file

234 ms <- use_ GetModSummary file

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

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

241− env_eq <- use_ GhcSession file

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

242− let env = hscEnv env_eq

243− let import_dirs = deps env_eq

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

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

245 opt <- getIdeOptions

238 opt <- getIdeOptions

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

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

248 case diagOrImp of

241 case diagOrImp of

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

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

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

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

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

529instance NFData GhcSessionIO

522instance NFData GhcSessionIO

530instance Binary GhcSessionIO

523instance Binary GhcSessionIO

531

524

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

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

533instance Show GhcSessionFun where show _ = "GhcSessionFun"

526instance Show GhcSessionFun where show _ = "GhcSessionFun"

534instance NFData GhcSessionFun where rnf !_ = ()

527instance NFData GhcSessionFun where rnf !_ = ()

535

528

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

539 defineNoFile $ \GhcSessionIO -> do

532 defineNoFile $ \GhcSessionIO -> do

540 opts <- getIdeOptions

533 opts <- getIdeOptions

541 GhcSessionFun <$> optGhcSession opts

534 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

546 defineEarlyCutoff $ \GhcSession file -> do

535 defineEarlyCutoff $ \GhcSession file -> do

547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

536 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548− alwaysRerun

549 val <- fun $ fromNormalizedFilePath file

537 val <- fun $ fromNormalizedFilePath file

550−

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

552 opts <- getIdeOptions

538 opts <- getIdeOptions

553− let cutoffHash =

554− case optShakeFiles opts of

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

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)

562

540

563getHiFileRule :: Rules ()

541getHiFileRule :: Rules ()

564getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

542getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

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

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

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

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

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

625 -- on the parsed module and the typecheck rules

603 -- on the parsed module and the typecheck rules

626− sess <- use_ GhcSession f

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

627− let hsc = hscEnv sess

628− -- After parsing the module remove all package imports referring to

629− -- these packages as we have already dealt with what they map to.

630− comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

631 opt <- getIdeOptions

605 opt <- getIdeOptions

632 (_, contents) <- getFileContents f

606 (_, contents) <- getFileContents f

633 -- Embed --haddocks in the interface file

607 -- Embed --haddocks in the interface file

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

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

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

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

636 case mb_pm of

610 case mb_pm of

637 Nothing -> return (diags, Nothing)

611 Nothing -> return (diags, Nothing)

638 Just pm -> do

612 Just pm -> do

src/Development/IDE/Core/Shake.hs+7−9

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

69import Development.IDE.Types.Options

70import Control.Concurrent.Async

71import Control.Concurrent.Extra

72−import Control.Exception.Extra

72+import Control.Exception

73import Control.DeepSeq

74import System.Time.Extra

75import Data.Typeable

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

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

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

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

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

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

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

131

132

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

134getIdeGlobalExtras ShakeExtras{globals} = do

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

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

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

137− case x of

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

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

142

137

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

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

144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

139getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

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

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

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

172-- errors but still failed.

167-- errors but still failed.

173--

168--

169+-- A rule on a file should only return diagnostics for that given file. It should

170+-- not propagate diagnostic errors through multiple phases.

171+type IdeResult v = ([FileDiagnostic], Maybe v)

174

172

175data Value v

173data Value v

176 = Succeeded TextDocumentVersion v

174 = Succeeded TextDocumentVersion v

src/Development/IDE/GHC/Compat.hs−5

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

26 includePathsQuote,

27 addIncludePathsQuote,

28 getModuleHash,

29− getPackageName,

30 pattern DerivD,

29 pattern DerivD,

31 pattern ForD,

30 pattern ForD,

32 pattern InstD,

31 pattern InstD,

@@ -48,7 +47,6 @@ import DynFlags

48import FieldLabel

47import FieldLabel

49import Fingerprint (Fingerprint)

48import Fingerprint (Fingerprint)

50import qualified Module

49import qualified Module

51−import Packages

53import qualified GHC

51import qualified GHC

54import GHC hiding (

52import GHC hiding (

@@ -304,6 +302,3 @@ getConArgs = GHC.getConArgs

304#else

302#else

305getConArgs = GHC.getConDetails

303getConArgs = GHC.getConDetails

306#endif

304#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(

8 modifyDynFlags,

9 evalGhcEnv,

10 runGhcEnv,

11− deps,

12 -- * GHC wrappers

11 -- * GHC wrappers

13 prettyPrint,

12 prettyPrint,

14 printRdrName,

13 printRdrName,

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

65import SrcLoc (mkRealSrcLoc)

64import SrcLoc (mkRealSrcLoc)

66import FastString (mkFastString)

65import FastString (mkFastString)

67import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

66import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

68−import Module (moduleNameSlashes, InstalledUnitId)

67+import Module (moduleNameSlashes)

69import OccName (parenSymOcc)

68import OccName (parenSymOcc)

70import RdrName (nameRdrName, rdrNameOcc)

69import RdrName (nameRdrName, rdrNameOcc)

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

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

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

168data HscEnvEq

167data HscEnvEq

169 = HscEnvEq !Unique !HscEnv

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

173 | GhcVersionMismatch { compileTime :: !Version

169 | GhcVersionMismatch { compileTime :: !Version

174 , runTime :: !Version

170 , runTime :: !Version

175 }

171 }

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

179hscEnv = either error id . hscEnv'

175hscEnv = either error id . hscEnv'

180

176

181hscEnv' :: HscEnvEq -> Either String HscEnv

177hscEnv' :: HscEnvEq -> Either String HscEnv

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

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

183hscEnv' GhcVersionMismatch{..} = Left $

179hscEnv' GhcVersionMismatch{..} = Left $

184 unwords

180 unwords

185 ["ghcide compiled against GHC"

181 ["ghcide compiled against GHC"

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

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

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

190 ]

186 ]

191

187

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

193−deps (HscEnvEq _ _ u) = u

194−deps GhcVersionMismatch{} = []

195−

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

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

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

189+newHscEnvEq :: HscEnv -> IO HscEnvEq

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

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

199

191

200instance Show HscEnvEq where

192instance Show HscEnvEq where

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

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

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

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

203

195

204instance Eq HscEnvEq where

196instance Eq HscEnvEq where

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

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

206 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

198 GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207 _ == _ = False

199 _ == _ = False

208

200

209instance NFData HscEnvEq where

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

211 rnf GhcVersionMismatch{} = rnf runTime

203 rnf GhcVersionMismatch{} = rnf runTime

212

204

213instance Hashable HscEnvEq where

205instance Hashable HscEnvEq where

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

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

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

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

216

208

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

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

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

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

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

63 , packageImports :: !(Set InstalledUnitId)

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

65− } deriving Show

65+ }

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

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

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

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

129 -- appear later in the sort.

130 , rawBootMap :: !BootIdMap

131− } deriving Show

131+ }

132

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

134pkgDependencies RawDependencyInformation{..} =

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

@@ -10,16 +10,16 @@ module Development.IDE.Import.FindImports

10 , ArtifactsLocation(..)

11 , modSummaryToArtifactsLocation

12 , isBootLocation

13− , mkImportDirs

14 ) where

13 ) where

16import Development.IDE.GHC.Error as ErrUtils

15import Development.IDE.GHC.Error as ErrUtils

17import Development.IDE.GHC.Orphans()

16import Development.IDE.GHC.Orphans()

18import Development.IDE.Types.Diagnostics

17import Development.IDE.Types.Diagnostics

19import Development.IDE.Types.Location

18import Development.IDE.Types.Location

20−import Development.IDE.GHC.Compat

21-- GHC imports

19-- GHC imports

20+import DynFlags

22import FastString

21import FastString

22+import GHC

23import qualified Module as M

24import Packages

25import Outputable (showSDoc, ppr, pprPanic)

@@ -31,7 +31,6 @@ import Control.Monad.Extra

31import Control.Monad.IO.Class

32import System.FilePath

33import DriverPhases

34−import Data.Maybe

36data Import

35data Import

37 = FileImport !ArtifactsLocation

36 = FileImport !ArtifactsLocation

@@ -64,72 +63,55 @@ modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (i

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

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

66locateModuleFile :: MonadIO m

65locateModuleFile :: MonadIO m

67− => [[FilePath]]

66+ => DynFlags

68 -> [String]

67 -> [String]

69 -> (NormalizedFilePath -> m Bool)

68 -> (NormalizedFilePath -> m Bool)

70 -> Bool

69 -> Bool

71 -> ModuleName

70 -> ModuleName

72 -> m (Maybe NormalizedFilePath)

71 -> m (Maybe NormalizedFilePath)

73−locateModuleFile import_dirss exts doesExist isSource modName = do

72+locateModuleFile dflags exts doesExist isSource modName = do

74− let candidates import_dirs =

73+ let candidates =

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

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

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

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

77− findM doesExist (concatMap candidates import_dirss)

76+ findM doesExist candidates

78 where

77 where

79 maybeBoot ext

78 maybeBoot ext

80 | isSource = ext ++ "-boot"

79 | isSource = ext ++ "-boot"

81 | otherwise = ext

80 | otherwise = ext

83−-- | This function is used to map a package name to a set of import paths.

84−-- It only returns Just for unit-ids which are possible to import into the

85−-- current module. In particular, it will return Nothing for 'main' components

86−-- as they can never be imported into another package.

87−mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])

88−mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i

89−

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

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

91-- Haskell

83-- Haskell

92locateModule

84locateModule

93 :: MonadIO m

85 :: MonadIO m

94 => DynFlags

86 => DynFlags

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

96 -> [String]

87 -> [String]

97 -> (NormalizedFilePath -> m Bool)

88 -> (NormalizedFilePath -> m Bool)

98 -> Located ModuleName

89 -> Located ModuleName

99 -> Maybe FastString

90 -> Maybe FastString

100 -> Bool

91 -> Bool

101 -> m (Either [FileDiagnostic] Import)

92 -> m (Either [FileDiagnostic] Import)

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

93+locateModule dflags exts doesExist modName mbPkgName isSource = do

103 case mbPkgName of

94 case mbPkgName of

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

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

105 Just "this" -> do

96 Just "this" -> do

106− lookupLocal [importPaths dflags]

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

98+ case mbFile of

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

100+ Just file -> toModLocation file

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

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

102+ Just _pkgName -> lookupInPackageDB dflags

112 Nothing -> do

103 Nothing -> do

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

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

114 -- database.

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

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

119 case mbFile of

107 case mbFile of

120 Nothing -> lookupInPackageDB dflags

108 Nothing -> lookupInPackageDB dflags

121 Just file -> toModLocation file

109 Just file -> toModLocation file

122 where

110 where

123− import_paths = mapMaybe (mkImportDirs dflags) comp_info

124 toModLocation file = liftIO $ do

111 toModLocation file = liftIO $ do

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

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

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

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

127

114

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

133

115

134 lookupInPackageDB dfs =

116 lookupInPackageDB dfs =

135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

117 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

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

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

6 LSP.Diagnostic(..),

7 ShowDiagnostic(..),

8 FileDiagnostic,

9− IdeResult,

10 LSP.DiagnosticSeverity(..),

9 LSP.DiagnosticSeverity(..),

11 DiagnosticStore,

10 DiagnosticStore,

12 List(..),

11 List(..),

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

33import Development.IDE.Types.Location

32import Development.IDE.Types.Location

35−-- A rule on a file should only return diagnostics for that given file. It should

36−-- not propagate diagnostic errors through multiple phases.

37−type IdeResult v = ([FileDiagnostic], Maybe v)

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

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

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

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

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

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

12 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15− , IdeResult

16 ) where

15 ) where

18import Development.Shake

17import Development.Shake

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

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

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

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

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

23import qualified Data.Text as T

22import qualified Data.Text as T

24−import Development.IDE.Types.Diagnostics

26data IdeOptions = IdeOptions

24data IdeOptions = IdeOptions

27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

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

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

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

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

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

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

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

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

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

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

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

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

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

78clientSupportsProgress caps = IdeReportProgress $ Just True ==

76clientSupportsProgress caps = IdeReportProgress $ Just True ==

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

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

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

79+defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

82defaultIdeOptions session = IdeOptions

80defaultIdeOptions session = IdeOptions

83 {optPreprocessor = IdePreprocessedSource [] []

81 {optPreprocessor = IdePreprocessedSource [] []

84 ,optGhcSession = session

82 ,optGhcSession = session

test/data/hover/Bar.hs → test/data/Bar.hsrenamed

The content is the same.

test/data/hover/Foo.hs → test/data/Foo.hsrenamed

The content is the same.

test/data/hover/GotoHover.hs → test/data/GotoHover.hsrenamed

The content is the same.

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+55−125

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

10module Main (main) where

12import Control.Applicative.Combinators

13−import Control.Exception (bracket, catch)

13+import Control.Exception (catch)

14import qualified Control.Lens as Lens

15import Control.Monad

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

@@ -35,7 +35,7 @@ import Language.Haskell.LSP.Types.Capabilities

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

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

37import Network.URI

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

38+import System.Environment.Blank (setEnv)

39import System.FilePath

40import System.IO.Extra

41import System.Directory

@@ -49,35 +49,32 @@ import Test.Tasty.QuickCheck

49import Data.Maybe

51main :: 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"

52+main = defaultMainWithRerun $ testGroup "HIE"

56− [ testSession "open close" $ do

53+ [ testSession "open close" $ do

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

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

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

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

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

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

60− closeDoc doc

57+ closeDoc doc

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

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

62− , initializeResponseTests

59+ , initializeResponseTests

63− , completionTests

60+ , completionTests

64− , cppTests

61+ , cppTests

65− , diagnosticTests

62+ , diagnosticTests

66− , codeActionTests

63+ , codeActionTests

67− , codeLensesTests

64+ , codeLensesTests

68− , outlineTests

65+ , outlineTests

69− , findDefinitionAndHoverTests

66+ , findDefinitionAndHoverTests

70− , pluginTests

67+ , pluginTests

71− , preprocessorTests

68+ , preprocessorTests

72− , thTests

69+ , thTests

73− , safeTests

70+ , safeTests

74− , unitTests

71+ , unitTests

75− , haddockTests

72+ , haddockTests

76− , positionMappingTests

73+ , positionMappingTests

77− , watchedFilesTests

74+ , watchedFilesTests

78− , cradleTests

75+ , cradleTests

79− , dependentFileTest

76+ , dependentFileTest

80− ]

77+ ]

82initializeResponseTests :: TestTree

79initializeResponseTests :: TestTree

83initializeResponseTests = withResource acquire release tests where

80initializeResponseTests = withResource acquire release tests where

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

1296 ]

1293 ]

1297 ]

1294 ]

1298

1295

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−

1320findDefinitionAndHoverTests :: TestTree

1296findDefinitionAndHoverTests :: TestTree

1321findDefinitionAndHoverTests = let

1297findDefinitionAndHoverTests = let

1322

1298

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

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

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

1300+ doc <- openTestDataDoc sourceFilePath

1325 found <- get doc pos

1301 found <- get doc pos

1326 check found targetRange

1302 check found targetRange

1327

1303

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

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

1328

1306

1307+ check (ExpectRange expectedRange) = do

1308+ assertNDefinitionsFound 1 defs

1309+ assertRangeCorrect (head defs) expectedRange

1310+ check (ExpectLocation expectedLocation) = do

1311+ assertNDefinitionsFound 1 defs

1312+ liftIO $ head defs @?= expectedLocation

1313+ check ExpectNoDefinitions = do

1314+ assertNDefinitionsFound 0 defs

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

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

1317+

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

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

1320+

1321+ assertRangeCorrect Location{_range = foundRange} expectedRange =

1322+ liftIO $ expectedRange @=? foundRange

1329

1323

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

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

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

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

@@ -1469,10 +1463,8 @@ findDefinitionAndHoverTests = let

1469

1463

1470checkFileCompiles :: FilePath -> TestTree

1464checkFileCompiles :: FilePath -> TestTree

1471checkFileCompiles fp =

1465checkFileCompiles fp =

1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do

1466+ testSessionWait ("Does " ++ fp ++ " compile") $

1473− void (openTestDataDoc (dir </> fp))

1467+ void (openTestDataDoc fp)

1474− expectNoMoreDiagnostics 0.5

1475−

1476

1468

1477

1469

1478pluginTests :: TestTree

1470pluginTests :: TestTree

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

2033cradleTests = testGroup "cradle"

2025cradleTests = testGroup "cradle"

2034 [testGroup "dependencies" [sessionDepsArePickedUp]

2026 [testGroup "dependencies" [sessionDepsArePickedUp]

2035 ,testGroup "loading" [loadCradleOnlyonce]

2027 ,testGroup "loading" [loadCradleOnlyonce]

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

2037 ]

2028 ]

2038

2029

2039loadCradleOnlyonce :: TestTree

2030loadCradleOnlyonce :: TestTree

@@ -2103,56 +2094,6 @@ cradleLoadedMessage = satisfy $ \case

2103cradleLoadedMethod :: T.Text

2094cradleLoadedMethod :: T.Text

2104cradleLoadedMethod = "ghcide/cradle/loaded"

2095cradleLoadedMethod = "ghcide/cradle/loaded"

2105

2096

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−

2156sessionDepsArePickedUp :: TestTree

2097sessionDepsArePickedUp :: TestTree

2157sessionDepsArePickedUp = testSession'

2098sessionDepsArePickedUp = testSession'

2158 "session-deps-are-picked-up"

2099 "session-deps-are-picked-up"

@@ -2197,9 +2138,6 @@ sessionDepsArePickedUp = testSession'

2197testSession :: String -> Session () -> TestTree

2138testSession :: String -> Session () -> TestTree

2198testSession name = testCase name . run

2139testSession name = testCase name . run

2199

2140

2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202−

2203testSession' :: String -> (FilePath -> Session ()) -> TestTree

2141testSession' :: String -> (FilePath -> Session ()) -> TestTree

2204testSession' name = testCase name . run'

2142testSession' name = testCase name . run'

2205

2143

@@ -2234,19 +2172,6 @@ mkRange a b c d = Range (Position a b) (Position c d)

2234run :: Session a -> IO a

2172run :: Session a -> IO a

2235run s = withTempDir $ \dir -> runInDir dir s

2173run s = withTempDir $ \dir -> runInDir dir s

2236

2174

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−

2250run' :: (FilePath -> Session a) -> IO a

2175run' :: (FilePath -> Session a) -> IO a

2251run' s = withTempDir $ \dir -> runInDir dir (s dir)

2176run' s = withTempDir $ \dir -> runInDir dir (s dir)

2252

2177

@@ -2258,6 +2183,11 @@ runInDir dir s = do

2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2183 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2259 createDirectoryIfMissing True $ dir ++ "/Data"

2184 createDirectoryIfMissing True $ dir ++ "/Data"

2260

2185

2186+ -- Copy all the test data files to the temporary workspace

2187+ testDataFiles <- getDirectoryFilesIO "test/data" ["//*"]

2188+ for_ testDataFiles $ \f -> do

2189+ createDirectoryIfMissing True $ dir </> takeDirectory f

2190+ copyFile ("test/data" </> f) (dir </> f)

2261

2191

2262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

2192 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

2263 -- HIE calls getXgdDirectory which assumes that HOME is set.

2193 -- HIE calls getXgdDirectory which assumes that HOME is set.