ghcide 0.2.0 → 0.3.0

raw patch · 49 files changed

+11311/−3865 lines, 49 filesdep +Chartdep +Chart-diagramsdep +diagramsdep −parser-combinatorsdep ~basedep ~extradep ~ghcnew-component:exe:ghcide-benchnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: Chart, Chart-diagrams, diagrams, diagrams-svg, process, safe, yaml

Dependencies removed: parser-combinators

Dependency ranges changed: base, extra, ghc, ghc-check, hie-bios, lsp-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +56/−0
• README.md +15/−4
• bench/exe/Main.hs +50/−0
• bench/hist/Main.hs +472/−0
• bench/lib/Experiments.hs +423/−0
• exe/Arguments.hs +2/−0
• exe/Main.hs +15/−538
• exe/Utils.hs +0/−9
• ghcide.cabal +128/−27
• session-loader/Development/IDE/Session.hs +632/−0
• session-loader/Development/IDE/Session/VersionCheck.hs +17/−0
• src-ghc810/Development/IDE/GHC/HieBin.hs +399/−0
• src-ghc86/Development/IDE/GHC/HieAst.hs +1784/−0
• src-ghc86/Development/IDE/GHC/HieBin.hs +388/−0
• src-ghc86/Development/IDE/GHC/HieDebug.hs +145/−0
• src-ghc86/Development/IDE/GHC/HieTypes.hs +534/−0
• src-ghc86/Development/IDE/GHC/HieUtils.hs +451/−0
• src-ghc88/Development/IDE/GHC/HieBin.hs +389/−0
• src/Development/IDE/Core/Compile.hs +150/−61
• src/Development/IDE/Core/Debouncer.hs +5/−0
• src/Development/IDE/Core/FileStore.hs +50/−12
• src/Development/IDE/Core/OfInterest.hs +15/−3
• src/Development/IDE/Core/RuleTypes.hs +38/−9
• src/Development/IDE/Core/Rules.hs +323/−179
• src/Development/IDE/Core/Service.hs +13/−34
• src/Development/IDE/Core/Shake.hs +456/−147
• src/Development/IDE/GHC/Compat.hs +138/−47
• src/Development/IDE/GHC/Error.hs +0/−21
• src/Development/IDE/GHC/Orphans.hs +5/−0
• src/Development/IDE/GHC/Util.hs +8/−22
• src/Development/IDE/LSP/HoverDefinition.hs +11/−6
• src/Development/IDE/LSP/LanguageServer.hs +5/−2
• src/Development/IDE/LSP/Notifications.hs +4/−3
• src/Development/IDE/LSP/Outline.hs +1/−1
• src/Development/IDE/Plugin/CodeAction.hs +371/−9
• src/Development/IDE/Plugin/Completions.hs +76/−14
• src/Development/IDE/Plugin/Completions/Logic.hs +121/−59
• src/Development/IDE/Plugin/Completions/Types.hs +16/−16
• src/Development/IDE/Spans/AtPoint.hs +78/−35
• src/Development/IDE/Spans/Calculate.hs +70/−75
• src/Development/IDE/Spans/Common.hs +34/−15
• src/Development/IDE/Spans/Documentation.hs +85/−18
• src/Development/IDE/Types/Diagnostics.hs +9/−0
• src/Development/IDE/Types/Location.hs +1/−1
• src/Development/IDE/Types/Options.hs +18/−4
• test/data/hover/Bar.hs +1/−0
• test/data/hover/Foo.hs +1/−0
• test/exe/Main.hs +3297/−2491
• test/src/Development/IDE/Test.hs +11/−3

@@ -1,5 +1,61 @@ ### unreleased +### 0.3.0 (2020-09-02)++* CI: remove (internal) DA Slack notifications (#750) - (Gary Verhaegen)+* Add session-loader to hie.yaml (#714) - (Luke Lau)+* Codeaction for exporting unused top-level bindings (#711) - (shaurya gupta)+* Add links to haddock and hscolour pages in documentation (#699) - (Luke Lau)+* Expose GHC.Compat module (#709) - (Pepe Iborra)+* Move session loading logic into ghcide library (#697) - (Luke Lau)+* Code action: remove redundant constraints for type signature (#692) - (Denis Frezzato)+* Fix Binary instance of Q to handle empty file paths (#707) - (Moritz Kiefer)+* Populate ms_hs_date in GetModSummary rule (#694) - (Pepe Iborra)+* Allow GHC plugins to be called with an updated StringBuffer (#698) - (Alfredo Di Napoli)+* Relax upper bounds for GHC 8.10.1 (#705) - (Pepe Iborra)+* Obtain the GHC libdir at runtime (#696) - (Luke Lau)+* Expect bench experiments to fail with Cabal (#704) - (Pepe Iborra)+* Bump lodash from 4.17.15 to 4.17.19 in /extension (#702) - (dependabot[bot])+* Update to hie-bios 0.6.1 (#693) - (fendor)+* Backport HIE files to GHC 8.6 (#689) - (wz1000)+* Performance improvements for GetSpanInfo (#681) - (Pepe Iborra)+* Code action add default type annotation to remove `-Wtype-defaults` warning (#680) - (Serhii)+* Use a global namecache to read `.hie` files (#677) - (wz1000)+* Completions need not depend on typecheck of the current file (#670) - (Pepe Iborra)+* Fix spaninfo Haddocks for local modules (#678) - (Pepe Iborra)+* Avoid excessive retypechecking of TH codebases (#673) - (Pepe Iborra)+* Use stale information if it's available to answer requests quickly (#624) - (Matthew Pickering)+* Code action: add constraint (#653) - (Denis Frezzato)+* Make BenchHist non buildable by default and save logs (#666) - (Pepe Iborra)+* Delete unused top level binding code action (#657) - (Serhii)+* stack810.yaml: bump (#651) - (Domen Kozar)+* Fix debouncer for 0 delay (#662) - (Pepe Iborra)+* Interface file fixes (#645) - (Pepe Iborra)+* Retry GHC 8.10 on Windows (#661) - (Moritz Kiefer)+* Finer dependencies for GhcSessionFun (#643) - (Pepe Iborra)+* Send WorkDoneProgressEnd only when work is done (#649) - (Pepe Iborra)+* Add a note on differential benchmarks (#647) - (Pepe Iborra)+* Cache a ghc session per file of interest (#630) - (Pepe Iborra)+* Remove `Strict` from the language extensions used for code actions (#638) - (Torsten Schmits)+* Report progress when setting up cradle (#644) - (Luke Lau)+* Fix crash when writing to a Barrier more than once (#637) - (Pepe Iborra)+* Write a cabal.project file in the benchmark example (#640) - (Pepe Iborra)+* Performance analysis over time (#629) - (Pepe Iborra)+* More benchmarks (#625) - (Pepe Iborra)+* Canonicalize the locations in the cradle tests (#628) - (Luke Lau)+* Add hie.yaml.stack and use none cradle for test data (#626) - (Javier Neira)+* Fix a bug in getHiFileRule (#623) - (Pepe Iborra)+* ghc initialization error handling (#609) - (Pepe Iborra)+* Fix regression in getSpanInfoRule (#622) - (Pepe Iborra)+* Restore Shake profiling (#621) - (Pepe Iborra)+* Use a better noRange (#612) - (Neil Mitchell)+* Add back a .ghci file (#607) - (Neil Mitchell)+* #573, make haddock errors warnings with the word Haddock in front (#608) - (Neil Mitchell)+* Implement Goto Type Definition (#533) - (Matthew Pickering)+* remove unnecessary FileExists dependency in GetHiFile (#589) - (Pepe Iborra)+* ShakeSession and shakeEnqueue (#554) - (Pepe Iborra)+* Benchmark suite (#590) - (Pepe Iborra)+ ### 0.2.0 (2020-06-02)  * Multi-component support (thanks @mpickering)

@@ -4,7 +4,7 @@  Our vision is that you should build an IDE by combining: -![vscode](https://raw.githubusercontent.com/digital-asset/ghcide/master/img/vscode2.png)+![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png)  * [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on; * `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages;@@ -64,7 +64,7 @@  First install the `ghcide` binary using `stack` or `cabal`, e.g. -1. `git clone https://github.com/digital-asset/ghcide.git`+1. `git clone https://github.com/haskell/ghcide.git` 2. `cd ghcide` 3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`) @@ -310,6 +310,17 @@ This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. +If you are touching performance sensitive code, take the time to run a differential+benchmark between HEAD and upstream using the benchHist script. The configuration in+`bench/hist.yaml` is setup to do this by default assuming upstream is+`origin/master`. Run the benchmarks with `stack`:++    export STACK_YAML=...+    stack bench++It should take around 15 minutes and the results will be stored in the `bench-hist` folder.+To interpret the results, see the comments in the `bench/hist/Main.hs` module.+ ### Building the extension  For development, you can also the VSCode extension from this repository (see@@ -327,8 +338,8 @@  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). -The 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).+The 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. The project has been handed over to Haskell.org as of September 2020.  The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. -The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).+The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/).

@@ -0,0 +1,50 @@+{- An automated benchmark built around the simple experiment described in:++  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html++  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and+  loads the module 'Distribution.Simple'. The rationale for this choice is:++    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`+    - It has very few dependencies, and all are already needed to build ghcide+    - Distribution.Simple has 235 transitive module dependencies, so non trivial++  The experiments are sequences of lsp commands scripted using lsp-test.+  A more refined approach would be to record and replay real IDE interactions,+  once the replay functionality is available in lsp-test.+  A more declarative approach would be to reuse ide-debug-driver:++  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md++  The result of an experiment is a total duration in seconds after a preset+  number of iterations. There is ample room for improvement:+     - Statistical analysis to detect outliers and auto infer the number of iterations needed+     - GC stats analysis (currently -S is printed as part of the experiment)+     - Analyisis of performance over the commit history of the project++  How to run:+     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`+     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`++  Note that the package database influences the response times of certain actions,+  e.g. code actions, and therefore the two methods above do not necessarily+  produce the same results.++ -}++{-# LANGUAGE ImplicitParams #-}++import Control.Exception.Safe+import Experiments+import Options.Applicative++main :: IO ()+main = do+  config <- execParser $ info (configP <**> helper) fullDesc+  let ?config = config++  output "starting test"++  cleanUp <- setup++  runBenchmarks experiments `finally` cleanUp

@@ -0,0 +1,472 @@+{-  Bench history++    A Shake script to analyze the performance of ghcide over the git history of the project++    Driven by a config file `bench/hist.yaml` containing the list of Git references to analyze.++    Builds each one of them and executes a set of experiments using the ghcide-bench suite.++    The results of the benchmarks and the analysis are recorded in the file+    system with the following structure:++    bench-hist+    ├── <git-reference>                       - one folder per version+    │   ├── <experiment>.benchmark-gcStats    - RTS -s output+    │   ├── <experiment>.csv                  - stats for the experiment+    │   ├── <experiment>.svg                  - Graph of bytes over elapsed time+    │   ├── <experiment>.diff.svg             - idem, including the previous version+    │   ├── <experiment>.log                  - ghcide-bench output+    │   ├── ghc.path                          - path to ghc used to build the binary+    │   ├── ghcide                            - binary for this version+    │   └── results.csv                       - results of all the experiments for the version+    ├── results.csv        - aggregated results of all the experiments and versions+    ├── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions++   For diff graphs, the "previous version" is the preceding entry in the list of versions+   in the config file. A possible improvement is to obtain this info via `git rev-list`.++   The script relies on stack for building and running all the binaries.++   To execute the script:++   > stack bench++   To build a specific analysis, enumerate the desired file artifacts++   > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg"++ -}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DerivingStrategies#-}+{-# LANGUAGE TypeFamilies      #-}++import Control.Applicative (Alternative (empty))+import Control.Monad (when, forM, forM_, replicateM)+import Data.Foldable (find)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow)+import Development.Shake+import Development.Shake.Classes (Binary, Hashable, NFData)+import GHC.Exts (IsList (..))+import GHC.Generics (Generic)+import qualified Graphics.Rendering.Chart.Backend.Diagrams as E+import Graphics.Rendering.Chart.Easy ((.=))+import qualified Graphics.Rendering.Chart.Easy as E+import Numeric.Natural (Natural)+import System.Directory+import System.FilePath+import qualified Text.ParserCombinators.ReadP as P+import Text.Read (Read (..), get, readMaybe, readP_to_Prec)++config :: FilePath+config = "bench/hist.yaml"++-- | Read the config without dependency+readConfigIO :: FilePath -> IO Config+readConfigIO = decodeFileThrow++newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)++newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)++newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)++newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)++newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)++type instance RuleResult GetSamples = Natural++type instance RuleResult GetExperiments = [Unescaped String]++type instance RuleResult GetVersions = [GitCommit]++type instance RuleResult GetParent = Text++type instance RuleResult GetCommitId = String++main :: IO ()+main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do+  want ["all"]++  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)++  _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config+  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config+  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config+  _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config++  let readVersions = askOracle $ GetVersions ()+      readExperiments = askOracle $ GetExperiments ()+      readSamples = askOracle $ GetSamples ()+      getParent = askOracle . GetParent++  build <- liftIO $ outputFolder <$> readConfigIO config+  ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)++  phony "all" $ do+    Config {..} <- readConfig config++    forM_ versions $ \ver ->+      need [build </> T.unpack (humanName ver) </> "results.csv"]++    need $+      [build </> "results.csv"]+        ++ [ build </> escaped (escapeExperiment e) <.> "svg"+             | e <- experiments+           ]+        ++ [ build </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"+             | e <- experiments,+               ver <- versions,+               mode <- ["", "diff"]+           ]++  build -/- "*/commitid" %> \out -> do+      alwaysRerun++      let [_,ver,_] = splitDirectories out+      mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions+      let gitThing :: String+          gitThing = maybe ver (T.unpack . gitName) mbEntry+      Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]+      writeFileChanged out $ init commitid++  priority 10 $ [build -/- "HEAD/ghcide"+                , build -/- "HEAD/ghc.path"+                ]+    &%> \[out, ghcpath] -> do+      liftIO $ createDirectoryIfMissing True $ dropFileName out+      need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]+      cmd_+          ( "stack --local-bin-path=" <> takeDirectory out+              <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts"+          )+      Stdout ghcLoc <- cmd (s "stack --stack-yaml=stack88.yaml exec which ghc")+      writeFile' ghcpath ghcLoc++  [ build -/- "*/ghcide",+    build -/- "*/ghc.path"+    ]+    &%> \[out, ghcpath] -> do+      let [b, ver, _] = splitDirectories out+      liftIO $ createDirectoryIfMissing True $ dropFileName out+      commitid <- readFile' $ b </> ver </> "commitid"+      cmd_ $ "git worktree add bench-temp " ++ commitid+      flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do+        Stdout ghcLoc <- cmd [Cwd "bench-temp"] (s "stack --stack-yaml=stack88.yaml exec which ghc")+        cmd_+          [Cwd "bench-temp"]+          ( "stack --local-bin-path=../"+              <> takeDirectory out+              <> " --stack-yaml=stack88.yaml build ghcide:ghcide --copy-bins --ghc-options -rtsopts"+          )+        writeFile' ghcpath ghcLoc++  priority 8000 $+    build -/- "*/results.csv" %> \out -> do+      experiments <- readExperiments++      let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]+      allResults <- traverse readFileLines allResultFiles++      let header = head $ head allResults+          results = map tail allResults+      writeFileChanged out $ unlines $ header : concat results++  ghcideBenchResource <- newResource "ghcide-bench" 1++  priority 0 $+    [ build -/- "*/*.csv",+      build -/- "*/*.benchmark-gcStats",+      build -/- "*/*.log"+    ]+      &%> \[outcsv, _outGc, outLog] -> do+        let [_, _, exp] = splitDirectories outcsv+        samples <- readSamples+        liftIO $ createDirectoryIfMissing True $ dropFileName outcsv+        let ghcide = dropFileName outcsv </> "ghcide"+            ghcpath = dropFileName outcsv </> "ghc.path"+        need [ghcide, ghcpath]+        ghcPath <- readFile' ghcpath+        withResource ghcideBenchResource 1 $ do+          command_+              [ EchoStdout False,+                FileStdout outLog,+                RemEnv "NIX_GHC_LIBDIR",+                RemEnv "GHC_PACKAGE_PATH",+                AddPath [takeDirectory ghcPath, "."] []+              ]+              ghcideBenchPath+              [ "--timeout=3000",+                "-v",+                "--samples=" <> show samples,+                "--csv=" <> outcsv,+                "--example-package-version=3.0.0.0",+                "--ghcide-options= +RTS -I0.5 -RTS",+                "--ghcide=" <> ghcide,+                "--select",+                unescaped (unescapeExperiment (Escaped $ dropExtension exp))+              ]+          cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv++  build -/- "results.csv" %> \out -> do+    versions <- readVersions+    let allResultFiles =+          [build </> T.unpack (humanName v) </> "results.csv" | v <- versions]++    need [build </> T.unpack (humanName v) </> "ghcide" | v <- versions]++    allResults <- traverse readFileLines allResultFiles++    let header = head $ head allResults+        results = map tail allResults+        header' = "version, " <> header+        results' = zipWith (\v -> map (\l -> T.unpack (humanName v) <> ", " <> l)) versions results++    writeFileChanged out $ unlines $ header' : concat results'++  priority 2 $+    build -/- "*/*.diff.svg" %> \out -> do+      let [b, ver, exp_] = splitDirectories out+          exp = Escaped $ dropExtension $ dropExtension exp_+      prev <- getParent $ T.pack ver++      runLog <- loadRunLog b exp ver+      runLogPrev <- loadRunLog b exp $ T.unpack prev++      let diagram = Diagram Live [runLog, runLogPrev] title+          title = show (unescapeExperiment exp) <> " - live bytes over time compared"+      plotDiagram True diagram out++  priority 1 $+    build -/- "*/*.svg" %> \out -> do+      let [b, ver, exp] = splitDirectories out+      runLog <- loadRunLog b (Escaped $ dropExtension exp) ver+      let diagram = Diagram Live [runLog] title+          title = ver <> " live bytes over time"+      plotDiagram True diagram out++  build -/- "*.svg" %> \out -> do+    let exp = Escaped $ dropExtension $ takeFileName out+    versions <- readVersions++    runLogs <- forM (filter include versions) $ \v -> do+      loadRunLog build exp $ T.unpack $ humanName v++    let diagram = Diagram Live runLogs title+        title = show (unescapeExperiment exp) <> " - live bytes over time"+    plotDiagram False diagram out++----------------------------------------------------------------------------------------------------++data Config = Config+  { experiments :: [Unescaped String],+    samples :: Natural,+    versions :: [GitCommit],+    -- | Path to the ghcide-bench binary for the experiments+    ghcideBench :: FilePath,+    -- | Output folder ('foo' works, 'foo/bar' does not)+    outputFolder :: String+  }+  deriving (Generic, Show)+  deriving anyclass (FromJSON, ToJSON)++data GitCommit = GitCommit+  { -- | A git hash, tag or branch name (e.g. v0.1.0)+    gitName :: Text,+    -- | A human understandable name (e.g. fix-collisions-leak)+    name :: Maybe Text,+    -- | The human understandable name of the parent, if specified explicitly+    parent :: Maybe Text,+    -- | Whether to include this version in the top chart+    include :: Bool+  }+  deriving (Binary, Eq, Hashable, Generic, NFData, Show)++instance FromJSON GitCommit where+  parseJSON (String s) = pure $ GitCommit s Nothing Nothing True+  parseJSON (Object (toList -> [(name, String gitName)])) =+    pure $ GitCommit gitName (Just name) Nothing True+  parseJSON (Object (toList -> [(name, Object props)])) =+    GitCommit+      <$> props .:? "git"  .!= name+      <*> pure (Just name)+      <*> props .:? "parent"+      <*> props .:? "include" .!= True+  parseJSON _ = empty++instance ToJSON GitCommit where+  toJSON GitCommit {..} =+    case name of+      Nothing -> String gitName+      Just n -> Object $ fromList [(n, String gitName)]++humanName :: GitCommit -> Text+humanName GitCommit {..} = fromMaybe gitName name++findPrev :: Text -> [GitCommit] -> Text+findPrev name (x : y : xx)+  | humanName y == name = humanName x+  | otherwise = findPrev name (y : xx)+findPrev name _ = name++----------------------------------------------------------------------------------------------------++-- | A line in the output of -S+data Frame = Frame+  { allocated, copied, live :: !Int,+    user, elapsed, totUser, totElapsed :: !Double,+    generation :: !Int+  }+  deriving (Show)++instance Read Frame where+  readPrec = do+    spaces+    allocated <- readPrec @Int <* spaces+    copied <- readPrec @Int <* spaces+    live <- readPrec @Int <* spaces+    user <- readPrec @Double <* spaces+    elapsed <- readPrec @Double <* spaces+    totUser <- readPrec @Double <* spaces+    totElapsed <- readPrec @Double <* spaces+    _ <- readPrec @Int <* spaces+    _ <- readPrec @Int <* spaces+    "(Gen:  " <- replicateM 7 get+    generation <- readPrec @Int+    ')' <- get+    return Frame {..}+    where+      spaces = readP_to_Prec $ const P.skipSpaces++data TraceMetric = Allocated | Copied | Live | User | Elapsed+  deriving (Generic, Enum, Bounded, Read)++instance Show TraceMetric where+  show Allocated = "Allocated bytes"+  show Copied = "Copied bytes"+  show Live = "Live bytes"+  show User = "User time"+  show Elapsed = "Elapsed time"++frameMetric :: TraceMetric -> Frame -> Double+frameMetric Allocated = fromIntegral . allocated+frameMetric Copied = fromIntegral . copied+frameMetric Live = fromIntegral . live+frameMetric Elapsed = elapsed+frameMetric User = user++data Diagram = Diagram+  { traceMetric :: TraceMetric,+    runLogs :: [RunLog],+    title :: String+  }+  deriving (Generic)++-- | A file path containing the output of -S for a given run+data RunLog = RunLog+  { runVersion :: !String,+    _runExperiment :: !String,+    runFrames :: ![Frame],+    runSuccess :: !Bool+  }++loadRunLog :: FilePath -> Escaped FilePath -> FilePath -> Action RunLog+loadRunLog buildF exp ver = do+  let log_fp = buildF </> ver </> escaped exp <.> "benchmark-gcStats"+      csv_fp = replaceExtension log_fp "csv"+  log <- readFileLines log_fp+  csv <- readFileLines csv_fp+  let frames =+        [ f+          | l <- log,+            Just f <- [readMaybe l],+            -- filter out gen 0 events as there are too many+            generation f == 1+        ]+      success = case map (T.split (== ',') . T.pack) csv of+          [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s+          _ -> error $ "Cannot parse: " <> csv_fp+  return $ RunLog ver (dropExtension $ escaped exp) frames success++plotDiagram :: Bool -> Diagram -> FilePath -> Action ()+plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do+  let extract = frameMetric traceMetric+  liftIO $ E.toFile E.def out $ do+    E.layout_title .= title t+    E.setColors myColors+    forM_ runLogs $ \rl ->+      when (includeFailed || runSuccess rl) $ E.plot $ do+        lplot <- E.line+            (runVersion rl ++ if runSuccess rl then "" else " (FAILED)")+            [ [ (totElapsed f, extract f)+                | f <- runFrames rl+                ]+            ]+        return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)++s :: String -> String+s = id++(-/-) :: FilePattern -> FilePattern -> FilePattern+a -/- b = a <> "/" <> b++newtype Escaped a = Escaped {escaped :: a}++newtype Unescaped a = Unescaped {unescaped :: a}+  deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)++escapeExperiment :: Unescaped String -> Escaped String+escapeExperiment = Escaped . map f . unescaped+  where+    f ' ' = '_'+    f other = other++unescapeExperiment :: Escaped String -> Unescaped String+unescapeExperiment = Unescaped . map f . escaped+  where+    f '_' = ' '+    f other = other++myColors :: [E.AlphaColour Double]+myColors = map E.opaque+  [ E.blue+  , E.green+  , E.red+  , E.orange+  , E.yellow+  , E.violet+  , E.black+  , E.gold+  , E.brown+  , E.hotpink+  , E.aliceblue+  , E.aqua+  , E.beige+  , E.bisque+  , E.blueviolet+  , E.burlywood+  , E.cadetblue+  , E.chartreuse+  , E.coral+  , E.crimson+  , E.darkblue+  , E.darkgray+  , E.darkgreen+  , E.darkkhaki+  , E.darkmagenta+  , E.deeppink+  , E.dodgerblue+  , E.firebrick+  , E.forestgreen+  , E.fuchsia+  , E.greenyellow+  , E.lightsalmon+  , E.seagreen+  , E.olive+  , E.sandybrown+  , E.sienna+  , E.peru+  ]

@@ -0,0 +1,423 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ImplicitParams #-}++module Experiments+( Bench(..)+, BenchRun(..)+, Config(..)+, Verbosity(..)+, CabalStack(..)+, experiments+, configP+, defConfig+, output+, setup+, runBench+, runBenchmarks+) where+import Control.Applicative.Combinators (skipManyTill)+import Control.Concurrent+import Control.Exception.Safe+import Control.Monad.Extra+import Control.Monad.IO.Class+import Data.Char (isDigit)+import Data.List+import Data.Maybe+import Data.Version+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Types+import Language.Haskell.LSP.Types.Capabilities+import Numeric.Natural+import Options.Applicative+import System.Directory+import System.FilePath ((</>))+import System.Process+import System.Time.Extra+import Text.ParserCombinators.ReadP (readP_to_S)+import System.Environment.Blank (getEnv)++-- Points to a string in the target file,+-- convenient for hygienic edits+hygienicP :: Position+hygienicP = Position 854 23++hygienicEdit :: TextDocumentContentChangeEvent+hygienicEdit =+    TextDocumentContentChangeEvent+    { _range = Just (Range hygienicP hygienicP),+        _rangeLength = Nothing,+        _text = " "+    }++breakingEdit :: TextDocumentContentChangeEvent+breakingEdit =+    TextDocumentContentChangeEvent+    { _range = Just (Range identifierP identifierP),+        _rangeLength = Nothing,+        _text = "a"+    }++-- Points to the middle of an identifier,+-- convenient for requesting goto-def, hover and completions+identifierP :: Position+identifierP = Position 853 12++experiments :: [Bench]+experiments =+    [ ---------------------------------------------------------------------------------------+      bench "hover" 10 $ \doc ->+        isJust <$> getHover doc identifierP,+      ---------------------------------------------------------------------------------------+      bench "edit" 10 $ \doc -> do+        changeDoc doc [hygienicEdit]+        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+        return True,+      ---------------------------------------------------------------------------------------+      bench "hover after edit" 10 $ \doc -> do+        changeDoc doc [hygienicEdit]+        isJust <$> getHover doc identifierP,+      ---------------------------------------------------------------------------------------+      bench "getDefinition" 10 $ \doc ->+        not . null <$> getDefinitions doc identifierP,+      ---------------------------------------------------------------------------------------+      bench "documentSymbols" 100 $+        fmap (either (not . null) (not . null)) . getDocumentSymbols,+      ---------------------------------------------------------------------------------------+      bench "documentSymbols after edit" 100 $ \doc -> do+        changeDoc doc [hygienicEdit]+        either (not . null) (not . null) <$> getDocumentSymbols doc,+      ---------------------------------------------------------------------------------------+      bench "completions after edit" 10 $ \doc -> do+        changeDoc doc [hygienicEdit]+        not . null <$> getCompletions doc identifierP,+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "code actions"+        10+        ( \doc -> do+            changeDoc doc [breakingEdit]+            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+            return identifierP+        )+        ( \p doc -> do+            not . null <$> getCodeActions doc (Range p p)+        ),+      ---------------------------------------------------------------------------------------+      benchWithSetup+        "code actions after edit"+        10+        ( \doc -> do+            changeDoc doc [breakingEdit]+            return identifierP+        )+        ( \p doc -> do+            changeDoc doc [hygienicEdit]+            whileM (null <$> waitForDiagnostics)+            not . null <$> getCodeActions doc (Range p p)+        )+    ]++---------------------------------------------------------------------------------------------++examplePackageName :: HasConfig => String+examplePackageName = name+  where+      (name, _, _) = examplePackageUsed ?config++examplePackage :: HasConfig => String+examplePackage = name <> "-" <> showVersion version+  where+      (name, version, _) = examplePackageUsed ?config++exampleModulePath :: HasConfig => FilePath+exampleModulePath = path+  where+      (_,_, path) = examplePackageUsed ?config++examplesPath :: FilePath+examplesPath = "bench/example"++data Verbosity = Quiet | Normal | All+  deriving (Eq, Show)+data Config = Config+  { verbosity :: !Verbosity,+    -- For some reason, the Shake profile files are truncated and won't load+    shakeProfiling :: !(Maybe FilePath),+    outputCSV :: !FilePath,+    buildTool :: !CabalStack,+    ghcideOptions :: ![String],+    matches :: ![String],+    repetitions :: Maybe Natural,+    ghcide :: FilePath,+    timeoutLsp :: Int,+    examplePackageUsed :: (String, Version, String)+  }+  deriving (Eq, Show)++defConfig :: Config+Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []++quiet, verbose :: Config -> Bool+verbose = (== All) . verbosity+quiet   = (== Quiet) . verbosity++data CabalStack = Cabal | Stack+  deriving (Eq, Show)++type HasConfig = (?config :: Config)++configP :: Parser Config+configP =+  Config+    <$> (flag' All (short 'v' <> long "verbose")+         <|> flag' Quiet (short 'q' <> long "quiet")+         <|> pure Normal+        )+    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))+    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)+    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")+    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))+    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))+    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))+    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")+    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")+    <*> ( (,,) <$> strOption (long "example-package-name" <> value "Cabal")+               <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0]))+               <*> strOption (long "example-package-module" <> metavar "PATH" <> value "Distribution/Simple.hs"))++versionP :: ReadM Version+versionP = maybeReader $ extract . readP_to_S parseVersion+  where+      extract parses = listToMaybe [ res | (res,"") <- parses]++output :: (MonadIO m, HasConfig) => String -> m ()+output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn++---------------------------------------------------------------------------------------++type Experiment = TextDocumentIdentifier -> Session Bool++data Bench = forall setup.+  Bench+  { name :: !String,+    enabled :: !Bool,+    samples :: !Natural,+    benchSetup :: TextDocumentIdentifier -> Session setup,+    experiment :: setup -> Experiment+  }++select :: HasConfig => Bench -> Bool+select Bench {name, enabled} =+  enabled && (null mm || name `elem` mm)+  where+    mm = matches ?config++benchWithSetup ::+  String ->+  Natural ->+  (TextDocumentIdentifier -> Session p) ->+  (p -> Experiment) ->+  Bench+benchWithSetup name samples benchSetup experiment = Bench {..}+  where+    enabled = True++bench :: String -> Natural -> Experiment -> Bench+bench name defSamples userExperiment =+  benchWithSetup name defSamples (const $ pure ()) experiment+  where+    experiment () = userExperiment++runBenchmarks :: HasConfig => [Bench] -> IO ()+runBenchmarks allBenchmarks = do+  let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }+                   | b <- allBenchmarks+                   , select b ]+  results <- forM benchmarks $ \b@Bench{name} ->+                let run dir = runSessionWithConfig conf (cmd name dir) lspTestCaps dir+                in (b,) <$> runBench run b++  -- output raw data as CSV+  let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"]+      rows =+        [ [ name,+            show success,+            show samples,+            show startup,+            show runSetup',+            show runExperiment,+            showMB maxResidency+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+        ]+      csv = unlines $ map (intercalate ", ") (headers : rows)+  writeFile (outputCSV ?config) csv++  -- print a nice table+  let pads = map (maximum . map length) (transpose (headers : rowsHuman))+      paddedHeaders = zipWith pad pads headers+      outputRow = putStrLn . intercalate " | "+      rowsHuman =+        [ [ name,+            show success,+            show samples,+            showDuration startup,+            showDuration runSetup',+            showDuration runExperiment,+            showMB maxResidency+          ]+          | (Bench {name, samples}, BenchRun {..}) <- results,+            let runSetup' = if runSetup < 0.01 then 0 else runSetup+        ]+  outputRow paddedHeaders+  outputRow $ (map . map) (const '-') paddedHeaders+  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row+  where+    gcStats name = escapeSpaces (name <> ".benchmark-gcStats")+    cmd name dir =+      unwords $+        [ ghcide ?config,+          "--lsp",+          "--cwd",+          dir,+          "+RTS",+          "-S" <> gcStats name,+          "-RTS"+        ]+          ++ ghcideOptions ?config+          ++ concat+            [ ["--shake-profiling", path]+              | Just path <- [shakeProfiling ?config]+            ]+    lspTestCaps =+      fullCaps {_window = Just $ WindowClientCapabilities $ Just True}+    conf =+      defaultConfig+        { logStdErr = verbose ?config,+          logMessages = verbose ?config,+          logColor = False,+          messageTimeout = timeoutLsp ?config+        }++data BenchRun = BenchRun+  { startup :: !Seconds,+    runSetup :: !Seconds,+    runExperiment :: !Seconds,+    success :: !Bool,+    maxResidency :: !Int+  }++badRun :: BenchRun+badRun = BenchRun 0 0 0 False 0++waitForProgressDone :: Session ()+waitForProgressDone =+      void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)++runBench :: (?config::Config) => (String -> Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun+runBench runSess Bench {..} = handleAny (\e -> print e >> return badRun)+  $ runSess dir+  $ do+    doc <- openDoc exampleModulePath "haskell"+    (startup, _) <- duration $ do+      waitForProgressDone+      -- wait again, as the progress is restarted once while loading the cradle+      -- make an edit, to ensure this doesn't block+      changeDoc doc [hygienicEdit]+      waitForProgressDone+++    liftIO $ output $ "Running " <> name <> " benchmark"+    (runSetup, userState) <- duration $ benchSetup doc+    let loop 0 = return True+        loop n = do+          (t, res) <- duration $ experiment userState doc+          if not res+            then return False+            else do+              output (showDuration t)+              loop (n -1)++    (runExperiment, success) <- duration $ loop samples++    -- sleep to give ghcide a chance to GC+    liftIO $ threadDelay 1100000++    maxResidency <- liftIO $+        ifM (doesFileExist gcStats)+            (parseMaxResidency <$> readFile gcStats)+            (pure 0)++    return BenchRun {..}+  where+    dir = "bench/example/" <> examplePackage+    gcStats = escapeSpaces (name <> ".benchmark-gcStats")++setup :: HasConfig => IO (IO ())+setup = do+  alreadyExists <- doesDirectoryExist examplesPath+  when alreadyExists $ removeDirectoryRecursive examplesPath+  let path = examplesPath </> examplePackage+  case buildTool ?config of+      Cabal -> do+        callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath+        writeFile+            (path </> "hie.yaml")+            ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")+        -- Need this in case there is a parent cabal.project somewhere+        writeFile+            (path </> "cabal.project")+            "packages: ."+        writeFile+            (path </> "cabal.project.local")+            ""+      Stack -> do+        callCommand $ "stack --silent unpack " <> examplePackage <> " --to " <> examplesPath+        -- Generate the stack descriptor to match the one used to build ghcide+        stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"+        stack_yaml_lines <- lines <$> readFile stack_yaml+        writeFile (path </> stack_yaml)+                  (unlines $+                   "packages: [.]" :+                    [ l+                    | l <- stack_yaml_lines+                    , any (`isPrefixOf` l)+                        ["resolver"+                        ,"allow-newer"+                        ,"compiler"]+                    ]+                  )++        writeFile+            (path </> "hie.yaml")+            ("cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}")++  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True++  return $ removeDirectoryRecursive examplesPath++--------------------------------------------------------------------------------------------++-- Parse the max residency in RTS -s output+parseMaxResidency :: String -> Int+parseMaxResidency input =+  case find ("maximum residency" `isInfixOf`) (reverse $ lines input) of+    Just l -> read $ filter isDigit $ head (words l)+    Nothing -> -1+++escapeSpaces :: String -> String+escapeSpaces = map f+  where+    f ' ' = '_'+    f x = x++pad :: Int -> String -> String+pad n [] = replicate n ' '+pad 0 _ = error "pad"+pad n (x:xx) = x : pad (n-1) xx++showMB :: Int -> String+showMB x = show (x `div` 2^(20::Int)) <> "MB"

@@ -14,6 +14,7 @@     ,argsShakeProfiling :: Maybe FilePath     ,argsTesting :: Bool     ,argsThreads :: Int+    ,argsVerbose :: Bool     }  getArguments :: IO Arguments@@ -33,3 +34,4 @@       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)+      <*> switch (long "verbose" <> help "Include internal events in logging output")

@@ -1,31 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above-{-# LANGUAGE CPP #-} -- To get precise GHC version {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}  module Main(main) where -import Linker (initDynLinker)-import Data.IORef-import NameCache-import Packages-import Module import Arguments-import Control.Concurrent.Async import Control.Concurrent.Extra-import Control.Exception import Control.Monad.Extra-import Control.Monad.IO.Class import Data.Default-import Data.Either-import Data.Function import Data.List.Extra import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Time.Clock (UTCTime) import Data.Version import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore@@ -39,44 +26,27 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Options import Development.IDE.Types.Logger-import Development.IDE.GHC.Util import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction+import Development.IDE.Session import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types-import Data.Aeson (ToJSON(toJSON)) import Development.IDE.LSP.LanguageServer import qualified System.Directory.Extra as IO import System.Environment import System.IO+import System.Info import System.Exit import System.FilePath-import System.Directory import System.Time.Extra-import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute) import Paths_ghcide import Development.GitRev-import Development.Shake (Action, action) import qualified Data.HashSet as HashSet-import qualified Data.HashMap.Strict as HM-import qualified Data.Map.Strict as Map-import qualified Crypto.Hash.SHA1 as H-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Base16 (encode)-import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))-import GhcMonad-import HscTypes (HscEnv(..), ic_dflags)-import GHC hiding (def)-import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )-import Data.Either.Extra  import HIE.Bios.Cradle-import HIE.Bios.Types -import Utils- ghcideVersion :: IO String ghcideVersion = do   path <- getExecutablePath@@ -84,7 +54,7 @@         x | x == "UNKNOWN" -> ""         x -> " (GIT hash: " <> x <> ")"   return $ "ghcide version: " <> showVersion version-             <> " (GHC: " <> VERSION_ghc+             <> " (GHC: " <> showVersion compilerVersion              <> ") (PATH: " <> path <> ")"              <> gitHashSection @@ -118,18 +88,20 @@         t <- offsetTime         hPutStrLn stderr "Starting LSP server..."         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do+        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do             t <- t             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t-            let options = (defaultIdeOptions $ loadSessionShake dir)+            sessionLoader <- loadSession dir+            let options = (defaultIdeOptions sessionLoader)                     { optReportProgress = clientSupportsProgress caps                     , optShakeProfiling = argsShakeProfiling-                    , optTesting        = argsTesting+                    , optTesting        = IdeTesting argsTesting                     , optThreads        = argsThreads                     }+                logLevel = if argsVerbose then minBound else Info             debouncer <- newAsyncDebouncer-            initialise caps (mainRule >> pluginRules plugins >> action kick)-                getLspId event (logger minBound) debouncer options vfs+            initialise caps (mainRule >> pluginRules plugins)+                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs     else do         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error         hSetEncoding stdout utf8@@ -152,18 +124,20 @@         putStrLn "\nStep 3/4: Initializing the IDE"         vfs <- makeVFSHandle         debouncer <- newAsyncDebouncer-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs+        let dummyWithProg _ _ f = f (const (pure ()))+        sessionLoader <- loadSession dir+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions sessionLoader)  vfs          putStrLn "\nStep 4/4: Type checking the files"         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files-        results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)+        results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)         let (worked, failed) = partition fst $ zip (map isJust results) files         when (failed /= []) $             putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed          let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"         putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"-        return ()+        unless (null failed) (exitWith $ ExitFailure (length failed))  expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do@@ -177,12 +151,6 @@             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x         return files --kick :: Action ()-kick = do-    files <- getFilesOfInterest-    void $ uses TypeCheck $ HashSet.toList files- -- | Print an LSP event. showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return ()@@ -190,494 +158,3 @@     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e ---- | Run the specific cradle on a specific FilePath via hie-bios.-cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)-cradleToSessionOpts cradle file = do-    let showLine s = putStrLn ("> " ++ s)-    cradleRes <- runCradle (cradleOptsProg cradle) showLine file-    case cradleRes of-        CradleSuccess r -> pure (Right r)-        CradleFail err -> return (Left [err])-        -- For the None cradle perhaps we still want to report an Info-        -- message about the fact that the file is being ignored.-        CradleNone -> return (Left [])--emptyHscEnv :: IO HscEnv-emptyHscEnv = do-    libdir <- getLibdir-    env <- runGhc (Just libdir) getSession-    initDynLinker env-    pure env---- | Convert a target to a list of potential absolute paths.--- A TargetModule can be anywhere listed by the supplied include--- directories--- A target file is a relative path but with a specific prefix so just need--- to canonicalise it.-targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]-targetToFile is (TargetModule mod) = do-    let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]-        exts = ["hs", "hs-boot", "lhs"]-    mapM (fmap toNormalizedFilePath' . canonicalizePath) fps-targetToFile _ (TargetFile f _) = do-  f' <- canonicalizePath f-  return [toNormalizedFilePath' f']--setNameCache :: IORef NameCache -> HscEnv -> HscEnv-setNameCache nc hsc = hsc { hsc_NC = nc }--loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))-loadSessionShake fp = do-  se <- getShakeExtras-  IdeOptions{optTesting} <- getIdeOptions-  res <- liftIO $ loadSession optTesting se fp-  return (fmap liftIO res)---- | This is the key function which implements multi-component support. All--- components mapping to the same hie.yaml file are mapped to the same--- HscEnv which is updated as new components are discovered.-loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))-loadSession optTesting ShakeExtras{logger, eventer} dir = do-  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file-  hscEnvs <- newVar Map.empty :: IO (Var HieMap)-  -- Mapping from a Filepath to HscEnv-  fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)--  -- This caches the mapping from Mod.hs -> hie.yaml-  cradleLoc <- memoIO $ \v -> do-      res <- findCradle v-      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path-      -- try and normalise that-      -- e.g. see https://github.com/digital-asset/ghcide/issues/126-      res' <- traverse IO.makeAbsolute res-      return $ normalise <$> res'--  -- Create a new HscEnv from a hieYaml root and a set of options-  -- If the hieYaml file already has an HscEnv, the new component is-  -- combined with the components in the old HscEnv into a new HscEnv-  -- which contains the union.-  let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)-                   -> IO (HscEnv, ComponentInfo, [ComponentInfo])-      packageSetup (hieYaml, cfp, opts) = do-        -- Parse DynFlags for the newly discovered component-        hscEnv <- emptyHscEnv-        (df, targets) <- evalGhcEnv hscEnv $-                          setOptions opts (hsc_dflags hscEnv)-        dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)-        -- Now lookup to see whether we are combining with an existing HscEnv-        -- or making a new one. The lookup returns the HscEnv and a list of-        -- information about other components loaded into the HscEnv-        -- (unitId, DynFlag, Targets)-        modifyVar hscEnvs $ \m -> do-            -- Just deps if there's already an HscEnv-            -- Nothing is it's the first time we are making an HscEnv-            let oldDeps = Map.lookup hieYaml m-            let -- Add the raw information about this component to the list-                -- We will modify the unitId and DynFlags used for-                -- compilation but these are the true source of-                -- information.-                new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info-                              : maybe [] snd oldDeps-                -- Get all the unit-ids for things in this component-                inplace = map rawComponentUnitId new_deps--            new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do-                -- Remove all inplace dependencies from package flags for-                -- components in this HscEnv-                let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags-                let prefix = show rawComponentUnitId-                -- See Note [Avoiding bad interface files]-                processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2-                -- The final component information, mostly the same but the DynFlags don't-                -- contain any packages which are also loaded-                -- into the same component.-                pure $ ComponentInfo rawComponentUnitId-                                     processed_df-                                     uids-                                     rawComponentTargets-                                     rawComponentFP-                                     rawComponentCOptions-                                     rawComponentDependencyInfo-            -- Make a new HscEnv, we have to recompile everything from-            -- scratch again (for now)-            -- It's important to keep the same NameCache though for reasons-            -- that I do not fully understand-            logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))-            hscEnv <- case oldDeps of-                        Nothing -> emptyHscEnv-                        Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv-            newHscEnv <--              -- Add the options for the current component to the HscEnv-              evalGhcEnv hscEnv $ do-                _ <- setSessionDynFlags df-                getSession-            -- Modify the map so the hieYaml now maps to the newly created-            -- HscEnv-            -- Returns-            -- . the new HscEnv so it can be used to modify the-            --   FilePath -> HscEnv map (fileToFlags)-            -- . The information for the new component which caused this cache miss-            -- . The modified information (without -inplace flags) for-            --   existing packages-            pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))--  let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)-      session (hieYaml, cfp, opts) = do-        (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)-        -- Make a map from unit-id to DynFlags, this is used when trying to-        -- resolve imports. (especially PackageImports)-        let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)--        -- For each component, now make a new HscEnvEq which contains the-        -- HscEnv for the hie.yaml file but the DynFlags for that component--        -- New HscEnv for the component in question, returns the new HscEnvEq and-        -- a mapping from FilePath to the newly created HscEnvEq.-        let new_cache = newComponentCache logger hscEnv uids-        (cs, res) <- new_cache new-        -- Modified cache targets for everything else in the hie.yaml file-        -- which now uses the same EPS and so on-        cached_targets <- concatMapM (fmap fst . new_cache) old_deps-        modifyVar_ fileToFlags $ \var -> do-            pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var--        return (fst res)--  let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)-      consultCradle hieYaml cfp = do-         when optTesting $ eventer $ notifyCradleLoaded cfp-         logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)-         cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml-         eopts <- cradleToSessionOpts cradle cfp-         logDebug logger $ T.pack ("Session loading result: " <> show eopts)-         case eopts of-           -- The cradle gave us some options so get to work turning them-           -- into and HscEnv.-           Right opts -> do-             session (hieYaml, toNormalizedFilePath' cfp, opts)-           -- Failure case, either a cradle error or the none cradle-           Left err -> do-             dep_info <- getDependencyInfo (maybeToList hieYaml)-             let ncfp = toNormalizedFilePath' cfp-             let res = (map (renderCradleError ncfp) err, Nothing)-             modifyVar_ fileToFlags $ \var -> do-               pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var-             return res--  -- This caches the mapping from hie.yaml + Mod.hs -> [String]-  let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)-      sessionOpts (hieYaml, file) = do-        v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags-        cfp <- canonicalizePath file-        case HM.lookup (toNormalizedFilePath' cfp) v of-          Just (opts, old_di) -> do-            deps_ok <- checkDependencyInfo old_di-            if not deps_ok-              then do-                -- If the dependencies are out of date then clear both caches and start-                -- again.-                modifyVar_ fileToFlags (const (return Map.empty))-                -- Keep the same name cache-                modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )-                consultCradle hieYaml cfp-              else return opts-          Nothing -> consultCradle hieYaml cfp--  dummyAs <- async $ return (error "Uninitialised")-  runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))-  -- The main function which gets options for a file. We only want one of these running-  -- at a time. Therefore the IORef contains the currently running cradle, if we try-  -- to get some more options then we wait for the currently running action to finish-  -- before attempting to do so.-  let getOptions :: FilePath -> IO (IdeResult HscEnvEq)-      getOptions file = do-          hieYaml <- cradleLoc file-          sessionOpts (hieYaml, file)-  return $ \file -> do-    join $ mask_ $ modifyVar runningCradle $ \as -> do-      -- If the cradle is not finished, then wait for it to finish.-      void $ wait as-      as <- async $ getOptions file-      return (as, wait as)------ | Create a mapping from FilePaths to HscEnvEqs-newComponentCache-         :: Logger-         -> HscEnv-         -> [(InstalledUnitId, DynFlags)]-         -> ComponentInfo-         -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))-newComponentCache logger hsc_env uids ci = do-    let df = componentDynFlags ci-    let hscEnv' = hsc_env { hsc_dflags = df-                          , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }--    versionMismatch <- checkGhcVersion-    henv <- case versionMismatch of-              Just mismatch -> return mismatch-              Nothing -> newHscEnvEq hscEnv' uids-    let res = (([], Just henv), componentDependencyInfo ci)-    logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))--    let is = importPaths df-    ctargets <- concatMapM (targetToFile is  . targetId) (componentTargets ci)-    -- A special target for the file which caused this wonderful-    -- component to be created. In case the cradle doesn't list all the targets for-    -- the component, in which case things will be horribly broken anyway.-    -- Otherwise, we will immediately attempt to reload this module which-    -- causes an infinite loop and high CPU usage.-    let special_target = (componentFP ci, res)-    let xs = map (,res) ctargets-    return (special_target:xs, res)--{- Note [Avoiding bad interface files]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Originally, we set the cache directory for the various components once-on the first occurrence of the component.-This works fine if these components have no references to each other,-but you have components that depend on each other, the interface files are-updated for each component.-After restarting the session and only opening the component that depended-on the other, suddenly the interface files of this component are stale.-However, from the point of view of `ghcide`, they do not look stale,-thus, not regenerated and the IDE shows weird errors such as:-```-typecheckIface-Declaration for Rep_ClientRunFlags-Axiom branches Rep_ClientRunFlags:-  Failed to load interface for ‘Distribution.Simple.Flag’-  Use -v to see a list of the files searched for.-```-and-```-expectJust checkFamInstConsistency-CallStack (from HasCallStack):-  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes-  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst-```--To mitigate this, we set the cache directory for each component dependent-on the components of the current `HscEnv`, additionally to the component options-of the respective components.-Assume two components, c1, c2, where c2 depends on c1, and the options of the-respective components are co1, co2.-If we want to load component c2, followed by c1, we set the cache directory for-each component in this way:--  * Load component c2-    * (Cache Directory State)-        - name of c2 + co2-  * Load component c1-    * (Cache Directory State)-        - name of c2 + name of c1 + co2-        - name of c2 + name of c1 + co1--Overall, we created three cache directories. If we opened c1 first, then we-create a fourth cache directory.-This makes sure that interface files are always correctly updated.--Since this causes a lot of recompilation, we only update the cache-directory,-if the dependencies of a component have really changed.-E.g. when you load two executables, they can not depend on each other. They-should be filtered out, such that we dont have to re-compile everything.--}---- | Set the cache-directory based on the ComponentOptions and a list of--- internal packages.--- For the exact reason, see Note [Avoiding bad interface files].-setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags-setCacheDir logger prefix hscComponents comps dflags = do-    cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)-    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir-    pure $ dflags-          & setHiDir cacheDir-          & setDefaultHieDir cacheDir---renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic-renderCradleError nfp (CradleError _ec t) =-  ideErrorText nfp (T.unlines (map T.pack t))---- See Note [Multi Cradle Dependency Info]-type DependencyInfo = Map.Map FilePath (Maybe UTCTime)-type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])-type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))---- This is pristine information about a component-data RawComponentInfo = RawComponentInfo-  { rawComponentUnitId :: InstalledUnitId-  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.-  -- We do not want to use them unprocessed.-  , rawComponentDynFlags :: DynFlags-  -- | All targets of this components.-  , rawComponentTargets :: [Target]-  -- | Filepath which caused the creation of this component-  , rawComponentFP :: NormalizedFilePath-  -- | Component Options used to load the component.-  , rawComponentCOptions :: ComponentOptions-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file-  -- to last modification time. See Note [Multi Cradle Dependency Info].-  , rawComponentDependencyInfo :: DependencyInfo-  }---- This is processed information about the component, in particular the dynflags will be modified.-data ComponentInfo = ComponentInfo-  { componentUnitId :: InstalledUnitId-  -- | Processed DynFlags. Does not contain inplace packages such as local-  -- libraries. Can be used to actually load this Component.-  , componentDynFlags :: DynFlags-  -- | Internal units, such as local libraries, that this component-  -- is loaded with. These have been extracted from the original-  -- ComponentOptions.-  , componentInternalUnits :: [InstalledUnitId]-  -- | All targets of this components.-  , componentTargets :: [Target]-  -- | Filepath which caused the creation of this component-  , componentFP :: NormalizedFilePath-  -- | Component Options used to load the component.-  , componentCOptions :: ComponentOptions-  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file-  -- to last modification time. See Note [Multi Cradle Dependency Info]-  , componentDependencyInfo :: DependencyInfo-  }---- | Check if any dependency has been modified lately.-checkDependencyInfo :: DependencyInfo -> IO Bool-checkDependencyInfo old_di = do-  di <- getDependencyInfo (Map.keys old_di)-  return (di == old_di)---- Note [Multi Cradle Dependency Info]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Why do we implement our own file modification tracking here?--- The primary reason is that the custom caching logic is quite complicated and going into shake--- adds even more complexity and more indirection. I did try for about 5 hours to work out how to--- use shake rules rather than IO but eventually gave up.---- | Computes a mapping from a filepath to its latest modification date.--- See Note [Multi Cradle Dependency Info] why we do this ourselves instead--- of letting shake take care of it.-getDependencyInfo :: [FilePath] -> IO DependencyInfo-getDependencyInfo fs = Map.fromList <$> mapM do_one fs--  where-    tryIO :: IO a -> IO (Either IOException a)-    tryIO = try--    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)-    do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)---- | This function removes all the -package flags which refer to packages we--- are going to deal with ourselves. For example, if a executable depends--- on a library component, then this function will remove the library flag--- from the package flags for the executable------ There are several places in GHC (for example the call to hptInstances in--- tcRnImports) which assume that all modules in the HPT have the same unit--- ID. Therefore we create a fake one and give them all the same unit id.-removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])-removeInplacePackages us df = (df { packageFlags = ps-                                  , thisInstalledUnitId = fake_uid }, uids)-  where-    (uids, ps) = partitionEithers (map go (packageFlags df))-    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")-    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us-                                                  then Left (toInstalledUnitId u)-                                                  else Right p-    go p = Right p---- | Memoize an IO function, with the characteristics:------   * If multiple people ask for a result simultaneously, make sure you only compute it once.------   * If there are exceptions, repeatedly reraise them.------   * If the caller is aborted (async exception) finish computing it anyway.-memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)-memoIO op = do-    ref <- newVar Map.empty-    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->-        case Map.lookup k mp of-            Nothing -> do-                res <- onceFork $ op k-                return (Map.insert k res mp, res)-            Just res -> return (mp, res)--setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])-setOptions (ComponentOptions theOpts compRoot _) dflags = do-    (dflags', targets) <- addCmdOpts theOpts dflags-    let dflags'' =-          -- disabled, generated directly by ghcide instead-          flip gopt_unset Opt_WriteInterface $-          -- disabled, generated directly by ghcide instead-          -- also, it can confuse the interface stale check-          dontWriteHieFiles $-          setIgnoreInterfacePragmas $-          setLinkerOptions $-          disableOptimisation $-          makeDynFlagsAbsolute compRoot dflags'-    -- initPackages parses the -package flags and-    -- sets up the visibility for each component.-    (final_df, _) <- liftIO $ initPackages dflags''-    return (final_df, targets)----- we don't want to generate object code so we compile to bytecode--- (HscInterpreted) which implies LinkInMemory--- HscInterpreted-setLinkerOptions :: DynFlags -> DynFlags-setLinkerOptions df = df {-    ghcLink   = LinkInMemory-  , hscTarget = HscNothing-  , ghcMode = CompManager-  }--setIgnoreInterfacePragmas :: DynFlags -> DynFlags-setIgnoreInterfacePragmas df =-    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges--disableOptimisation :: DynFlags -> DynFlags-disableOptimisation df = updOptLevel 0 df--setHiDir :: FilePath -> DynFlags -> DynFlags-setHiDir f d =-    -- override user settings to avoid conflicts leading to recompilation-    d { hiDir      = Just f}--getCacheDir :: String -> [String] -> IO FilePath-getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)-    where-        -- Create a unique folder per set of different GHC options, assuming that each different set of-        -- GHC options will create incompatible interface files.-        opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)---- | Sub directory for the cache path-cacheDir :: String-cacheDir = "ghcide"--notifyCradleLoaded :: FilePath -> FromServerMessage-notifyCradleLoaded fp =-    NotCustomServer $-    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $-    toJSON fp--cradleLoadedMethod :: T.Text-cradleLoadedMethod = "ghcide/cradle/loaded"--ghcVersionChecker :: IO VersionCheck-ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))--checkGhcVersion :: IO (Maybe HscEnvEq)-checkGhcVersion = do-    res <- ghcVersionChecker-    case res of-        Failure err -> do-          putStrLn $ "Error while checking GHC version: " ++ show err-          return Nothing-        Mismatch {..} ->-          return $ Just GhcVersionMismatch {..}-        _ ->-          return Nothing

@@ -1,9 +0,0 @@-module Utils (getLibdir) where--import qualified GHC.Paths-import System.Environment-import Data.Maybe---- Set the GHC libdir to the nix libdir if it's present.-getLibdir :: IO FilePath-getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

@@ -2,17 +2,17 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.2.0+version:            0.3.0 license:            Apache-2.0 license-file:       LICENSE-author:             Digital Asset-maintainer:         Digital Asset-copyright:          Digital Asset 2018-2020+author:             Digital Asset and Ghcide contributors+maintainer:         Ghcide contributors+copyright:          Digital Asset and Ghcide contributors 2018-2020 synopsis:           The core of an IDE description:     A library for building Haskell IDE's on top of the GHC API.-homepage:           https://github.com/digital-asset/ghcide#readme-bug-reports:        https://github.com/digital-asset/ghcide/issues+homepage:           https://github.com/haskell/ghcide#readme+bug-reports:        https://github.com/haskell/ghcide/issues tested-with:        GHC==8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md                     test/data/hover/*.hs@@ -25,7 +25,7 @@  source-repository head     type:     git-    location: https://github.com/digital-asset/ghcide.git+    location: https://github.com/haskell/ghcide.git  flag ghc-lib   description: build against ghc-lib instead of the ghc package@@ -59,6 +59,7 @@         prettyprinter,         regex-tdfa >= 1.3.1.0,         rope-utf16-splay,+        safe,         safe-exceptions,         shake >= 0.18.4,         sorted-list,@@ -79,7 +80,14 @@       build-depends:         ghc-boot-th,         ghc-boot,-        ghc >= 8.4+        ghc >= 8.4,+        -- These dependencies are used by Development.IDE.Session and are+        -- Haskell specific. So don't use them when building with -fghc-lib!+        ghc-check,+        ghc-paths,+        cryptohash-sha1 >=0.11.100 && <0.12,+        hie-bios == 0.6.*,+        base16-bytestring >=0.1.1 && <0.2     if os(windows)       build-depends:         Win32@@ -119,6 +127,7 @@         Development.IDE.Core.RuleTypes         Development.IDE.Core.Service         Development.IDE.Core.Shake+        Development.IDE.GHC.Compat         Development.IDE.GHC.Error         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation@@ -135,11 +144,24 @@         Development.IDE.Plugin         Development.IDE.Plugin.Completions         Development.IDE.Plugin.CodeAction++    -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses+    -- the real GHC library and the types are incompatible. Furthermore, when+    -- building with ghc-lib we need to make this Haskell agnostic, so no+    -- hie-bios!+    -- We also put these modules into a separate hs-source-dirs so we can avoid+    -- compiling them at all if ghc-lib is not set+    if !flag(ghc-lib)+      hs-source-dirs:+        session-loader+      exposed-modules:+        Development.IDE.Session+      other-modules:+        Development.IDE.Session.VersionCheck     other-modules:         Development.IDE.Core.Compile         Development.IDE.Core.Preprocessor         Development.IDE.Core.FileExists-        Development.IDE.GHC.Compat         Development.IDE.GHC.CPP         Development.IDE.GHC.Orphans         Development.IDE.GHC.Warnings@@ -155,15 +177,29 @@         Development.IDE.Plugin.CodeAction.RuleTypes         Development.IDE.Plugin.Completions.Logic         Development.IDE.Plugin.Completions.Types+    if (impl(ghc > 8.5) && impl(ghc < 8.7)) && !flag(ghc-lib)+      hs-source-dirs: src-ghc86+      other-modules:+        Development.IDE.GHC.HieAst+        Development.IDE.GHC.HieBin+        Development.IDE.GHC.HieTypes+        Development.IDE.GHC.HieDebug+        Development.IDE.GHC.HieUtils     if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)       hs-source-dirs: src-ghc88       other-modules:         Development.IDE.GHC.HieAst+        Development.IDE.GHC.HieBin     if (impl(ghc > 8.9))       hs-source-dirs: src-ghc810       other-modules:         Development.IDE.GHC.HieAst+        Development.IDE.GHC.HieBin     ghc-options: -Wall -Wno-name-shadowing+    -- This is needed to prevent a GHC crash when building+    -- Development.IDE.Session with stack on 8.10.1 on Windows+    if (impl(ghc > 8.9) && os(windows))+      ghc-options: -fexternal-interpreter  executable ghcide-test-preprocessor     default-language: Haskell2010@@ -173,6 +209,43 @@     build-depends:         base == 4.* +benchmark benchHist+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    ghc-options: -Wall -Wno-name-shadowing -threaded+    main-is: bench/hist/Main.hs+    build-tool-depends:+        ghcide:ghcide,+        ghcide:ghcide-bench+    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++    build-depends:+        aeson,+        base == 4.*,+        Chart,+        Chart-diagrams,+        diagrams,+        diagrams-svg,+        directory,+        extra >= 1.7.2,+        filepath,+        shake,+        text,+        yaml+ executable ghcide     if flag(ghc-lib)       buildable: False@@ -190,36 +263,21 @@                 "-with-rtsopts=-I0 -qg -A128M"     main-is: Main.hs     build-depends:-        time,-        async,-        hslogger,-        aeson,         base == 4.*,-        binary,-        base16-bytestring >=0.1.1 && <0.2,-        bytestring,-        containers,-        cryptohash-sha1 >=0.11.100 && <0.12,         data-default,-        deepseq,         directory,         extra,         filepath,-        ghc-check >= 0.3.0.1 && < 0.4,-        ghc-paths,-        ghc,         gitrev,         hashable,         haskell-lsp,         haskell-lsp-types,-        hie-bios >= 0.5.0 && < 0.6,+        hie-bios >= 0.6.0 && < 0.7,         ghcide,         optparse-applicative,-        shake,         text,         unordered-containers     other-modules:-        Utils         Arguments         Paths_ghcide @@ -249,6 +307,7 @@     build-depends:         aeson,         base,+        binary,         bytestring,         containers,         directory,@@ -270,10 +329,13 @@         network-uri,         lens,         lsp-test >= 0.11.0.1 && < 0.12,-        parser-combinators,+        optparse-applicative,+        process,         QuickCheck,         quickcheck-instances,         rope-utf16-splay,+        safe,+        safe-exceptions,         shake,         tasty,         tasty-expected-failure,@@ -281,13 +343,52 @@         tasty-quickcheck,         tasty-rerun,         text-    hs-source-dirs: test/cabal test/exe test/src+    hs-source-dirs: test/cabal test/exe test/src bench/lib     include-dirs: include     ghc-options: -threaded -Wall -Wno-name-shadowing     main-is: Main.hs     other-modules:         Development.IDE.Test         Development.IDE.Test.Runfiles+        Experiments+    default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings+        RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        ViewPatterns++executable ghcide-bench+    default-language: Haskell2010+    build-tool-depends:+        ghcide:ghcide+    build-depends:+        aeson,+        base,+        bytestring,+        containers,+        directory,+        extra,+        filepath,+        ghcide,+        lsp-test >= 0.11.0.2 && < 0.12,+        optparse-applicative,+        process,+        safe-exceptions+    hs-source-dirs: bench/lib bench/exe+    include-dirs: include+    ghc-options: -threaded -Wall -Wno-name-shadowing+    main-is: Main.hs+    other-modules:+        Experiments     default-extensions:         BangPatterns         DeriveFunctor

@@ -0,0 +1,632 @@+{-# LANGUAGE TypeFamilies #-}++{-|+The logic for setting up a ghcide session by tapping into hie-bios.+-}+module Development.IDE.Session (loadSession) where++-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses+-- the real GHC library and the types are incompatible. Furthermore, when+-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios!++import Control.Concurrent.Async+import Control.Concurrent.Extra+import Control.Exception.Safe+import Control.Monad+import Control.Monad.Extra+import Control.Monad.IO.Class+import qualified Crypto.Hash.SHA1 as H+import qualified Data.ByteString.Char8 as B+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Data.Aeson+import Data.Bifunctor+import qualified Data.ByteString.Base16 as B16+import Data.Either.Extra+import Data.Function+import Data.List+import Data.IORef+import Data.Maybe+import Data.Time.Clock+import Data.Version+import Development.IDE.Core.OfInterest+import Development.IDE.Core.Shake+import Development.IDE.GHC.Util+import Development.IDE.Session.VersionCheck+import Development.IDE.Types.Diagnostics+import Development.IDE.Types.Location+import Development.IDE.Types.Logger+import Development.IDE.Types.Options+import Development.Shake (Action)+import GHC.Check+import HIE.Bios+import HIE.Bios.Environment hiding (getCacheDir)+import HIE.Bios.Types+import Language.Haskell.LSP.Core+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+import System.Directory+import System.FilePath+import System.Info+import System.IO++import GHC+import DynFlags+import HscTypes+import Linker+import Module+import NameCache+import Packages++-- | Given a root directory, return a Shake 'Action' which setups an+-- 'IdeGhcSession' given a file.+-- Some of the many things this does:+--+-- * Find the cradle for the file+-- * Get the session options,+-- * Get the GHC lib directory+-- * Make sure the GHC compiletime and runtime versions match+-- * Restart the Shake session+--+-- This is the key function which implements multi-component support. All+-- components mapping to the same hie.yaml file are mapped to the same+-- HscEnv which is updated as new components are discovered.+loadSession :: FilePath -> IO (Action IdeGhcSession)+loadSession dir = do+  -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file+  hscEnvs <- newVar Map.empty :: IO (Var HieMap)+  -- Mapping from a Filepath to HscEnv+  fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)+  -- Version of the mappings above+  version <- newVar 0+  let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)+  let invalidateShakeCache = do+        modifyVar_ version (return . succ)+  -- This caches the mapping from Mod.hs -> hie.yaml+  cradleLoc <- liftIO $ memoIO $ \v -> do+      res <- findCradle v+      -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path+      -- try and normalise that+      -- e.g. see https://github.com/digital-asset/ghcide/issues/126+      res' <- traverse makeAbsolute res+      return $ normalise <$> res'++  dummyAs <- async $ return (error "Uninitialised")+  runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))++  return $ do+    ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras+    IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions++    -- Create a new HscEnv from a hieYaml root and a set of options+    -- If the hieYaml file already has an HscEnv, the new component is+    -- combined with the components in the old HscEnv into a new HscEnv+    -- which contains the union.+    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)+                     -> IO (HscEnv, ComponentInfo, [ComponentInfo])+        packageSetup (hieYaml, cfp, opts, libDir) = do+          -- Parse DynFlags for the newly discovered component+          hscEnv <- emptyHscEnv ideNc libDir+          (df, targets) <- evalGhcEnv hscEnv $+              setOptions opts (hsc_dflags hscEnv)+          let deps = componentDependencies opts ++ maybeToList hieYaml+          dep_info <- getDependencyInfo deps+          -- Now lookup to see whether we are combining with an existing HscEnv+          -- or making a new one. The lookup returns the HscEnv and a list of+          -- information about other components loaded into the HscEnv+          -- (unitId, DynFlag, Targets)+          modifyVar hscEnvs $ \m -> do+              -- Just deps if there's already an HscEnv+              -- Nothing is it's the first time we are making an HscEnv+              let oldDeps = Map.lookup hieYaml m+              let -- Add the raw information about this component to the list+                  -- We will modify the unitId and DynFlags used for+                  -- compilation but these are the true source of+                  -- information.+                  new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info+                                : maybe [] snd oldDeps+                  -- Get all the unit-ids for things in this component+                  inplace = map rawComponentUnitId new_deps++              new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do+                  -- Remove all inplace dependencies from package flags for+                  -- components in this HscEnv+                  let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags+                  let prefix = show rawComponentUnitId+                  -- See Note [Avoiding bad interface files]+                  processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2+                  -- The final component information, mostly the same but the DynFlags don't+                  -- contain any packages which are also loaded+                  -- into the same component.+                  pure $ ComponentInfo rawComponentUnitId+                                       processed_df+                                       uids+                                       rawComponentTargets+                                       rawComponentFP+                                       rawComponentCOptions+                                       rawComponentDependencyInfo+              -- Make a new HscEnv, we have to recompile everything from+              -- scratch again (for now)+              -- It's important to keep the same NameCache though for reasons+              -- that I do not fully understand+              logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))+              hscEnv <- emptyHscEnv ideNc libDir+              newHscEnv <-+                -- Add the options for the current component to the HscEnv+                evalGhcEnv hscEnv $ do+                  _ <- setSessionDynFlags df+                  getSession++              -- Modify the map so the hieYaml now maps to the newly created+              -- HscEnv+              -- Returns+              -- . the new HscEnv so it can be used to modify the+              --   FilePath -> HscEnv map (fileToFlags)+              -- . The information for the new component which caused this cache miss+              -- . The modified information (without -inplace flags) for+              --   existing packages+              pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))+++    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)+                -> IO (IdeResult HscEnvEq,[FilePath])+        session args@(hieYaml, _cfp, _opts, _libDir) = do+          (hscEnv, new, old_deps) <- packageSetup args+          -- Make a map from unit-id to DynFlags, this is used when trying to+          -- resolve imports. (especially PackageImports)+          let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)++          -- For each component, now make a new HscEnvEq which contains the+          -- HscEnv for the hie.yaml file but the DynFlags for that component++          -- New HscEnv for the component in question, returns the new HscEnvEq and+          -- a mapping from FilePath to the newly created HscEnvEq.+          let new_cache = newComponentCache logger hscEnv uids+          (cs, res) <- new_cache new+          -- Modified cache targets for everything else in the hie.yaml file+          -- which now uses the same EPS and so on+          cached_targets <- concatMapM (fmap fst . new_cache) old_deps+          modifyVar_ fileToFlags $ \var -> do+              pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var++          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session+          invalidateShakeCache+          restartShakeSession [kick]++          return (second Map.keys res)++    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])+        consultCradle hieYaml cfp = do+           when optTesting $ eventer $ notifyCradleLoaded cfp+           logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)++           cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml+           -- Display a user friendly progress message here: They probably don't know what a+           -- cradle is+           let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))++           eopts <- withIndefiniteProgress progMsg NotCancellable $+             cradleToOptsAndLibDir cradle cfp++           logDebug logger $ T.pack ("Session loading result: " <> show eopts)+           case eopts of+             -- The cradle gave us some options so get to work turning them+             -- into and HscEnv.+             Right (opts, libDir) -> do+               installationCheck <- ghcVersionChecker libDir+               case installationCheck of+                 InstallationNotFound{..} ->+                     error $ "GHC installation not found in libdir: " <> libdir+                 InstallationMismatch{..} ->+                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])+                 InstallationChecked _compileTime _ghcLibCheck ->+                   session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)+             -- Failure case, either a cradle error or the none cradle+             Left err -> do+               dep_info <- getDependencyInfo (maybeToList hieYaml)+               let ncfp = toNormalizedFilePath' cfp+               let res = (map (renderCradleError ncfp) err, Nothing)+               modifyVar_ fileToFlags $ \var -> do+                 pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var+               return (res,[])++    -- This caches the mapping from hie.yaml + Mod.hs -> [String]+    -- Returns the Ghc session and the cradle dependencies+    let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])+        sessionOpts (hieYaml, file) = do+          v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags+          cfp <- canonicalizePath file+          case HM.lookup (toNormalizedFilePath' cfp) v of+            Just (opts, old_di) -> do+              deps_ok <- checkDependencyInfo old_di+              if not deps_ok+                then do+                  -- If the dependencies are out of date then clear both caches and start+                  -- again.+                  modifyVar_ fileToFlags (const (return Map.empty))+                  -- Keep the same name cache+                  modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )+                  consultCradle hieYaml cfp+                else return (opts, Map.keys old_di)+            Nothing -> consultCradle hieYaml cfp++    -- The main function which gets options for a file. We only want one of these running+    -- at a time. Therefore the IORef contains the currently running cradle, if we try+    -- to get some more options then we wait for the currently running action to finish+    -- before attempting to do so.+    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])+        getOptions file = do+            hieYaml <- cradleLoc file+            sessionOpts (hieYaml, file) `catch` \e ->+                return (([renderPackageSetupException file e], Nothing),[])++    returnWithVersion $ \file -> do+      liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do+        -- If the cradle is not finished, then wait for it to finish.+        void $ wait as+        as <- async $ getOptions file+        return (as, wait as)++-- | Run the specific cradle on a specific FilePath via hie-bios.+-- This then builds dependencies or whatever based on the cradle, gets the+-- GHC options/dynflags needed for the session and the GHC library directory+cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath+                      -> IO (Either [CradleError] (ComponentOptions, FilePath))+cradleToOptsAndLibDir cradle file = do+    -- Start off by getting the session options+    let showLine s = hPutStrLn stderr ("> " ++ s)+    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle+    cradleRes <- runCradle (cradleOptsProg cradle) showLine file+    case cradleRes of+        CradleSuccess r -> do+            -- Now get the GHC lib dir+            libDirRes <- getRuntimeGhcLibDir cradle+            case libDirRes of+                -- This is the successful path+                CradleSuccess libDir -> pure (Right (r, libDir))+                CradleFail err -> return (Left [err])+                -- For the None cradle perhaps we still want to report an Info+                -- message about the fact that the file is being ignored.+                CradleNone -> return (Left [])++        CradleFail err -> return (Left [err])+        -- Same here+        CradleNone -> return (Left [])++emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv+emptyHscEnv nc libDir = do+    env <- runGhc (Just libDir) getSession+    initDynLinker env+    pure $ setNameCache nc env++-- | Convert a target to a list of potential absolute paths.+-- A TargetModule can be anywhere listed by the supplied include+-- directories+-- A target file is a relative path but with a specific prefix so just need+-- to canonicalise it.+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]+targetToFile is (TargetModule mod) = do+    let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]+        exts = ["hs", "hs-boot", "lhs"]+    mapM (fmap toNormalizedFilePath' . canonicalizePath) fps+targetToFile _ (TargetFile f _) = do+  f' <- canonicalizePath f+  return [toNormalizedFilePath' f']++setNameCache :: IORef NameCache -> HscEnv -> HscEnv+setNameCache nc hsc = hsc { hsc_NC = nc }+++-- | Create a mapping from FilePaths to HscEnvEqs+newComponentCache+         :: Logger+         -> HscEnv+         -> [(InstalledUnitId, DynFlags)]+         -> ComponentInfo+         -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))+newComponentCache logger hsc_env uids ci = do+    let df = componentDynFlags ci+    let hscEnv' = hsc_env { hsc_dflags = df+                          , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }++    henv <- newHscEnvEq hscEnv' uids+    let res = (([], Just henv), componentDependencyInfo ci)+    logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))++    let is = importPaths df+    ctargets <- concatMapM (targetToFile is  . targetId) (componentTargets ci)+    -- A special target for the file which caused this wonderful+    -- component to be created. In case the cradle doesn't list all the targets for+    -- the component, in which case things will be horribly broken anyway.+    -- Otherwise, we will immediately attempt to reload this module which+    -- causes an infinite loop and high CPU usage.+    let special_target = (componentFP ci, res)+    let xs = map (,res) ctargets+    return (special_target:xs, res)++{- Note [Avoiding bad interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Originally, we set the cache directory for the various components once+on the first occurrence of the component.+This works fine if these components have no references to each other,+but you have components that depend on each other, the interface files are+updated for each component.+After restarting the session and only opening the component that depended+on the other, suddenly the interface files of this component are stale.+However, from the point of view of `ghcide`, they do not look stale,+thus, not regenerated and the IDE shows weird errors such as:+```+typecheckIface+Declaration for Rep_ClientRunFlags+Axiom branches Rep_ClientRunFlags:+  Failed to load interface for ‘Distribution.Simple.Flag’+  Use -v to see a list of the files searched for.+```+and+```+expectJust checkFamInstConsistency+CallStack (from HasCallStack):+  error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes+  expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst+```++To mitigate this, we set the cache directory for each component dependent+on the components of the current `HscEnv`, additionally to the component options+of the respective components.+Assume two components, c1, c2, where c2 depends on c1, and the options of the+respective components are co1, co2.+If we want to load component c2, followed by c1, we set the cache directory for+each component in this way:++  * Load component c2+    * (Cache Directory State)+        - name of c2 + co2+  * Load component c1+    * (Cache Directory State)+        - name of c2 + name of c1 + co2+        - name of c2 + name of c1 + co1++Overall, we created three cache directories. If we opened c1 first, then we+create a fourth cache directory.+This makes sure that interface files are always correctly updated.++Since this causes a lot of recompilation, we only update the cache-directory,+if the dependencies of a component have really changed.+E.g. when you load two executables, they can not depend on each other. They+should be filtered out, such that we dont have to re-compile everything.+-}++-- | Set the cache-directory based on the ComponentOptions and a list of+-- internal packages.+-- For the exact reason, see Note [Avoiding bad interface files].+setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags+setCacheDir logger prefix hscComponents comps dflags = do+    cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)+    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir+    pure $ dflags+          & setHiDir cacheDir+          & setHieDir cacheDir+++renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic+renderCradleError nfp (CradleError _ _ec t) =+  ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t))++-- See Note [Multi Cradle Dependency Info]+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))++-- This is pristine information about a component+data RawComponentInfo = RawComponentInfo+  { rawComponentUnitId :: InstalledUnitId+  -- | Unprocessed DynFlags. Contains inplace packages such as libraries.+  -- We do not want to use them unprocessed.+  , rawComponentDynFlags :: DynFlags+  -- | All targets of this components.+  , rawComponentTargets :: [Target]+  -- | Filepath which caused the creation of this component+  , rawComponentFP :: NormalizedFilePath+  -- | Component Options used to load the component.+  , rawComponentCOptions :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info].+  , rawComponentDependencyInfo :: DependencyInfo+  }++-- This is processed information about the component, in particular the dynflags will be modified.+data ComponentInfo = ComponentInfo+  { componentUnitId :: InstalledUnitId+  -- | Processed DynFlags. Does not contain inplace packages such as local+  -- libraries. Can be used to actually load this Component.+  , componentDynFlags :: DynFlags+  -- | Internal units, such as local libraries, that this component+  -- is loaded with. These have been extracted from the original+  -- ComponentOptions.+  , _componentInternalUnits :: [InstalledUnitId]+  -- | All targets of this components.+  , componentTargets :: [Target]+  -- | Filepath which caused the creation of this component+  , componentFP :: NormalizedFilePath+  -- | Component Options used to load the component.+  , _componentCOptions :: ComponentOptions+  -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file+  -- to last modification time. See Note [Multi Cradle Dependency Info]+  , componentDependencyInfo :: DependencyInfo+  }++-- | Check if any dependency has been modified lately.+checkDependencyInfo :: DependencyInfo -> IO Bool+checkDependencyInfo old_di = do+  di <- getDependencyInfo (Map.keys old_di)+  return (di == old_di)++-- Note [Multi Cradle Dependency Info]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why do we implement our own file modification tracking here?+-- The primary reason is that the custom caching logic is quite complicated and going into shake+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to+-- use shake rules rather than IO but eventually gave up.++-- | Computes a mapping from a filepath to its latest modification date.+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead+-- of letting shake take care of it.+getDependencyInfo :: [FilePath] -> IO DependencyInfo+getDependencyInfo fs = Map.fromList <$> mapM do_one fs++  where+    tryIO :: IO a -> IO (Either IOException a)+    tryIO = try++    do_one :: FilePath -> IO (FilePath, Maybe UTCTime)+    do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)++-- | This function removes all the -package flags which refer to packages we+-- are going to deal with ourselves. For example, if a executable depends+-- on a library component, then this function will remove the library flag+-- from the package flags for the executable+--+-- There are several places in GHC (for example the call to hptInstances in+-- tcRnImports) which assume that all modules in the HPT have the same unit+-- ID. Therefore we create a fake one and give them all the same unit id.+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])+removeInplacePackages us df = (df { packageFlags = ps+                                  , thisInstalledUnitId = fake_uid }, uids)+  where+    (uids, ps) = partitionEithers (map go (packageFlags df))+    fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")+    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us+                                                  then Left (toInstalledUnitId u)+                                                  else Right p+    go p = Right p++-- | Memoize an IO function, with the characteristics:+--+--   * If multiple people ask for a result simultaneously, make sure you only compute it once.+--+--   * If there are exceptions, repeatedly reraise them.+--+--   * If the caller is aborted (async exception) finish computing it anyway.+memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)+memoIO op = do+    ref <- newVar Map.empty+    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->+        case Map.lookup k mp of+            Nothing -> do+                res <- onceFork $ op k+                return (Map.insert k res mp, res)+            Just res -> return (mp, res)++-- | Throws if package flags are unsatisfiable+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])+setOptions (ComponentOptions theOpts compRoot _) dflags = do+    (dflags', targets) <- addCmdOpts theOpts dflags+    let dflags'' =+          -- disabled, generated directly by ghcide instead+          flip gopt_unset Opt_WriteInterface $+          -- disabled, generated directly by ghcide instead+          -- also, it can confuse the interface stale check+          dontWriteHieFiles $+          setIgnoreInterfacePragmas $+          setLinkerOptions $+          disableOptimisation $+          makeDynFlagsAbsolute compRoot dflags'+    -- initPackages parses the -package flags and+    -- sets up the visibility for each component.+    -- Throws if a -package flag cannot be satisfied.+    (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''+    return (final_df, targets)+++-- we don't want to generate object code so we compile to bytecode+-- (HscInterpreted) which implies LinkInMemory+-- HscInterpreted+setLinkerOptions :: DynFlags -> DynFlags+setLinkerOptions df = df {+    ghcLink   = LinkInMemory+  , hscTarget = HscNothing+  , ghcMode = CompManager+  }++setIgnoreInterfacePragmas :: DynFlags -> DynFlags+setIgnoreInterfacePragmas df =+    gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges++disableOptimisation :: DynFlags -> DynFlags+disableOptimisation df = updOptLevel 0 df++setHiDir :: FilePath -> DynFlags -> DynFlags+setHiDir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { hiDir      = Just f}++getCacheDir :: String -> [String] -> IO FilePath+getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)+    where+        -- Create a unique folder per set of different GHC options, assuming that each different set of+        -- GHC options will create incompatible interface files.+        opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts)++-- | Sub directory for the cache path+cacheDir :: String+cacheDir = "ghcide"++notifyCradleLoaded :: FilePath -> FromServerMessage+notifyCradleLoaded fp =+    NotCustomServer $+    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $+    toJSON fp++cradleLoadedMethod :: T.Text+cradleLoadedMethod = "ghcide/cradle/loaded"++----------------------------------------------------------------------------------------------------++data PackageSetupException+    = PackageSetupException+        { message     :: !String+        }+    | GhcVersionMismatch+        { compileTime :: !Version+        , runTime     :: !Version+        }+    | PackageCheckFailed !NotCompatibleReason+    deriving (Eq, Show, Typeable)++instance Exception PackageSetupException++-- | Wrap any exception as a 'PackageSetupException'+wrapPackageSetupException :: IO a -> IO a+wrapPackageSetupException = handleAny $ \case+  e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE+  e -> (throwIO . PackageSetupException . show) e++showPackageSetupException :: PackageSetupException -> String+showPackageSetupException GhcVersionMismatch{..} = unwords+    ["ghcide compiled against GHC"+    ,showVersion compileTime+    ,"but currently using"+    ,showVersion runTime+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."+    ]+showPackageSetupException PackageSetupException{..} = unwords+    [ "ghcide compiled by GHC", showVersion compilerVersion+    , "failed to load packages:", message <> "."+    , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]+showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords+    ["ghcide compiled with package "+    , packageName <> "-" <> showVersion compileTime+    ,"but project uses package"+    , packageName <> "-" <> showVersion runTime+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."+    ]+showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords+    ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi+    ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi+    ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."+    ]++renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)+renderPackageSetupException fp e =+    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)

@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell #-}++-- | This module exists to circumvent a compile time exception on Windows with+-- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session.+-- See https://github.com/digital-asset/ghcide/pull/697+module Development.IDE.Session.VersionCheck (ghcVersionChecker) where++import Data.Maybe+import GHC.Check+-- Only use this for checking against the compile time GHC libDir!+-- Use getRuntimeGhcLibDir from hie-bios instead for everything else+-- otherwise binaries will not be distributable since paths will be baked into them+import qualified GHC.Paths+import System.Environment++ghcVersionChecker :: GhcVersionChecker+ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))

@@ -0,0 +1,399 @@+{-+Binary serialization for .hie files.+-}+{- HLINT ignore -}+{-# LANGUAGE ScopedTypeVariables #-}+module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where++import GHC.Settings               ( maybeRead )++import Config                     ( cProjectVersion )+import Binary+import BinIface                   ( getDictFastString )+import FastMutInt+import FastString                 ( FastString )+import Module                     ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply                 ( takeUniqFromSupply )+import Unique+import UniqFM+import IfaceEnv++import qualified Data.Array as A+import Data.IORef+import Data.ByteString            ( ByteString )+import qualified Data.ByteString  as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List                  ( mapAccumR )+import Data.Word                  ( Word8, Word32 )+import Control.Monad              ( replicateM, when )+import System.Directory           ( createDirectoryIfMissing )+import System.FilePath            ( takeDirectory )++import HieTypes++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+  = ExternalName !Module !OccName !SrcSpan+  | LocalName !OccName !SrcSpan+  | KnownKeyName !Unique+  deriving (Eq)++instance Ord HieName where+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+    -- Not actually non determinstic as it is a KnownKey+  compare ExternalName{} _ = LT+  compare LocalName{} ExternalName{} = GT+  compare LocalName{} _ = LT+  compare KnownKeyName{} _ = GT++instance Outputable HieName where+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+  case lookupKnownKeyName u of+    Just n -> nameOccName n+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+                        (ppr (unpkUnique u))+++data HieSymbolTable = HieSymbolTable+  { hie_symtab_next :: !FastMutInt+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))+  }++data HieDictionary = HieDictionary+  { hie_dict_next :: !FastMutInt -- The next index to use+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+  }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+  mapM_ (putByte bh) $ BS.unpack xs+  putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+  bh0 <- openBinMem initBinMemSize++  -- Write the header: hieHeader followed by the+  -- hieVersion and the GHC version used to generate this file+  mapM_ (putByte bh0) hieMagic+  putBinLine bh0 $ BSC.pack $ show hieVersion+  putBinLine bh0 $ ghcVersion++  -- remember where the dictionary pointer will go+  dict_p_p <- tellBin bh0+  put_ bh0 dict_p_p++  -- remember where the symbol table pointer will go+  symtab_p_p <- tellBin bh0+  put_ bh0 symtab_p_p++  -- Make some intial state+  symtab_next <- newFastMutInt+  writeFastMutInt symtab_next 0+  symtab_map <- newIORef emptyUFM+  let hie_symtab = HieSymbolTable {+                      hie_symtab_next = symtab_next,+                      hie_symtab_map  = symtab_map }+  dict_next_ref <- newFastMutInt+  writeFastMutInt dict_next_ref 0+  dict_map_ref <- newIORef emptyUFM+  let hie_dict = HieDictionary {+                      hie_dict_next = dict_next_ref,+                      hie_dict_map  = dict_map_ref }++  -- put the main thing+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+                                           (putName hie_symtab)+                                           (putFastString hie_dict)+  put_ bh hiefile++  -- write the symtab pointer at the front of the file+  symtab_p <- tellBin bh+  putAt bh symtab_p_p symtab_p+  seekBin bh symtab_p++  -- write the symbol table itself+  symtab_next' <- readFastMutInt symtab_next+  symtab_map'  <- readIORef symtab_map+  putSymbolTable bh symtab_next' symtab_map'++  -- write the dictionary pointer at the front of the file+  dict_p <- tellBin bh+  putAt bh dict_p_p dict_p+  seekBin bh dict_p++  -- write the dictionary itself+  dict_next <- readFastMutInt dict_next_ref+  dict_map  <- readIORef dict_map_ref+  putDictionary bh dict_next dict_map++  -- and send the result to the file+  createDirectoryIfMissing True (takeDirectory hie_file_path)+  writeBinMem bh hie_file_path+  return ()++data HieFileResult+  = HieFileResult+  { hie_file_result_version :: Integer+  , hie_file_result_ghc_version :: ByteString+  , hie_file_result :: HieFile+  }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion ncu file = do+  bh0 <- readBinMem file++  (hieVersion, ghcVersion) <- readHieFileHeader file bh0++  if readVersion (hieVersion, ghcVersion)+  then do+    hieFile <- readHieFileContents bh0 ncu+    return $ Right (HieFileResult hieVersion ghcVersion hieFile)+  else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult+readHieFile ncu file = do++  bh0 <- readBinMem file++  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++  -- Check if the versions match+  when (readHieVersion /= hieVersion) $+    panic $ unwords ["readHieFile: hie file versions don't match for file:"+                    , file+                    , "Expected"+                    , show hieVersion+                    , "but got", show readHieVersion+                    ]+  hieFile <- readHieFileContents bh0 ncu+  return $ HieFileResult hieVersion ghcVersion hieFile++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+  where+    loop acc = do+      char <- get bh :: IO Word8+      if char == 10 -- ASCII newline '\n'+      then return acc+      else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+  -- Read the header+  magic <- replicateM hieMagicLen (get bh0)+  version <- BSC.unpack <$> readBinLine bh0+  case maybeRead version of+    Nothing ->+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+                      , show version+                      ]+    Just readHieVersion -> do+      ghcVersion <- readBinLine bh0++      -- Check if the header is valid+      when (magic /= hieMagic) $+        panic $ unwords ["readHieFileHeader: headers don't match for file:"+                        , file+                        , "Expected"+                        , show hieMagic+                        , "but got", show magic+                        ]+      return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile+readHieFileContents bh0 ncu = do++  dict  <- get_dictionary bh0++  -- read the symbol table so we are capable of reading the actual data+  bh1 <- do+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+                                               (getDictFastString dict)+      symtab <- get_symbol_table bh1+      let bh1' = setUserData bh1+               $ newReadState (getSymTabName symtab)+                              (getDictFastString dict)+      return bh1'++  -- load the actual data+  hiefile <- get bh1+  return hiefile+  where+    get_dictionary bin_handle = do+      dict_p <- get bin_handle+      data_p <- tellBin bin_handle+      seekBin bin_handle dict_p+      dict <- getDictionary bin_handle+      seekBin bin_handle data_p+      return dict++    get_symbol_table bh1 = do+      symtab_p <- get bh1+      data_p'  <- tellBin bh1+      seekBin bh1 symtab_p+      symtab <- getSymbolTable bh1 ncu+      seekBin bh1 data_p'+      return symtab++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+                              hie_dict_map  = out_r}  bh f+  = do+    out <- readIORef out_r+    let unique = getUnique f+    case lookupUFM out unique of+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           put_ bh (fromIntegral j :: Word32)+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+  put_ bh next_off+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+  mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+  sz <- get bh+  od_names <- replicateM sz (getHieName bh)+  updateNameCache ncu $ \nc ->+    let arr = A.listArray (0,sz-1) names+        (nc', names) = mapAccumR fromHieName nc od_names+        in (nc',arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+  i :: Word32 <- get bh+  return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+  symmap <- readIORef ref+  case lookupUFM symmap name of+    Just (off, ExternalName mod occ (UnhelpfulSpan _))+      | isGoodSrcSpan (nameSrcSpan name) -> do+      let hieName = ExternalName mod occ (nameSrcSpan name)+      writeIORef ref $! addToUFM symmap name (off, hieName)+      put_ bh (fromIntegral off :: Word32)+    Just (off, LocalName _occ span)+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do+      writeIORef ref $! addToUFM symmap name (off, toHieName name)+      put_ bh (fromIntegral off :: Word32)+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)+    Nothing -> do+        off <- readFastMutInt next+        writeFastMutInt next (off+1)+        writeIORef ref $! addToUFM symmap name (off, toHieName name)+        put_ bh (fromIntegral off :: Word32)++  where+    notLocal :: HieName -> Bool+    notLocal LocalName{} = False+    notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+  | isKnownKeyName name = KnownKeyName (nameUnique name)+  | isExternalName name = ExternalName (nameModule name)+                                       (nameOccName name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+    let cache = nsNames nc+    in case lookupOrigNameCache cache mod occ of+         Just name+           | nameSrcSpan name == span -> (nc, name)+           | otherwise ->+             let name' = setNameLoc name span+                 new_cache = extendNameCache cache mod occ name'+             in ( nc{ nsNames = new_cache }, name' )+         Nothing ->+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+               name       = mkExternalName uniq mod occ span+               new_cache  = extendNameCache cache mod occ name+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+        name       = mkInternalName uniq occ span+    in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+    Nothing -> pprPanic "fromHieName:unknown known-key unique"+                        (ppr (unpkUnique u))+    Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+  putByte bh 0+  put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+  putByte bh 1+  put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+  putByte bh 2+  put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+  t <- getByte bh+  case t of+    0 -> do+      (modu, occ, span) <- get bh+      return $ ExternalName modu occ span+    1 -> do+      (occ, span) <- get bh+      return $ LocalName occ span+    2 -> do+      (c,i) <- get bh+      return $ KnownKeyName $ mkUnique c i+    _ -> panic "HieBin.getHieName: invalid tag"

@@ -0,0 +1,1784 @@++{-+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile++Main functions for .hie file generation+-}+{- HLINT ignore -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+module Development.IDE.GHC.HieAst ( mkHieFile ) where++import Avail                      ( Avails )+import Bag                        ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class                      ( FunDep )+import CoreUtils                  ( exprType )+import ConLike                    ( conLikeName )+import Desugar                    ( deSugarExpr )+import FieldLabel+import HsSyn+import HscTypes+import Module                     ( ModuleName, ml_hs_file )+import MonadUtils                 ( concatMapM, liftIO )+import Name                       ( Name, nameSrcSpan, setNameLoc )+import SrcLoc+import TcHsSyn                    ( hsLitType, hsPatType )+import Type                       ( mkFunTys, Type )+import TysWiredIn                 ( mkListTy, mkSumTy )+import Var                        ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface                    ( mkIfaceExports )++import Development.IDE.GHC.HieTypes+import Development.IDE.GHC.HieUtils++import qualified Data.Array as A+import qualified Data.ByteString as BS+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Data                  ( Data, Typeable )+import Data.List                  (foldl',  foldl1' )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class  ( lift )++-- These synonyms match those defined in main/GHC.hs+type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]+                         , Maybe [(LIE GhcRn, Avails)]+                         , Maybe LHsDocString )+type TypecheckedSource = LHsBinds GhcTc++-- | Marks that a field uses the GhcRn variant even when the pass+-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because+-- HsType GhcTc should never occur.+type family NoGhcTc (p :: *) where+    -- this way, GHC can figure out that the result is a GhcPass+  NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)+  NoGhcTc other          = other++type family NoGhcTcPass (p :: Pass) :: Pass where+  NoGhcTcPass 'Typechecked = 'Renamed+  NoGhcTcPass other        = other++{- Note [Name Remapping]+The Typechecker introduces new names for mono names in AbsBinds.+We don't care about the distinction between mono and poly bindings,+so we replace all occurrences of the mono name with the poly name.+-}+newtype HieState = HieState+  { name_remapping :: M.Map Name Id+  }++initState :: HieState+initState = HieState M.empty++class ModifyState a where -- See Note [Name Remapping]+  addSubstitution :: a -> a -> HieState -> HieState++instance ModifyState Name where+  addSubstitution _ _ hs = hs++instance ModifyState Id where+  addSubstitution mono poly hs =+    hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}++modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState = foldr go id+  where+    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f+    go _ f = f++type HieM = ReaderT HieState Hsc++-- | Construct an 'HieFile' from the outputs of the typechecker.+mkHieFile :: ModSummary+          -> TcGblEnv+          -> RenamedSource+          -> BS.ByteString+          -> Hsc HieFile+mkHieFile ms ts rs src = do+  let tc_binds = tcg_binds ts+  (asts', arr) <- getCompressedAsts tc_binds rs+  let Just src_file = ml_hs_file $ ms_location ms+  return $ HieFile+      { hie_hs_file = src_file+      , hie_module = ms_mod ms+      , hie_types = arr+      , hie_asts = asts'+      -- mkIfaceExports sorts the AvailInfos for stability+      , hie_exports = mkIfaceExports (tcg_exports ts)+      , hie_hs_src = src+      }++getCompressedAsts :: TypecheckedSource -> RenamedSource+  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+  asts <- enrichHie ts rs+  return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do+    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts+    rasts <- processGrp hsGrp+    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports+    exps <- toHie $ fmap (map $ IEC Export . fst) exports+    let spanFile children = case children of+          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+                             (realSrcSpanEnd   $ nodeSpan $ last children)++        modulify xs =+          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++        asts = HieASTs+          $ resolveTyVarScopes+          $ M.map (modulify . mergeSortAsts)+          $ M.fromListWith (++)+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++        flat_asts = concat+          [ tasts+          , rasts+          , imps+          , exps+          ]+    return asts+  where+    processGrp grp = concatM+      [ toHie $ fmap (RS ModuleScope ) hs_valds grp+      , toHie $ hs_splcds grp+      , toHie $ hs_tyclds grp+      , toHie $ hs_derivds grp+      , toHie $ hs_fixds grp+      , toHie $ hs_defds grp+      , toHie $ hs_fords grp+      , toHie $ hs_warnds grp+      , toHie $ hs_annds grp+      , toHie $ hs_ruleds grp+      ]++getRealSpan :: SrcSpan -> Maybe Span+getRealSpan (RealSrcSpan sp) = Just sp+getRealSpan _ = Nothing++grhss_span :: GRHSs p body -> SrcSpan+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)+grhss_span (XGRHSs _) = error "XGRHS has no span"++bindingsOnly :: [Context Name] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+          info = mempty{identInfo = S.singleton c}+  _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local tranformation, but scopes of bindings cannot be known locally,+hence we have to push the relevant info down into the binding nodes.+We use the following types (*Context and *Scoped) to wrap things and+carry the required info+(Maybe Span) always carries the span of the entire binding, including rhs+-}+data Context a = C ContextInfo a -- Used for names and bindings++data RContext a = RC RecFieldContext a+data RFContext a = RFC RecFieldContext (Maybe Span) a+-- ^ context for record fields++data IEContext a = IEC IEType a+-- ^ context for imports/exports++data BindContext a = BC BindType Scope a+-- ^ context for imports/exports++data PatSynFieldContext a = PSC (Maybe Span) a+-- ^ context for pattern synonym fields.++data SigContext a = SC SigInfo a+-- ^ context for type signatures++data SigInfo = SI SigType (Maybe Span)++data SigType = BindSig | ClassSig | InstSig++data RScoped a = RS Scope a+-- ^ Scope spans over everything to the right of a, (mostly) not+-- including a itself+-- (Includes a in a few special cases like recursive do bindings) or+-- let/where bindings++-- | Pattern scope+data PScoped a = PS (Maybe Span)+                    Scope       -- ^ use site of the pattern+                    Scope       -- ^ pattern to the right of a, not including a+                    a+  deriving (Typeable, Data) -- Pattern Scope++{- Note [TyVar Scopes]+Due to -XScopedTypeVariables, type variables can be in scope quite far from+their original binding. We resolve the scope of these type variables+in a separate pass+-}+data TScoped a = TS TyVarScope a -- TyVarScope++data TVScoped a = TVS TyVarScope Scope a -- TyVarScope+-- ^ First scope remains constant+-- Second scope is used to build up the scope of a tyvar over+-- things to its right, ala RScoped++-- | Each element scopes over the elements to the right+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]+listScopes _ [] = []+listScopes rhsScope [pat] = [RS rhsScope pat]+listScopes rhsScope (pat : pats) = RS sc pat : pats'+  where+    pats'@((RS scope p):_) = listScopes rhsScope pats+    sc = combineScopes scope $ mkScope $ getLoc p++-- | 'listScopes' specialised to 'PScoped' things+patScopes+  :: Maybe Span+  -> Scope+  -> Scope+  -> [LPat (GhcPass p)]+  -> [PScoped (LPat (GhcPass p))]+patScopes rsp useScope patScope xs =+  map (\(RS sc a) -> PS rsp useScope sc a) $+    listScopes patScope xs++-- | 'listScopes' specialised to 'TVScoped' things+tvScopes+  :: TyVarScope+  -> Scope+  -> [LHsTyVarBndr a]+  -> [TVScoped (LHsTyVarBndr a)]+tvScopes tvScope rhsScope xs =+  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs++{- Note [Scoping Rules for SigPat]+Explicitly quantified variables in pattern type signatures are not+brought into scope in the rhs, but implicitly quantified variables+are (HsWC and HsIB).+This is unlike other signatures, where explicitly quantified variables+are brought into the RHS Scope+For example+foo :: forall a. ...;+foo = ... -- a is in scope here++bar (x :: forall a. a -> a) = ... -- a is not in scope here+--   ^ a is in scope here (pattern body)++bax (x :: a) = ... -- a is in scope here+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explictly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+                                                GhcRn+                                                (Shielded (LHsType GhcRn)))+  ProtectedSig GhcTc = NoExt++class ProtectSig a where+  protectSig :: Scope -> XSigPat a -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+  loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+  protectSig _ _ = NoExt++instance ProtectSig GhcRn where+  protectSig sc (HsWC a (HsIB b sig)) =+    HsWC a (HsIB b (SH sc sig))+  protectSig _ _ = error "protectSig not given HsWC (HsIB)"++class HasLoc a where+  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can+  -- know what their implicit bindings are scoping over+  loc :: a -> SrcSpan++instance HasLoc thing => HasLoc (TScoped thing) where+  loc (TS _ a) = loc a++instance HasLoc thing => HasLoc (PScoped thing) where+  loc (PS _ _ _ a) = loc a++instance HasLoc (LHsQTyVars GhcRn) where+  loc (HsQTvs _ vs) = loc vs+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where+  loc (HsIB _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where+  loc (HsWC _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc (Located a) where+  loc (L l _) = l++instance HasLoc a => HasLoc [a] where+  loc [] = noSrcSpan+  loc xs = foldl1' combineSrcSpans $ map loc xs++instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where+  loc (FamEqn _ a b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]+  loc _ = noSrcSpan+{-+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where+  loc (HsValArg tm) = loc tm+  loc (HsTypeArg _ ty) = loc ty+  loc (HsArgPar sp)  = sp+-}++instance HasLoc (HsDataDefn GhcRn) where+  loc def@(HsDataDefn{}) = loc $ dd_cons def+    -- Only used for data family instances, so we only need rhs+    -- Most probably the rest will be unhelpful anyway+  loc _ = noSrcSpan++-- | The main worker class+class ToHie a where+  toHie :: a -> HieM [HieAST Type]++-- | Used to collect type info+class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]++instance (ToHie a) => ToHie [a] where+  toHie = concatMapM toHie++instance (ToHie a) => ToHie (Bag a) where+  toHie = toHie . bagToList++instance (ToHie a) => ToHie (Maybe a) where+  toHie = maybe (pure []) toHie++instance ToHie (Context (Located NoExt)) where+  toHie _ = pure []++instance ToHie (TScoped NoExt) where+  toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+  toHie (IEC c (L (RealSrcSpan span) mname)) =+      pure $ [Node (NodeInfo S.empty [] idents) span []]+    where details = mempty{identInfo = S.singleton (IEThing c)}+          idents = M.singleton (Left mname) details+  toHie _ = pure []++instance ToHie (Context (Located Var)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name')+        -> do+        m <- asks name_remapping+        let name = M.findWithDefault name' (varName name') m+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right $ varName name)+                          (IdentifierDetails (Just $ varType name')+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++instance ToHie (Context (Located Name)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name') -> do+        m <- asks name_remapping+        let name = case M.lookup name' m of+              Just var -> varName var+              Nothing -> name'+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right name)+                          (IdentifierDetails Nothing+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped Type) where+  toHie _ = pure []++instance HasType (LHsBind GhcRn) where+  getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+  getTypeNode (L spn bind) = case bind of+      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+      _ -> makeNode bind spn++instance HasType (LPat GhcRn) where+  getTypeNode (L spn pat) = makeNode pat spn++instance HasType (LPat GhcTc) where+  getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn++-- | This instance tries to construct 'HieAST' nodes which include the type of+-- the expression. It is not yet possible to do this efficiently for all+-- expression forms, so we skip filling in the type for those inputs.+--+-- 'HsApp', for example, doesn't have any type information available directly on+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then+-- query the type of that. Yet both the desugaring call and the type query both+-- involve recursive calls to the function and argument! This is particularly+-- problematic when you realize that the HIE traversal will eventually visit+-- those nodes too and ask for their types again.+--+-- Since the above is quite costly, we just skip cases where computing the+-- expression's type is going to be expensive.+--+-- See #16233+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = lift $+    -- Some expression forms have their type immediately available+    let tyOpt = case e' of+          HsLit _ l -> Just (hsLitType l)+          HsOverLit _ o -> Just (overLitType o)++          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)++          ExplicitList  ty _ _   -> Just (mkListTy ty)+          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)+          HsDo          ty _ _   -> Just ty+          HsMultiIf     ty _     -> Just ty++          _ -> Nothing++    in+    case tyOpt of+      _ | skipDesugaring e' -> fallback+        | otherwise -> do+            hs_env <- Hsc $ \e w -> return (e,w)+            (_,mbe) <- liftIO $ deSugarExpr hs_env e+            maybe fallback (makeTypeNode e' spn . exprType) mbe+    where+      fallback = makeNode e' spn++      matchGroupType :: MatchGroupTc -> Type+      matchGroupType (MatchGroupTc args res) = mkFunTys args res++      -- | Skip desugaring of these expressions for performance reasons.+      --+      -- See impact on Haddock output (esp. missing type annotations or links)+      -- before marking more things here as 'False'. See impact on Haddock+      -- performance before marking more things as 'True'.+      skipDesugaring :: HsExpr a -> Bool+      skipDesugaring e = case e of+        HsVar{}        -> False+        HsUnboundVar{} -> False+        HsConLikeOut{} -> False+        HsRecFld{}     -> False+        HsOverLabel{}  -> False+        HsIPVar{}      -> False+        HsWrap{}       -> False+        _              -> True++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a (LHsExpr a))+         , ToHie (LHsExpr a)+         , ToHie (Located (PatSynBind a a))+         , HasType (LHsBind a)+         , ModifyState (IdP a)+         , Data (HsBind a)+         ) => ToHie (BindContext (LHsBind a)) where+  toHie (BC context scope b@(L span bind)) =+    concatM $ getTypeNode b : case bind of+      FunBind{fun_id = name, fun_matches = matches} ->+        [ toHie $ C (ValBind context scope $ getRealSpan span) name+        , toHie matches+        ]+      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->+        [ toHie $ PS (getRealSpan span) scope NoScope lhs+        , toHie rhs+        ]+      VarBind{var_rhs = expr} ->+        [ toHie expr+        ]+      AbsBinds{abs_exports = xs, abs_binds = binds} ->+        [ local (modifyState xs) $ -- Note [Name Remapping]+            toHie $ fmap (BC context scope) binds+        ]+      PatSynBind _ psb ->+        [ toHie $ L span psb -- PatSynBinds only occur at the top level+        ]+      XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+         ) => ToHie (MatchGroup a body) where+  toHie mg = concatM $ case mg of+    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+      [ pure $ locOnly span+      , toHie alts+      ]+    MG{} -> []+    XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (HsPatSynDir a)+         ) => ToHie (Located (PatSynBind a a)) where+    toHie (L sp psb) = concatM $ case psb of+      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->+        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var+        , toHie $ toBind dets+        , toHie $ PS Nothing lhsScope NoScope pat+        , toHie dir+        ]+        where+          lhsScope = combineScopes varScope detScope+          varScope = mkLScope var+          detScope = case dets of+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args+            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)+            (RecCon r) -> foldr go NoScope r+          go (RecordPatSynField a b) c = combineScopes c+            $ combineScopes (mkLScope a) (mkLScope b)+          detSpan = case detScope of+            LocalScope a -> Just a+            _ -> Nothing+          toBind (PrefixCon args) = PrefixCon $ map (C Use) args+          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)+          toBind (RecCon r) = RecCon $ map (PSC detSpan) r+      XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+         ) => ToHie (HsPatSynDir a) where+  toHie dir = case dir of+    ExplicitBidirectional mg -> toHie mg+    _ -> pure []++instance ( a ~ GhcPass p+         , ToHie body+         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a body)+         , Data (Match a body)+         ) => ToHie (LMatch (GhcPass p) body) where+  toHie (L span m ) = concatM $ makeNode m span : case m of+    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->+      [ toHie mctx+      , let rhsScope = mkScope $ grhss_span grhss+          in toHie $ patScopes Nothing rhsScope NoScope pats+      , toHie grhss+      ]+    XMatch _ -> []++instance ( ToHie (Context (Located a))+         ) => ToHie (HsMatchContext a) where+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (StmtCtxt a) = toHie a+  toHie _ = pure []++instance ( ToHie (HsMatchContext a)+         ) => ToHie (HsStmtContext a) where+  toHie (PatGuard a) = toHie a+  toHie (ParStmtCtxt a) = toHie a+  toHie (TransStmtCtxt a) = toHie a+  toHie _ = pure []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+         , ToHie (LHsExpr a)+         , ToHie (TScoped (LHsSigWcType a))+         , ProtectSig a+         , ToHie (TScoped (ProtectedSig a))+         , HasType (LPat a)+         , Data (HsSplice a)+         ) => ToHie (PScoped (LPat (GhcPass p))) where+  toHie (PS rsp scope pscope lpat@(L ospan opat)) =+    concatM $ getTypeNode lpat : case opat of+      WildPat _ ->+        []+      VarPat _ lname ->+        [ toHie $ C (PatternBind scope pscope rsp) lname+        ]+      LazyPat _ p ->+        [ toHie $ PS rsp scope pscope p+        ]+      AsPat _ lname pat ->+        [ toHie $ C (PatternBind scope+                                 (combineScopes (mkLScope pat) pscope)+                                 rsp)+                    lname+        , toHie $ PS rsp scope pscope pat+        ]+      ParPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      BangPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ListPat _ pats ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      TuplePat _ pats _ ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      SumPat _ pat _ _ ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ConPatIn c dets ->+        [ toHie $ C Use c+        , toHie $ contextify dets+        ]+      ConPatOut {pat_con = con, pat_args = dets}->+        [ toHie $ C Use $ fmap conLikeName con+        , toHie $ contextify dets+        ]+      ViewPat _ expr pat ->+        [ toHie expr+        , toHie $ PS rsp scope pscope pat+        ]+      SplicePat _ sp ->+        [ toHie $ L ospan sp+        ]+      LitPat _ _ ->+        []+      NPat _ _ _ _ ->+        []+      NPlusKPat _ n _ _ _ _ ->+        [ toHie $ C (PatternBind scope pscope rsp) n+        ]+      SigPat sig pat ->+        [ toHie $ PS rsp scope pscope pat+        , let cscope = mkLScope pat in+            toHie $ TS (ResolvedScopes [cscope, scope, pscope])+                       (protectSig @a cscope sig)+              -- See Note [Scoping Rules for SigPat]+        ]+      CoPat _ _ _ _ ->+        []+      XPat _ -> []+    where+      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args+      contextify (InfixCon a b) = InfixCon a' b'+        where [a', b'] = patScopes rsp scope pscope [a,b]+      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r+      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a+        where+          go (RS fscope (L spn (HsRecField lbl pat pun))) =+            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun+          scoped_fds = listScopes pscope fds++instance ( ToHie body+         , ToHie (LGRHS a body)+         , ToHie (RScoped (LHsLocalBinds a))+         ) => ToHie (GRHSs a body) where+  toHie grhs = concatM $ case grhs of+    GRHSs _ grhss binds ->+     [ toHie grhss+     , toHie $ RS (mkScope $ grhss_span grhs) binds+     ]+    XGRHSs _ -> []++instance ( ToHie (Located body)+         , ToHie (RScoped (GuardLStmt a))+         , Data (GRHS a (Located body))+         ) => ToHie (LGRHS a (Located body)) where+  toHie (L span g) = concatM $ makeNode g span : case g of+    GRHS _ guards body ->+      [ toHie $ listScopes (mkLScope body) guards+      , toHie body+      ]+    XGRHS _ -> []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , HasType (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (LGRHS a (LHsExpr a))+         , ToHie (RContext (HsRecordBinds a))+         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+         , ToHie (ArithSeqInfo a)+         , ToHie (LHsCmdTop a)+         , ToHie (RScoped (GuardLStmt a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (TScoped (LHsWcType (NoGhcTc a)))+         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+         , Data (HsExpr a)+         , Data (HsSplice a)+         , Data (HsTupArg a)+         , Data (AmbiguousFieldOcc a)+         ) => ToHie (LHsExpr (GhcPass p)) where+  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsUnboundVar _ _ ->+        []+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      HsRecFld _ fld ->+        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+        ]+      HsOverLabel _ _ _ -> []+      HsIPVar _ _ -> []+      HsOverLit _ _ -> []+      HsLit _ _ -> []+      HsLam _ mg ->+        [ toHie mg+        ]+      HsLamCase _ mg ->+        [ toHie mg+        ]+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsAppType _sig expr ->+        [ toHie expr+        -- , toHie $ TS (ResolvedScopes []) sig+        ]+      OpApp _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      NegApp _ a _ ->+        [ toHie a+        ]+      HsPar _ a ->+        [ toHie a+        ]+      SectionL _ a b ->+        [ toHie a+        , toHie b+        ]+      SectionR _ a b ->+        [ toHie a+        , toHie b+        ]+      ExplicitTuple _ args _ ->+        [ toHie args+        ]+      ExplicitSum _ _ _ expr ->+        [ toHie expr+        ]+      HsCase _ expr matches ->+        [ toHie expr+        , toHie matches+        ]+      HsIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsMultiIf _ grhss ->+        [ toHie grhss+        ]+      HsLet _ binds expr ->+        [ toHie $ RS (mkLScope expr) binds+        , toHie expr+        ]+      HsDo _ _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      ExplicitList _ _ exprs ->+        [ toHie exprs+        ]+      RecordCon {rcon_con_name = name, rcon_flds = binds}->+        [ toHie $ C Use name+        , toHie $ RC RecFieldAssign $ binds+        ]+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->+        [ toHie expr+        , toHie $ map (RC RecFieldAssign) upds+        ]+      ExprWithTySig _ expr ->+        [ toHie expr+        -- , toHie $ TS (ResolvedScopes [mkLScope expr]) sig+        ]+      ArithSeq _ _ info ->+        [ toHie info+        ]+      HsSCC _ _ _ expr ->+        [ toHie expr+        ]+      HsCoreAnn _ _ _ expr ->+        [ toHie expr+        ]+      HsProc _ pat cmdtop ->+        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+        , toHie cmdtop+        ]+      HsStatic _ expr ->+        [ toHie expr+        ]+      HsArrApp _ a b _ _ ->+        [ toHie a+        , toHie b+        ]+      HsArrForm _ expr _ cmds ->+        [ toHie expr+        , toHie cmds+        ]+      HsTick _ _ expr ->+        [ toHie expr+        ]+      HsBinTick _ _ _ expr ->+        [ toHie expr+        ]+      HsTickPragma _ _ _ _ expr ->+        [ toHie expr+        ]+      HsWrap _ _ a ->+        [ toHie $ L mspan a+        ]+      HsBracket _ b ->+        [ toHie b+        ]+      HsRnBracketOut _ b p ->+        [ toHie b+        , toHie p+        ]+      HsTcBracketOut _ b p ->+        [ toHie b+        , toHie p+        ]+      HsSpliceE _ x ->+        [ toHie $ L mspan x+        ]+      EWildPat _ -> []+      EAsPat _ a b ->+        [ toHie $ C Use a+        , toHie b+        ]+      EViewPat _ a b ->+        [ toHie a+        , toHie b+        ]+      ELazyPat _ a ->+        [ toHie a+        ]+      XExpr _ -> []++instance ( a ~ GhcPass p+         , ToHie (LHsExpr a)+         , Data (HsTupArg a)+         ) => ToHie (LHsTupArg (GhcPass p)) where+  toHie (L span arg) = concatM $ makeNode arg span : case arg of+    Present _ expr ->+      [ toHie expr+      ]+    Missing _ -> []+    XTupArg _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (RScoped (ApplicativeArg a))+         , ToHie (Located body)+         , Data (StmtLR a a (Located body))+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of+      LastStmt _ body _ _ ->+        [ toHie body+        ]+      BindStmt _ pat body _ _ ->+        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat+        , toHie body+        ]+      ApplicativeStmt _ stmts _ ->+        [ concatMapM (toHie . RS scope . snd) stmts+        ]+      BodyStmt _ body _ _ ->+        [ toHie body+        ]+      LetStmt _ binds ->+        [ toHie $ RS scope binds+        ]+      ParStmt _ parstmts _ _ ->+        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->+                          toHie $ listScopes NoScope stmts)+                     parstmts+        ]+      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->+        [ toHie $ listScopes scope stmts+        , toHie using+        , toHie by+        ]+      RecStmt {recS_stmts = stmts} ->+        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts+        ]+      XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (LHsLocalBinds a)) where+  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+      EmptyLocalBinds _ -> []+      HsIPBinds _ _ -> []+      HsValBinds _ valBinds ->+        [ toHie $ RS (combineScopes scope $ mkScope sp)+                      valBinds+        ]+      XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (XXValBindsLR a a))+         ) => ToHie (RScoped (HsValBindsLR a a)) where+  toHie (RS sc v) = concatM $ case v of+    ValBinds _ binds sigs ->+      [ toHie $ fmap (BC RegularBind sc) binds+      , toHie $ fmap (SC (SI BindSig Nothing)) sigs+      ]+    XValBindsLR x -> [ toHie $ RS sc x ]++instance ToHie (RScoped (NHsValBindsLR GhcTc)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]++instance ( ToHie (RContext (LHsRecField a arg))+         ) => ToHie (RContext (HsRecFields a arg)) where+  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+         , ToHie arg+         , HasLoc arg+         , Data label+         , Data arg+         ) => ToHie (RContext (LHsRecField' label arg)) where+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of+    HsRecField label expr _ ->+      [ toHie $ RFC c (getRealSpan $ loc expr) label+      , toHie expr+      ]++removeDefSrcSpan :: Name -> Name+removeDefSrcSpan n = setNameLoc n noSrcSpan++instance ToHie (RFContext (LFieldOcc GhcRn)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc name _ ->+      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)+      ]+    XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous name _ ->+      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name+      ]+    Ambiguous _name _ ->+      [ ]+    XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    Ambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (StmtLR a a (Located (HsExpr a)))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where+  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM+    [ toHie $ PS Nothing sc NoScope pat+    , toHie expr+    ]+  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM+    [ toHie $ listScopes NoScope stmts+    , toHie $ PS Nothing sc NoScope pat+    ]+  toHie (RS _ (XApplicativeArg _)) = pure []++instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where+  toHie (PrefixCon args) = toHie args+  toHie (RecCon rec) = toHie rec+  toHie (InfixCon a b) = concatM [ toHie a, toHie b]++instance ( ToHie (LHsCmd a)+         , Data  (HsCmdTop a)+         ) => ToHie (LHsCmdTop a) where+  toHie (L span top) = concatM $ makeNode top span : case top of+    HsCmdTop _ cmd ->+      [ toHie cmd+      ]+    XCmdTop _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (MatchGroup a (LHsCmd a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsCmd a)+         , Data (HsCmdTop a)+         , Data (StmtLR a a (Located (HsCmd a)))+         , Data (HsLocalBinds a)+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (LHsCmd (GhcPass p)) where+  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of+      HsCmdArrApp _ a b _ _ ->+        [ toHie a+        , toHie b+        ]+      HsCmdArrForm _ a _ _ cmdtops ->+        [ toHie a+        , toHie cmdtops+        ]+      HsCmdApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsCmdLam _ mg ->+        [ toHie mg+        ]+      HsCmdPar _ a ->+        [ toHie a+        ]+      HsCmdCase _ expr alts ->+        [ toHie expr+        , toHie alts+        ]+      HsCmdIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsCmdLet _ binds cmd' ->+        [ toHie $ RS (mkLScope cmd') binds+        , toHie cmd'+        ]+      HsCmdDo _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      HsCmdWrap _ _ _ -> []+      XCmd _ -> []++instance ToHie (TyClGroup GhcRn) where+  toHie (TyClGroup _ classes roles instances) = concatM+    [ toHie classes+    , toHie roles+    , toHie instances+    ]+  toHie (XTyClGroup _) = pure []++instance ToHie (LTyClDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamDecl {tcdFam = fdecl} ->+        [ toHie (L span fdecl)+        ]+      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->+        [ toHie $ C (Decl SynDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars+        , toHie typ+        ]+      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->+        [ toHie $ C (Decl DataDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars+        , toHie defn+        ]+        where+          quant_scope = mkLScope $ dd_ctxt defn+          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc+          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn+          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn+          deriv_sc = mkLScope $ dd_derivs defn+      ClassDecl { tcdCtxt = context+                , tcdLName = name+                , tcdTyVars = vars+                , tcdFDs = deps+                , tcdSigs = sigs+                , tcdMeths = meths+                , tcdATs = typs+                , tcdATDefs = deftyps+                } ->+        [ toHie $ C (Decl ClassDec $ getRealSpan span) name+        , toHie context+        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars+        , toHie deps+        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs+        , toHie $ fmap (BC InstanceBind ModuleScope) meths+        , toHie typs+        , concatMapM (pure . locOnly . getLoc) deftyps+        , toHie $ map (go . unLoc) deftyps+        ]+        where+          context_scope = mkLScope context+          rhs_scope = foldl1' combineScopes $ map mkScope+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]++          go :: TyFamDefltEqn GhcRn+             -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)+          go (FamEqn a var pat b rhs) =+             FamEqn a var (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs+          go (XFamEqn NoExt) = XFamEqn NoExt+      XTyClDecl _ -> []++instance ToHie (LFamilyDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamilyDecl _ info name vars _ sig inj ->+        [ toHie $ C (Decl FamDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [rhsSpan]) vars+        , toHie info+        , toHie $ RS injSpan sig+        , toHie inj+        ]+        where+          rhsSpan = sigSpan `combineScopes` injSpan+          sigSpan = mkScope $ getLoc sig+          injSpan = maybe NoScope (mkScope . getLoc) inj+      XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+  toHie (ClosedTypeFamily (Just eqns)) = concatM $+    [ concatMapM (pure . locOnly . getLoc) eqns+    , toHie $ map go eqns+    ]+    where+      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib+  toHie _ = pure []++instance ToHie (RScoped (LFamilyResultSig GhcRn)) where+  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+      NoSig _ ->+        []+      KindSig _ k ->+        [ toHie k+        ]+      TyVarSig _ bndr ->+        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr+        ]+      XFamilyResultSig _ -> []++instance ToHie (Located (FunDep (Located Name))) where+  toHie (L span fd@(lhs, rhs)) = concatM $+    [ makeNode fd span+    , toHie $ map (C Use) lhs+    , toHie $ map (C Use) rhs+    ]++instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)+    => ToHie (TScoped (FamEqn GhcRn pats rhs)) where+  toHie (TS _ f) = toHie f++instance ( ToHie pats+         , ToHie rhs+         , HasLoc pats+         , HasLoc rhs+         ) => ToHie (FamEqn GhcRn pats rhs) where+  toHie fe@(FamEqn _ var pats _ rhs) = concatM $+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+    , toHie pats+    , toHie rhs+    ]+  toHie (XFamEqn _) = pure []++instance ToHie (LInjectivityAnn GhcRn) where+  toHie (L span ann) = concatM $ makeNode ann span : case ann of+      InjectivityAnn lhs rhs ->+        [ toHie $ C Use lhs+        , toHie $ map (C Use) rhs+        ]++instance ToHie (HsDataDefn GhcRn) where+  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM+    [ toHie ctx+    , toHie mkind+    , toHie cons+    , toHie derivs+    ]+  toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+  toHie (L span clauses) = concatM+    [ pure $ locOnly span+    , toHie clauses+    ]++instance ToHie (LHsDerivingClause GhcRn) where+  toHie (L span cl) = concatM $ makeNode cl span : case cl of+      HsDerivingClause _ strat (L ispan tys) ->+        [ toHie strat+        , pure $ locOnly ispan+        , toHie $ map (TS (ResolvedScopes [])) tys+        ]+      XHsDerivingClause _ -> []++instance ToHie (Located (DerivStrategy GhcRn)) where+  toHie (L span strat) = concatM $ makeNode strat span : case strat of+      StockStrategy -> []+      AnyclassStrategy -> []+      NewtypeStrategy -> []+      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]++instance ToHie (Located OverlapMode) where+  toHie (L span _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ConDeclGADT { con_names = names, con_qvars = qvars+                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+        , toHie ctx+        , toHie args+        , toHie typ+        ]+        where+          rhsScope = combineScopes argsScope tyScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope args+          tyScope = mkLScope typ+      ConDeclH98 { con_name = name, con_ex_tvs = qvars+                 , con_mb_cxt = ctx, con_args = dets } ->+        [ toHie $ C (Decl ConDec $ getRealSpan span) name+        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars+        , toHie ctx+        , toHie dets+        ]+        where+          rhsScope = combineScopes ctxScope argsScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope dets+      XConDecl _ -> []+    where condecl_scope args = case args of+            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+            RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+  toHie (L span decls) = concatM $+    [ pure $ locOnly span+    , toHie decls+    ]++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+  toHie (TS sc (HsIB ibrn a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) $ (hsib_vars ibrn)+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+  toHie (TS sc (HsWC names a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (SigContext (LSig GhcRn)) where+  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of+      TypeSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      PatSynSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      ClassOpSig _ _ names typ ->+        [ case styp of+            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names+            _  -> toHie $ map (C $ TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ+        ]+      IdSig _ _ -> []+      FixSig _ fsig ->+        [ toHie $ L sp fsig+        ]+      InlineSig _ name _ ->+        [ toHie $ (C Use) name+        ]+      SpecSig _ name typs _ ->+        [ toHie $ (C Use) name+        , toHie $ map (TS (ResolvedScopes [])) typs+        ]+      SpecInstSig _ _ typ ->+        [ toHie $ TS (ResolvedScopes []) typ+        ]+      MinimalSig _ _ form ->+        [ toHie form+        ]+      SCCFunSig _ _ name mtxt ->+        [ toHie $ (C Use) name+        , pure $ maybe [] (locOnly . getLoc) mtxt+        ]+      CompleteMatchSig _ _ (L ispan names) typ ->+        [ pure $ locOnly ispan+        , toHie $ map (C Use) names+        , toHie $ fmap (C Use) typ+        ]+      XSig _ -> []++instance ToHie (LHsType GhcRn) where+  toHie x = toHie $ TS (ResolvedScopes []) x++instance ToHie (TScoped (LHsType GhcRn)) where+  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of+      HsForAllTy _ bndrs body ->+        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs+        , toHie body+        ]+      HsQualTy _ ctx body ->+        [ toHie ctx+        , toHie body+        ]+      HsTyVar _ _ var ->+        [ toHie $ C Use var+        ]+      HsAppTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsFunTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsListTy _ a ->+        [ toHie a+        ]+      HsTupleTy _ _ tys ->+        [ toHie tys+        ]+      HsSumTy _ tys ->+        [ toHie tys+        ]+      HsOpTy _ a op b ->+        [ toHie a+        , toHie $ C Use op+        , toHie b+        ]+      HsParTy _ a ->+        [ toHie a+        ]+      HsIParamTy _ ip ty ->+        [ toHie ip+        , toHie ty+        ]+      HsKindSig _ a b ->+        [ toHie a+        , toHie b+        ]+      HsSpliceTy _ a ->+        [ toHie $ L span a+        ]+      HsDocTy _ a _ ->+        [ toHie a+        ]+      HsBangTy _ _ ty ->+        [ toHie ty+        ]+      HsRecTy _ fields ->+        [ toHie fields+        ]+      HsExplicitListTy _ _ tys ->+        [ toHie tys+        ]+      HsExplicitTupleTy _ tys ->+        [ toHie tys+        ]+      HsTyLit _ _ -> []+      HsWildCardTy _ -> []+      HsStarTy _ _ -> []+      XHsType _ -> []++{-+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where+  toHie (HsValArg tm) = toHie tm+  toHie (HsTypeArg _ ty) = toHie ty+  toHie (HsArgPar sp) = pure $ locOnly sp+-}++instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      UserTyVar _ var ->+        [ toHie $ C (TyVarBind sc tsc) var+        ]+      KindedTyVar _ var kind ->+        [ toHie $ C (TyVarBind sc tsc) var+        , toHie kind+        ]+      XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+  toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $+    [ pure $ bindingsOnly bindings+    , toHie $ tvScopes sc NoScope vars+    ]+    where+      varLoc = loc vars+      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+  toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+  toHie (L span tys) = concatM $+      [ pure $ locOnly span+      , toHie tys+      ]++instance ToHie (LConDeclField GhcRn) where+  toHie (L span field) = concatM $ makeNode field span : case field of+      ConDeclField _ fields typ _ ->+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields+        , toHie typ+        ]+      XConDeclField _ -> []++instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where+  toHie (From expr) = toHie expr+  toHie (FromThen a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromTo a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromThenTo a b c) = concatM $+    [ toHie a+    , toHie b+    , toHie c+    ]++instance ToHie (LSpliceDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      SpliceDecl _ splice _ ->+        [ toHie splice+        ]+      XSpliceDecl _ -> []++instance ToHie (HsBracket a) where+  toHie _ = pure []++instance ToHie PendingRnSplice where+  toHie _ = pure []++instance ToHie PendingTcSplice where+  toHie _ = pure []++instance ToHie (LBooleanFormula (Located Name)) where+  toHie (L span form) = concatM $ makeNode form span : case form of+      Var a ->+        [ toHie $ C Use a+        ]+      And forms ->+        [ toHie forms+        ]+      Or forms ->+        [ toHie forms+        ]+      Parens f ->+        [ toHie f+        ]++instance ToHie (Located HsIPName) where+  toHie (L span e) = makeNode e span++instance ( ToHie (LHsExpr a)+         , Data (HsSplice a)+         ) => ToHie (Located (HsSplice a)) where+  toHie (L span sp) = concatM $ makeNode sp span : case sp of+      HsTypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsUntypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsQuasiQuote _ _ _ ispan _ ->+        [ pure $ locOnly ispan+        ]+      HsSpliced _ _ _ ->+        []+      XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+  toHie (L span annot) = concatM $ makeNode annot span : case annot of+      RoleAnnotDecl _ var roles ->+        [ toHie $ C Use var+        , concatMapM (pure . locOnly . getLoc) roles+        ]+      XRoleAnnotDecl _ -> []++instance ToHie (LInstDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ClsInstD _ d ->+        [ toHie $ L span d+        ]+      DataFamInstD _ d ->+        [ toHie $ L span d+        ]+      TyFamInstD _ d ->+        [ toHie $ L span d+        ]+      XInstDecl _ -> []++instance ToHie (LClsInstDecl GhcRn) where+  toHie (L span decl) = concatM+    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl+    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl+    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl+    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+    , toHie $ cid_tyfam_insts decl+    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl+    , toHie $ cid_datafam_insts decl+    , toHie $ cid_overlap_mode decl+    ]++instance ToHie (LDataFamInstDecl GhcRn) where+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (LTyFamInstDecl GhcRn) where+  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (Context a)+         => ToHie (PatSynFieldContext (RecordPatSynField a)) where+  toHie (PSC sp (RecordPatSynField a b)) = concatM $+    [ toHie $ C (RecField RecFieldDecl sp) a+    , toHie $ C Use b+    ]++instance ToHie (LDerivDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DerivDecl _ typ strat overlap ->+        [ toHie $ TS (ResolvedScopes []) typ+        , toHie strat+        , toHie overlap+        ]+      XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+  toHie (L span sig) = concatM $ makeNode sig span : case sig of+      FixitySig _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DefaultDecl _ typs ->+        [ toHie typs+        ]+      XDefaultDecl _ -> []++instance ToHie (LForeignDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fi+        ]+      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->+        [ toHie $ C Use name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fe+        ]+      XForeignDecl _ -> []++instance ToHie ForeignImport where+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    , locOnly c+    ]++instance ToHie ForeignExport where+  toHie (CExport (L a _) (L b _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    ]++instance ToHie (LWarnDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warnings _ _ warnings ->+        [ toHie warnings+        ]+      XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warning _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsAnnotation _ _ prov expr ->+        [ toHie prov+        , toHie expr+        ]+      XAnnDecl _ -> []++instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where+  toHie (ValueAnnProvenance a) = toHie $ C Use a+  toHie (TypeAnnProvenance a) = toHie $ C Use a+  toHie ModuleAnnProvenance = pure []++instance ToHie (LRuleDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsRules _ _ rules ->+        [ toHie rules+        ]+      XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+  toHie (L _ (XRuleDecl _)) = pure []+  toHie (L span r@(HsRule _ rname _ bndrs exprA exprB)) = concatM+        [ makeNode r span+        , pure $ locOnly $ getLoc rname+        , toHie $ map (RS $ mkScope span) bndrs+        , toHie exprA+        , toHie exprB+        ]++instance ToHie (RScoped (LRuleBndr GhcRn)) where+  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      RuleBndr _ var ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        ]+      RuleBndrSig _ var typ ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        , toHie $ TS (ResolvedScopes [sc]) typ+        ]+      XRuleBndr _ -> []++instance ToHie (LImportDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->+        [ toHie $ IEC Import name+        , toHie $ fmap (IEC ImportAs) as+        , maybe (pure []) goIE hidden+        ]+      XImportDecl _ -> []+    where+      goIE (hiding, (L sp liens)) = concatM $+        [ pure $ locOnly sp+        , toHie $ map (IEC c) liens+        ]+        where+         c = if hiding then ImportHiding else Import++instance ToHie (IEContext (LIE GhcRn)) where+  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of+      IEVar _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAbs _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAll _ n ->+        [ toHie $ IEC c n+        ]+      IEThingWith _ n _ ns flds ->+        [ toHie $ IEC c n+        , toHie $ map (IEC c) ns+        , toHie $ map (IEC c) flds+        ]+      IEModuleContents _ n ->+        [ toHie $ IEC c n+        ]+      IEGroup _ _ _ -> []+      IEDoc _ _ -> []+      IEDocNamed _ _ -> []+      XIE _ -> []++instance ToHie (IEContext (LIEWrappedName Name)) where+  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of+      IEName n ->+        [ toHie $ C (IEThing c) n+        ]+      IEPattern p ->+        [ toHie $ C (IEThing c) p+        ]+      IEType n ->+        [ toHie $ C (IEThing c) n+        ]++instance ToHie (IEContext (Located (FieldLbl Name))) where+  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of+      FieldLabel _ _ n ->+        [ toHie $ C (IEThing c) $ L span n+        ]+

@@ -0,0 +1,388 @@+{-+Binary serialization for .hie files.+-}+{-# LANGUAGE ScopedTypeVariables #-}+module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where++import Config                     ( cProjectVersion )+import Binary+import BinIface                   ( getDictFastString )+import FastMutInt+import FastString                 ( FastString )+import Module                     ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply                 ( takeUniqFromSupply )+import Util                       ( maybeRead )+import Unique+import UniqFM+import IfaceEnv++import qualified Data.Array as A+import Data.IORef+import Data.ByteString            ( ByteString )+import qualified Data.ByteString  as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List                  ( mapAccumR )+import Data.Word                  ( Word8, Word32 )+import Control.Monad              ( replicateM, when )+import System.Directory           ( createDirectoryIfMissing )+import System.FilePath            ( takeDirectory )++import Development.IDE.GHC.HieTypes++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+  = ExternalName !Module !OccName !SrcSpan+  | LocalName !OccName !SrcSpan+  | KnownKeyName !Unique+  deriving (Eq)++instance Ord HieName where+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+    -- Not actually non determinstic as it is a KnownKey+  compare ExternalName{} _ = LT+  compare LocalName{} ExternalName{} = GT+  compare LocalName{} _ = LT+  compare KnownKeyName{} _ = GT++instance Outputable HieName where+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u+++data HieSymbolTable = HieSymbolTable+  { hie_symtab_next :: !FastMutInt+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))+  }++data HieDictionary = HieDictionary+  { hie_dict_next :: !FastMutInt -- The next index to use+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+  }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+  mapM_ (putByte bh) $ BS.unpack xs+  putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+  bh0 <- openBinMem initBinMemSize++  -- Write the header: hieHeader followed by the+  -- hieVersion and the GHC version used to generate this file+  mapM_ (putByte bh0) hieMagic+  putBinLine bh0 $ BSC.pack $ show hieVersion+  putBinLine bh0 $ ghcVersion++  -- remember where the dictionary pointer will go+  dict_p_p <- tellBin bh0+  put_ bh0 dict_p_p++  -- remember where the symbol table pointer will go+  symtab_p_p <- tellBin bh0+  put_ bh0 symtab_p_p++  -- Make some intial state+  symtab_next <- newFastMutInt+  writeFastMutInt symtab_next 0+  symtab_map <- newIORef emptyUFM+  let hie_symtab = HieSymbolTable {+                      hie_symtab_next = symtab_next,+                      hie_symtab_map  = symtab_map }+  dict_next_ref <- newFastMutInt+  writeFastMutInt dict_next_ref 0+  dict_map_ref <- newIORef emptyUFM+  let hie_dict = HieDictionary {+                      hie_dict_next = dict_next_ref,+                      hie_dict_map  = dict_map_ref }++  -- put the main thing+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+                                           (putName hie_symtab)+                                           (putFastString hie_dict)+  put_ bh hiefile++  -- write the symtab pointer at the front of the file+  symtab_p <- tellBin bh+  putAt bh symtab_p_p symtab_p+  seekBin bh symtab_p++  -- write the symbol table itself+  symtab_next' <- readFastMutInt symtab_next+  symtab_map'  <- readIORef symtab_map+  putSymbolTable bh symtab_next' symtab_map'++  -- write the dictionary pointer at the front of the file+  dict_p <- tellBin bh+  putAt bh dict_p_p dict_p+  seekBin bh dict_p++  -- write the dictionary itself+  dict_next <- readFastMutInt dict_next_ref+  dict_map  <- readIORef dict_map_ref+  putDictionary bh dict_next dict_map++  -- and send the result to the file+  createDirectoryIfMissing True (takeDirectory hie_file_path)+  writeBinMem bh hie_file_path+  return ()++data HieFileResult+  = HieFileResult+  { hie_file_result_version :: Integer+  , hie_file_result_ghc_version :: ByteString+  , hie_file_result :: HieFile+  }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion ncu file = do+  bh0 <- readBinMem file++  (hieVersion, ghcVersion) <- readHieFileHeader file bh0++  if readVersion (hieVersion, ghcVersion)+  then do+    hieFile <- readHieFileContents bh0 ncu+    return $ Right (HieFileResult hieVersion ghcVersion hieFile)+  else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult+readHieFile ncu file = do++  bh0 <- readBinMem file++  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++  -- Check if the versions match+  when (readHieVersion /= hieVersion) $+    panic $ unwords ["readHieFile: hie file versions don't match for file:"+                    , file+                    , "Expected"+                    , show hieVersion+                    , "but got", show readHieVersion+                    ]+  hieFile <- readHieFileContents bh0 ncu+  return $ HieFileResult hieVersion ghcVersion hieFile++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+  where+    loop acc = do+      char <- get bh :: IO Word8+      if char == 10 -- ASCII newline '\n'+      then return acc+      else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+  -- Read the header+  magic <- replicateM hieMagicLen (get bh0)+  version <- BSC.unpack <$> readBinLine bh0+  case maybeRead version of+    Nothing ->+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+                      , show version+                      ]+    Just readHieVersion -> do+      ghcVersion <- readBinLine bh0++      -- Check if the header is valid+      when (magic /= hieMagic) $+        panic $ unwords ["readHieFileHeader: headers don't match for file:"+                        , file+                        , "Expected"+                        , show hieMagic+                        , "but got", show magic+                        ]+      return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile+readHieFileContents bh0 ncu = do++  dict  <- get_dictionary bh0++  -- read the symbol table so we are capable of reading the actual data+  bh1 <- do+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+                                               (getDictFastString dict)+      symtab <- get_symbol_table bh1+      let bh1' = setUserData bh1+               $ newReadState (getSymTabName symtab)+                              (getDictFastString dict)+      return bh1'++  -- load the actual data+  hiefile <- get bh1+  return hiefile+  where+    get_dictionary bin_handle = do+      dict_p <- get bin_handle+      data_p <- tellBin bin_handle+      seekBin bin_handle dict_p+      dict <- getDictionary bin_handle+      seekBin bin_handle data_p+      return dict++    get_symbol_table bh1 = do+      symtab_p <- get bh1+      data_p'  <- tellBin bh1+      seekBin bh1 symtab_p+      symtab <- getSymbolTable bh1 ncu+      seekBin bh1 data_p'+      return symtab++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+                              hie_dict_map  = out_r}  bh f+  = do+    out <- readIORef out_r+    let unique = getUnique f+    case lookupUFM out unique of+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           put_ bh (fromIntegral j :: Word32)+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+  put_ bh next_off+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+  mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+  sz <- get bh+  od_names <- replicateM sz (getHieName bh)+  updateNameCache ncu $ \nc ->+    let arr = A.listArray (0,sz-1) names+        (nc', names) = mapAccumR fromHieName nc od_names+        in (nc',arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+  i :: Word32 <- get bh+  return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+  symmap <- readIORef ref+  case lookupUFM symmap name of+    Just (off, ExternalName mod occ (UnhelpfulSpan _))+      | isGoodSrcSpan (nameSrcSpan name) -> do+      let hieName = ExternalName mod occ (nameSrcSpan name)+      writeIORef ref $! addToUFM symmap name (off, hieName)+      put_ bh (fromIntegral off :: Word32)+    Just (off, LocalName _occ span)+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do+      writeIORef ref $! addToUFM symmap name (off, toHieName name)+      put_ bh (fromIntegral off :: Word32)+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)+    Nothing -> do+        off <- readFastMutInt next+        writeFastMutInt next (off+1)+        writeIORef ref $! addToUFM symmap name (off, toHieName name)+        put_ bh (fromIntegral off :: Word32)++  where+    notLocal :: HieName -> Bool+    notLocal LocalName{} = False+    notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+  | isKnownKeyName name = KnownKeyName (nameUnique name)+  | isExternalName name = ExternalName (nameModule name)+                                       (nameOccName name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+    let cache = nsNames nc+    in case lookupOrigNameCache cache mod occ of+         Just name+           | nameSrcSpan name == span -> (nc, name)+           | otherwise ->+             let name' = setNameLoc name span+                 new_cache = extendNameCache cache mod occ name'+             in ( nc{ nsNames = new_cache }, name' )+         Nothing ->+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+               name       = mkExternalName uniq mod occ span+               new_cache  = extendNameCache cache mod occ name+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+        name       = mkInternalName uniq occ span+    in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+    Nothing -> pprPanic "fromHieName:unknown known-key unique"+                        (ppr (unpkUnique u))+    Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+  putByte bh 0+  put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+  putByte bh 1+  put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+  putByte bh 2+  put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+  t <- getByte bh+  case t of+    0 -> do+      (modu, occ, span) <- get bh+      return $ ExternalName modu occ span+    1 -> do+      (occ, span) <- get bh+      return $ LocalName occ span+    2 -> do+      (c,i) <- get bh+      return $ KnownKeyName $ mkUnique c i+    _ -> panic "HieBin.getHieName: invalid tag"