ghcide 0.1.0 → 0.2.0

raw patch · 60 files changed

+9441/−3043 lines, 60 filesdep +Win32dep +arraydep +base16-bytestringdep ~haskell-lspdep ~haskell-lsp-typesdep ~hie-biosPVP ok

version bump matches the API change (PVP)

Dependencies added: Win32, array, base16-bytestring, cryptohash-sha1, ghc-check, tasty-rerun

Dependency ranges changed: haskell-lsp, haskell-lsp-types, hie-bios, lsp-test, shake, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• README.md +62/−3
• exe/Arguments.hs +4/−0
• exe/Main.hs +537/−81
• exe/Utils.hs +9/−0
• ghcide.cabal +64/−14
• src-ghc810/Development/IDE/GHC/HieAst.hs +1928/−0
• src-ghc88/Development/IDE/GHC/HieAst.hs +1789/−0
• src/Development/IDE/Compat.hs +19/−0
• src/Development/IDE/Core/Compile.hs +292/−93
• src/Development/IDE/Core/Debouncer.hs +15/−9
• src/Development/IDE/Core/FileExists.hs +40/−46
• src/Development/IDE/Core/FileStore.hs +8/−5
• src/Development/IDE/Core/IdeConfiguration.hs +71/−0
• src/Development/IDE/Core/OfInterest.hs +10/−10
• src/Development/IDE/Core/PositionMapping.hs +48/−10
• src/Development/IDE/Core/Preprocessor.hs +15/−13
• src/Development/IDE/Core/RuleTypes.hs +50/−11
• src/Development/IDE/Core/Rules.hs +418/−116
• src/Development/IDE/Core/Service.hs +4/−1
• src/Development/IDE/Core/Shake.hs +94/−81
• src/Development/IDE/GHC/CPP.hs +26/−1
• src/Development/IDE/GHC/Compat.hs +188/−18
• src/Development/IDE/GHC/Error.hs +27/−4
• src/Development/IDE/GHC/Orphans.hs +10/−3
• src/Development/IDE/GHC/Util.hs +102/−53
• src/Development/IDE/GHC/WithDynFlags.hs +30/−0
• src/Development/IDE/Import/DependencyInformation.hs +120/−33
• src/Development/IDE/Import/FindImports.hs +63/−17
• src/Development/IDE/LSP/HoverDefinition.hs +5/−2
• src/Development/IDE/LSP/LanguageServer.hs +52/−28
• src/Development/IDE/LSP/Notifications.hs +13/−4
• src/Development/IDE/LSP/Outline.hs +47/−8
• src/Development/IDE/LSP/Server.hs +11/−9
• src/Development/IDE/Plugin.hs +34/−8
• src/Development/IDE/Plugin/CodeAction.hs +156/−91
• src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +112/−0
• src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +61/−0
• src/Development/IDE/Plugin/CodeAction/Rules.hs +61/−0
• src/Development/IDE/Plugin/Completions.hs +32/−17
• src/Development/IDE/Plugin/Completions/Logic.hs +43/−47
• src/Development/IDE/Spans/AtPoint.hs +17/−18
• src/Development/IDE/Spans/Calculate.hs +34/−25
• src/Development/IDE/Spans/Common.hs +4/−4
• src/Development/IDE/Spans/Documentation.hs +21/−19
• src/Development/IDE/Types/Diagnostics.hs +19/−5
• src/Development/IDE/Types/Location.hs +24/−115
• src/Development/IDE/Types/Options.hs +35/−8
• test/data/GotoHover.hs +0/−50
• test/data/hover/Bar.hs +3/−0
• test/data/hover/Foo.hs +5/−0
• test/data/hover/GotoHover.hs +57/−0
• test/data/multi/a/A.hs +3/−0
• test/data/multi/a/a.cabal +9/−0
• test/data/multi/b/B.hs +3/−0
• test/data/multi/b/b.cabal +9/−0
• test/data/multi/cabal.project +1/−0
• test/data/multi/hie.yaml +6/−0
• test/exe/Main.hs +2493/−1961
• test/src/Development/IDE/Test.hs +8/−2

@@ -1,5 +1,25 @@ ### unreleased +### 0.2.0 (2020-06-02)++* Multi-component support (thanks @mpickering)+* Support for GHC 8.10 (thanks @sheaf and @chshersh)+* Fix some TH issues (thanks @mpickering)+* Automatically pick up changes to cradle dependencies (e.g. cabal+  files) (thanks @jinwoo)+* Track dependencies when using `qAddDependentFile` (thanks @mpickering)+* Add record fields to document symbols outline (thanks @bubba)+* Fix some space leaks (thanks @mpickering)+* Strip redundant path information from diagnostics (thanks @tek)+* Fix import suggestions for operators (thanks @eddiemundo)+* Significant reductions in memory usage by using interfaces and `.hie` files (thanks+  @pepeiborra)+* Minor improvements to completions+* More comprehensive suggestions for missing imports (thanks @pepeiborra)+* Group imports in document outline (thanks @fendor)+* Upgrade to haskell-lsp-0.22 (thanks @bubba)+* Upgrade to hie-bios 0.5 (thanks @fendor)+ ### 0.1.0 (2020-02-04)  * Code action for inserting new definitions (see #309).

@@ -25,14 +25,41 @@ | Display type and source module of values | hover | | Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions  | codeAction (quickfix) | ++## Limitations to Multi-Component support++`ghcide` supports loading multiple components into the same session so that+features such as go-to definition work across components. However, there are+some limitations to this.++1. You will get much better results currently manually specifying the hie.yaml file.+Until tools like cabal and stack provide the right interface to support multi-component+projects, it is always advised to specify explicitly how your project partitions.+2. Cross-component features only work if you have loaded at least one file+from each component.+3. There is a known issue where if you have three components, such that A depends on B which depends on C+then if you load A and C into the session but not B then under certain situations you+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for+a simple reproduction of the bug.+ ## Using it  ### Install `ghcide`  #### With Nix -[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)+Note that you need to compile `ghcide` with the same `ghc` as the project you are working on. +1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via+   ```+   nix-env -iA haskellPackages.ghcide+   ```+   or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.+   Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.++2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)+   which provides a `ghcide` via the `haskell.nix` infrastructure.+ #### With Cabal or Stack  First install the `ghcide` binary using `stack` or `cabal`, e.g.@@ -64,6 +91,10 @@  If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with. +### Optimal project setup++`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.+ ### Using with VS Code  You can install the VSCode extension from the [VSCode@@ -203,8 +234,12 @@ ```  Here's a nice article on setting up neovim and coc: [Vim and Haskell in-2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide) +Here is a Docker container that pins down the build and configuration for+Neovim and ghcide on a minimal Debian 10 base system:+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).+ ### SpaceVim  In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`:@@ -248,11 +283,33 @@ This example above describes a setup in which `ghcide` is installed using `stack install ghcide` within a project. +### Using with Kakoune++Install [kak-lsp](https://github.com/ul/kak-lsp).++Change `kak-lsp.toml` to include this:++```toml+[language.haskell]+filetypes = ["haskell"]+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]+command = "ghcide"+args = ["--lsp"]+```+ ## Hacking on ghcide  To build and work on `ghcide` itself, you can use Stack or cabal, e.g., running `stack test` will execute the test suite.+If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`. +If you are chasing down test failures, you can use the tasty-rerun feature by running tests as++    stack --stack-yaml=stack84.yaml test --test-arguments "--rerun"++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.+ ### Building the extension  For development, you can also the VSCode extension from this repository (see@@ -268,8 +325,10 @@  ## History and relationship to other Haskell IDE's +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 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 has 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. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors.+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/).

@@ -12,6 +12,8 @@     ,argFiles :: [FilePath]     ,argsVersion :: Bool     ,argsShakeProfiling :: Maybe FilePath+    ,argsTesting :: Bool+    ,argsThreads :: Int     }  getArguments :: IO Arguments@@ -29,3 +31,5 @@       <*> many (argument str (metavar "FILES/DIRS..."))       <*> switch (long "version" <> help "Show ghcide and GHC versions")       <*> 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)

@@ -3,19 +3,31 @@ {-# 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 Data.Maybe-import Data.List.Extra-import System.FilePath+import Control.Concurrent.Async import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import Data.Default-import System.Time.Extra+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 import Development.IDE.Core.OfInterest import Development.IDE.Core.Service@@ -31,31 +43,39 @@ import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction-import qualified Data.Text as T-import qualified Data.Text.IO as T+import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types (LspId(IdInt))-import Linker-import Data.Version+import Language.Haskell.LSP.Types+import Data.Aeson (ToJSON(toJSON)) import Development.IDE.LSP.LanguageServer-import System.Directory.Extra as IO+import qualified System.Directory.Extra as IO import System.Environment import System.IO 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.Set as Set+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 qualified GHC.Paths+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )+import Data.Either.Extra -import HIE.Bios+import HIE.Bios.Cradle+import HIE.Bios.Types --- Set the GHC libdir to the nix libdir if it's present.-getLibdir :: IO FilePath-getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"+import Utils  ghcideVersion :: IO String ghcideVersion = do@@ -82,74 +102,68 @@     let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $             T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg -    whenJust argsCwd setCurrentDirectory+    whenJust argsCwd IO.setCurrentDirectory -    dir <- getCurrentDirectory+    dir <- IO.getCurrentDirectory+    command <- makeLspCommandId "typesignature.add"      let plugins = Completions.plugin <> CodeAction.plugin+        onInitialConfiguration = const $ Right ()+        onConfigurationChange  = const $ Right ()+        options = def { LSP.executeCommandCommands = Just [command]+                      , LSP.completionTriggerCharacters = Just "."+                      }      if argLSP then do         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 def (pluginHandler plugins) $ \getLspId event vfs caps -> do+        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do             t <- t             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t-            -- very important we only call loadSession once, and it's fast, so just do it before starting-            session <- loadSession dir-            let options = (defaultIdeOptions $ return session)+            let options = (defaultIdeOptions $ loadSessionShake dir)                     { optReportProgress = clientSupportsProgress caps                     , optShakeProfiling = argsShakeProfiling+                    , optTesting        = argsTesting+                    , optThreads        = argsThreads                     }-            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs+            debouncer <- newAsyncDebouncer+            initialise caps (mainRule >> pluginRules plugins >> action kick)+                getLspId event (logger minBound) debouncer options vfs     else do+        -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error+        hSetEncoding stdout utf8+        hSetEncoding stderr utf8+         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."         putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues" -        putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir+        putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir         files <- expandFiles (argFiles ++ ["." | null argFiles])         -- LSP works with absolute file paths, so try and behave similarly-        files <- nubOrd <$> mapM canonicalizePath files+        files <- nubOrd <$> mapM IO.canonicalizePath files         putStrLn $ "Found " ++ show (length files) ++ " files" -        putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"+        putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"         cradles <- mapM findCradle files         let ucradles = nubOrd cradles         let n = length ucradles         putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]-        sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do-            let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x-            putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg-            cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x-            when (isNothing x) $ print cradle-            putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"-            cradleToSession cradle--        putStrLn "\nStep 5/6: Initializing the IDE"+        putStrLn "\nStep 3/4: Initializing the IDE"         vfs <- makeVFSHandle-        let cradlesToSessions = Map.fromList $ zip ucradles sessions-        let filesToCradles = Map.fromList $ zip files cradles-        let grab file = fromMaybe (head sessions) $ do-                cradle <- Map.lookup file filesToCradles-                Map.lookup cradle cradlesToSessions--        let options =-              (defaultIdeOptions $ return $ return . grab)-                    { optShakeProfiling = argsShakeProfiling }-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs+        debouncer <- newAsyncDebouncer+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs -        putStrLn "\nStep 6/6: Type checking the files"-        setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files-        results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files+        putStrLn "\nStep 4/4: Type checking the files"+        setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files+        results <- runActionSync 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)"--        unless (null failed) exitFailure-+        return ()  expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do@@ -158,7 +172,7 @@         let recurse "." = True             recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc             recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories-        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x+        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x         when (null files) $             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x         return files@@ -167,48 +181,414 @@ kick :: Action () kick = do     files <- getFilesOfInterest-    void $ uses TypeCheck $ Set.toList files+    void $ uses TypeCheck $ HashSet.toList files  -- | Print an LSP event. showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return ()-showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e  -cradleToSession :: Cradle a -> IO HscEnvEq-cradleToSession cradle = do-    cradleRes <- getCompilerOptions "" cradle-    opts <- case cradleRes of-        CradleSuccess r -> pure r-        CradleFail err -> throwIO err-        -- TODO Rather than failing here, we should ignore any files that use this cradle.-        -- That will require some more changes.-        CradleNone -> fail "'none' cradle is not yet supported"+-- | 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) $ do-        _targets <- initSession opts-        getSession+    env <- runGhc (Just libdir) getSession     initDynLinker env-    newHscEnvEq 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'] -loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)-loadSession dir = do-    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 makeAbsolute res-        return $ normalise <$> res'-    session <- memoIO $ \file -> do-        c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file-        cradleToSession c-    return $ \file -> liftIO $ session =<< cradleLoc file+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.@@ -225,3 +605,79 @@                 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

@@ -0,0 +1,9 @@+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,12 +2,12 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.1.0+version:            0.2.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset maintainer:         Digital Asset-copyright:          Digital Asset 2018-2019+copyright:          Digital Asset 2018-2020 synopsis:           The core of an IDE description:     A library for building Haskell IDE's on top of the GHC API.@@ -15,7 +15,13 @@ bug-reports:        https://github.com/digital-asset/ghcide/issues tested-with:        GHC==8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md-                    test/data/GotoHover.hs+                    test/data/hover/*.hs+                    test/data/multi/cabal.project+                    test/data/multi/hie.yaml+                    test/data/multi/a/a.cabal+                    test/data/multi/a/*.hs+                    test/data/multi/b/b.cabal+                    test/data/multi/b/*.hs  source-repository head     type:     git@@ -30,6 +36,7 @@     default-language:   Haskell2010     build-depends:         aeson,+        array,         async,         base == 4.*,         binary,@@ -43,8 +50,8 @@         filepath,         haddock-library >= 1.8,         hashable,-        haskell-lsp-types == 0.19.*,-        haskell-lsp == 0.19.*,+        haskell-lsp-types == 0.22.*,+        haskell-lsp == 0.22.*,         mtl,         network-uri,         prettyprinter-ansi-terminal,@@ -60,7 +67,7 @@         text,         time,         transformers,-        unordered-containers,+        unordered-containers >= 0.2.10.0,         utf8-string,         hslogger     if flag(ghc-lib)@@ -73,8 +80,11 @@         ghc-boot-th,         ghc-boot,         ghc >= 8.4-    if !os(windows)+    if os(windows)       build-depends:+        Win32+    else+      build-depends:         unix       c-sources:         cbits/getmodtime.c@@ -99,7 +109,10 @@     include-dirs:         include     exposed-modules:+        Development.IDE.Compat+        Development.IDE.Core.Debouncer         Development.IDE.Core.FileStore+        Development.IDE.Core.IdeConfiguration         Development.IDE.Core.OfInterest         Development.IDE.Core.PositionMapping         Development.IDE.Core.Rules@@ -109,7 +122,9 @@         Development.IDE.GHC.Error         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation+        Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.LanguageServer+        Development.IDE.LSP.Outline         Development.IDE.LSP.Protocol         Development.IDE.LSP.Server         Development.IDE.Spans.Common@@ -121,7 +136,6 @@         Development.IDE.Plugin.Completions         Development.IDE.Plugin.CodeAction     other-modules:-        Development.IDE.Core.Debouncer         Development.IDE.Core.Compile         Development.IDE.Core.Preprocessor         Development.IDE.Core.FileExists@@ -129,22 +143,32 @@         Development.IDE.GHC.CPP         Development.IDE.GHC.Orphans         Development.IDE.GHC.Warnings+        Development.IDE.GHC.WithDynFlags         Development.IDE.Import.FindImports-        Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.Notifications-        Development.IDE.LSP.Outline         Development.IDE.Spans.AtPoint         Development.IDE.Spans.Calculate         Development.IDE.Spans.Documentation         Development.IDE.Spans.Type+        Development.IDE.Plugin.CodeAction.PositionIndexed+        Development.IDE.Plugin.CodeAction.Rules+        Development.IDE.Plugin.CodeAction.RuleTypes         Development.IDE.Plugin.Completions.Logic         Development.IDE.Plugin.Completions.Types+    if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)+      hs-source-dirs: src-ghc88+      other-modules:+        Development.IDE.GHC.HieAst+    if (impl(ghc > 8.9))+      hs-source-dirs: src-ghc810+      other-modules:+        Development.IDE.GHC.HieAst     ghc-options: -Wall -Wno-name-shadowing  executable ghcide-test-preprocessor     default-language: Haskell2010     hs-source-dirs: test/preprocessor-    ghc-options: -Wall+    ghc-options: -Wall -Wno-name-shadowing     main-is: Main.hs     build-depends:         base == 4.*@@ -166,29 +190,52 @@                 "-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,-        hie-bios >= 0.4.0 && < 0.5,+        haskell-lsp-types,+        hie-bios >= 0.5.0 && < 0.6,         ghcide,         optparse-applicative,         shake,-        text+        text,+        unordered-containers     other-modules:+        Utils         Arguments         Paths_ghcide      default-extensions:+        BangPatterns+        DeriveFunctor+        DeriveGeneric+        GeneralizedNewtypeDeriving+        LambdaCase+        NamedFieldPuns+        OverloadedStrings         RecordWildCards+        ScopedTypeVariables+        StandaloneDeriving         TupleSections+        TypeApplications         ViewPatterns  test-suite ghcide-tests@@ -220,16 +267,19 @@         haddock-library,         haskell-lsp,         haskell-lsp-types,+        network-uri,         lens,-        lsp-test >= 0.8,+        lsp-test >= 0.11.0.1 && < 0.12,         parser-combinators,         QuickCheck,         quickcheck-instances,         rope-utf16-splay,+        shake,         tasty,         tasty-expected-failure,         tasty-hunit,         tasty-quickcheck,+        tasty-rerun,         text     hs-source-dirs: test/cabal test/exe test/src     include-dirs: include

@@ -0,0 +1,1928 @@+++{-+Forked from GHC v8.10.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 #-}+module Development.IDE.GHC.HieAst ( mkHieFile ) where++import GhcPrelude++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 GHC.Hs+import HscTypes+import Module                     ( ModuleName, ml_hs_file )+import MonadUtils                 ( concatMapM, liftIO )+import Name                       ( Name, nameSrcSpan, setNameLoc )+import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )+import SrcLoc+import TcHsSyn                    ( hsLitType, hsPatType )+import Type                       ( mkVisFunTys, Type )+import TysWiredIn                 ( mkListTy, mkSumTy )+import Var                        ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface                    ( mkIfaceExports )+import Panic++import HieTypes+import 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                  ( foldl1' )+import Data.Maybe                 ( listToMaybe )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class  ( lift )++{- Note [Updating HieAst for changes in the GHC AST]++When updating the code in this file for changes in the GHC AST, you+need to pay attention to the following things:++1) Symbols (Names/Vars/Modules) in the following categories:++   a) Symbols that appear in the source file that directly correspond to+   something the user typed+   b) Symbols that don't appear in the source, but should be in some sense+   "visible" to a user, particularly via IDE tooling or the like. This+   includes things like the names introduced by RecordWildcards (We record+   all the names introduced by a (..) in HIE files), and will include implicit+   parameters and evidence variables after one of my pending MRs lands.++2) Subtrees that may contain such symbols, or correspond to a SrcSpan in+   the file. This includes all `Located` things++For 1), you need to call `toHie` for one of the following instances++instance ToHie (Context (Located Name)) where ...+instance ToHie (Context (Located Var)) where ...+instance ToHie (IEContext (Located ModuleName)) where ...++`Context` is a data type that looks like:++data Context a = C ContextInfo a -- Used for names and bindings++`ContextInfo` is defined in `HieTypes`, and looks like++data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl+  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding+  ...++It is used to annotate symbols in the .hie files with some extra information on+the context in which they occur and should be fairly self explanatory. You need+to select one that looks appropriate for the symbol usage. In very rare cases,+you might need to extend this sum type if none of the cases seem appropriate.++So, given a `Located Name` that is just being "used", and not defined at a+particular location, you would do the following:++   toHie $ C Use located_name++If you select one that corresponds to a binding site, you will need to+provide a `Scope` and a `Span` for your binding. Both of these are basically+`SrcSpans`.++The `SrcSpan` in the `Scope` is supposed to span over the part of the source+where the symbol can be legally allowed to occur. For more details on how to+calculate this, see Note [Capturing Scopes and other non local information]+in HieAst.++The binding `Span` is supposed to be the span of the entire binding for+the name.++For a function definition `foo`:++foo x = x + y+  where y = x^2++The binding `Span` is the span of the entire function definition from `foo x`+to `x^2`.  For a class definition, this is the span of the entire class, and+so on.  If this isn't well defined for your bit of syntax (like a variable+bound by a lambda), then you can just supply a `Nothing`++There is a test that checks that all symbols in the resulting HIE file+occur inside their stated `Scope`. This can be turned on by passing the+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the+.hie file.++You may also want to provide a test in testsuite/test/hiefile that includes+a file containing your new construction, and tests that the calculated scope+is valid (by using -fvalidate-ide-info)++For subtrees in the AST that may contain symbols, the procedure is fairly+straightforward.  If you are extending the GHC AST, you will need to provide a+`ToHie` instance for any new types you may have introduced in the AST.++Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):++  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+        ]+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      ...+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]++If your subtree is `Located` or has a `SrcSpan` available, the output list+should contain a HieAst `Node` corresponding to the subtree. You can use+either `makeNode` or `getTypeNode` for this purpose, depending on whether it+makes sense to assign a `Type` to the subtree. After this, you just need+to concatenate the result of calling `toHie` on all subexpressions and+appropriately annotated symbols contained in the subtree.++The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed+to work for both the renamed and typechecked source. `getTypeNode` is from+the `HasType` class defined in this file, and it has different instances+for `GhcTc` and `GhcRn` that allow it to access the type of the expression+when given a typechecked AST:++class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression+instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type++If your subtree doesn't have a span available, you can omit the `makeNode`+call and just recurse directly in to the subexpressions.++-}++-- 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+++{- 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 :: NameEnv Id+  }++initState :: HieState+initState = HieState emptyNameEnv++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 = extendNameEnv (name_remapping hs) (varName mono) poly}++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 _) = panic "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 (composeSrcSpan a)) $+    listScopes patScope (map dL 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 = NoExtField++class ProtectSig a where+  protectSig :: Scope -> LHsSigWcType (NoGhcTc 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 _ _ = noExtField++instance ProtectSig GhcRn where+  protectSig sc (HsWC a (HsIB b sig)) =+    HsWC a (HsIB b (SH sc sig))+  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec++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 (FamEqn s a) where+  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans+                                              [loc a, loc tvs, 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++{- Note [Real DataCon Name]+The typechecker subtitutes the conLikeWrapId for the name, but we don't want+this showing up in the hieFile, so we replace the name in the Id with the+original datacon name+See also Note [Data Constructor Naming]+-}+class HasRealDataConName p where+  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)++instance HasRealDataConName GhcRn where+  getRealDataCon _ n = n+instance HasRealDataConName GhcTc where+  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =+    L sp (setVarName var (conLikeName con))++-- | The main worker class+-- See Note [Updating HieAst for changes in the GHC AST] for more information+-- on how to add/modify instances for this.+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 NoExtField)) where+  toHie _ = pure []++instance ToHie (TScoped NoExtField) 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 = case lookupNameEnv m (varName name') of+              Just var -> var+              Nothing-> name'+        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 lookupNameEnv m name' 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 (Located (Pat GhcRn)) where+  getTypeNode (dL -> L spn pat) = makeNode pat spn++instance HasType (Located (Pat GhcTc)) where+  getTypeNode (dL -> 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+      Just t -> makeTypeNode e' spn t+      Nothing+        | 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) = mkVisFunTys 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 (Located (Pat (GhcPass p)))) where+  toHie (PS rsp scope pscope lpat@(dL -> 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 (dL 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 _ pat sig ->+        [ toHie $ PS rsp scope pscope pat+        , let cscope = mkLScope (dL 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)+         , (HasRealDataConName 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 _ expr sig ->+        [ 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_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->+        [ toHie $ C Use (getRealDataCon @a mrealcon name)+            -- See Note [Real DataCon Name]+        , toHie $ RC RecFieldAssign $ binds+        ]+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->+        [ toHie expr+        , toHie $ map (RC RecFieldAssign) upds+        ]+      ExprWithTySig _ expr sig ->+        [ 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+        ]+      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+        ]+      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{ group_tyclds = classes+                 , group_roles  = roles+                 , group_kisigs = sigs+                 , group_instds = instances } =+    concatM+    [ toHie classes+    , toHie sigs+    , 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 deftyps+        ]+        where+          context_scope = mkLScope context+          rhs_scope = foldl1' combineScopes $ map mkScope+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]+      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 rhs, HasLoc rhs)+    => ToHie (TScoped (FamEqn GhcRn rhs)) where+  toHie (TS _ f) = toHie f++instance (ToHie rhs, HasLoc rhs)+    => ToHie (FamEqn GhcRn rhs) where+  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie pats+    , toHie rhs+    ]+    where scope = combineScopes patsScope rhsScope+          patsScope = mkScope (loc pats)+          rhsScope = mkScope (loc 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) 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 (LStandaloneKindSig GhcRn) where+  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]++instance ToHie (StandaloneKindSig GhcRn) where+  toHie sig = concatM $ case sig of+    StandaloneKindSig _ name typ ->+      [ toHie $ C TyDecl name+      , toHie $ TS (ResolvedScopes []) typ+      ]+    XStandaloneKindSig _ -> []++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+        ]+      HsAppKindTy _ ty ki ->+        [ toHie ty+        , toHie $ TS (ResolvedScopes []) ki+        ]+      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 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 _ _ _ ->+        []+      HsSplicedT _ ->+        []+      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 _ tybndrs bndrs exprA exprB)) = concatM+        [ makeNode r span+        , pure $ locOnly $ getLoc rname+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+        , toHie $ map (RS $ mkScope span) bndrs+        , toHie exprA+        , toHie exprB+        ]+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          exprA_sc = mkLScope exprA+          exprB_sc = mkLScope 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,1789 @@++{-+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 #-}+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 HieTypes+import 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 Data.Maybe                 ( listToMaybe )+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+++{- 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 (unLoc a)) $+    listScopes patScope (map dL 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 -> LHsSigWcType (NoGhcTc 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 Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans+                                              [loc a, loc tvs, 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++instance HasLoc (Pat (GhcPass a)) where+  loc (dL -> L l _) = l++-- | 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 (dL -> L spn pat) = makeNode pat spn++instance HasType (LPat GhcTc) where+  getTypeNode (dL -> 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@(dL -> 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 (dL 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 _ pat sig ->+        [ toHie $ PS rsp scope pscope pat+        , let cscope = mkLScope (dL 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 _ expr sig ->+        [ 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 sig ->+        [ 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 bndrs pat b rhs) =+             FamEqn a var bndrs (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 tybndrs pats _ rhs) = concatM $+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie pats+    , toHie rhs+    ]+    where scope = combineScopes patsScope rhsScope+          patsScope = mkScope (loc pats)+          rhsScope = mkScope (loc 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) 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+        ]+      HsAppKindTy _ ty ki ->+        [ toHie ty+        , toHie $ TS (ResolvedScopes []) ki+        ]+      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 _ _ _ ->+        []+      HsSplicedT _ ->+        []+      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 _ tybndrs bndrs exprA exprB)) = concatM+        [ makeNode r span+        , pure $ locOnly $ getLoc rname+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+        , toHie $ map (RS $ mkScope span) bndrs+        , toHie exprA+        , toHie exprB+        ]+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          exprA_sc = mkLScope exprA+          exprB_sc = mkLScope 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,19 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Compat+    (+        getProcessID+    ) where++#ifdef mingw32_HOST_OS++import qualified System.Win32.Process as P (getCurrentProcessId)+getProcessID :: IO Int+getProcessID = fromIntegral <$> P.getCurrentProcessId++#else++import qualified System.Posix.Process as P (getProcessID)+getProcessID :: IO Int+getProcessID = fromIntegral <$> P.getProcessID++#endif

@@ -9,6 +9,7 @@ --   Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. module Development.IDE.Core.Compile   ( TcModuleResult(..)+  , RunSimplifier(..)   , compileModule   , parseModule   , typecheckModule@@ -16,6 +17,13 @@   , addRelativeImport   , mkTcModuleResult   , generateByteCode+  , generateAndWriteHieFile+  , generateAndWriteHiFile+  , getModSummaryFromImports+  , loadHieFile+  , loadInterface+  , loadDepModule+  , loadModuleHome   ) where  import Development.IDE.Core.RuleTypes@@ -29,6 +37,7 @@ import qualified GHC.LanguageExtensions.Type as GHC import Development.IDE.Types.Options import Development.IDE.Types.Location+import Outputable  #if MIN_GHC_API_VERSION(8,6,0) import           DynamicLoading (initializePlugins)@@ -37,43 +46,59 @@ import           GHC hiding (parseModule, typecheckModule) import qualified Parser import           Lexer+#if MIN_GHC_API_VERSION(8,10,0)+#else import ErrUtils+#endif -import qualified GHC+import           Finder+import qualified Development.IDE.GHC.Compat     as GHC+import qualified Development.IDE.GHC.Compat     as Compat import           GhcMonad import           GhcPlugins                     as GHC hiding (fst3, (<>)) import qualified HeaderInfo                     as Hdr-import           HscMain                        (hscInteractive)+import           HscMain                        (hscInteractive, hscSimplify)+import           LoadIface                      (readIface)+import qualified Maybes import           MkIface+import           NameCache import           StringBuffer                   as SB+import           TcRnMonad (initIfaceLoad, tcg_th_coreplugins)+import           TcIface                        (typecheckIface) import           TidyPgm +import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.Except import Control.Monad.Trans.Except-import           Data.Function-import           Data.Ord+import Data.Bifunctor                           (first, second) import qualified Data.Text as T import           Data.IORef import           Data.List.Extra import           Data.Maybe-import           Data.Tuple.Extra import qualified Data.Map.Strict                          as Map import           System.FilePath+import           System.Directory+import           System.IO.Extra+import Data.Either.Extra (maybeToEither)+import Control.DeepSeq (rnf)+import Control.Exception (evaluate)+import Exception (ExceptionMonad)   -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule     :: IdeOptions     -> HscEnv+    -> [PackageName]     -> FilePath     -> Maybe SB.StringBuffer     -> IO (IdeResult (StringBuffer, ParsedModule))-parseModule IdeOptions{..} env filename mbContents =+parseModule IdeOptions{..} env comp_pkgs filename mbContents =     fmap (either (, Nothing) id) $-    runGhcEnv env $ runExceptT $ do+    evalGhcEnv env $ runExceptT $ do         (contents, dflags) <- preprocessor filename mbContents-        (diag, modu) <- parseFileContents optPreprocessor dflags filename contents+        (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents         return (diag, Just (contents, modu))  @@ -85,35 +110,40 @@ computePackageDeps env pkg = do     let dflags = hsc_dflags env     case lookupInstalledPackage dflags pkg of-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $+        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $             T.pack $ "unknown package: " ++ show pkg]         Just pkgInfo -> return $ Right $ depends pkgInfo +typecheckModule :: IdeDefer+                -> HscEnv+                -> [(ModSummary, (ModIface, Maybe Linkable))]+                -> ParsedModule+                -> IO (IdeResult (HscEnv, TcModuleResult))+typecheckModule (IdeDefer defer) hsc depsIn pm = do+    fmap (either (, Nothing) (second Just . sequence) . sequence) $+      runGhcEnv hsc $+      catchSrcErrors "typecheck" $ do+        -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.+        -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.+        -- Long-term we might just want to change the order returned by GetDependencies+        let deps = reverse depsIn --- | Typecheck a single module using the supplied dependencies and packages.-typecheckModule-    :: IdeDefer-    -> HscEnv-    -> [TcModuleResult]-    -> ParsedModule-    -> IO (IdeResult TcModuleResult)-typecheckModule (IdeDefer defer) packageState deps pm =-    let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id-    in-    fmap (either (, Nothing) (second Just)) $-    runGhcEnv packageState $-        catchSrcErrors "typecheck" $ do-            setupEnv deps-            let modSummary = pm_mod_summary pm-                dflags = ms_hspp_opts modSummary-            modSummary' <- initPlugins modSummary-            (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->-                GHC.typecheckModule $ enableTopLevelWarnings-                                    $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}-            tcm2 <- mkTcModuleResult tcm-            let errorPipeline = unDefer . hideDiag dflags-            return (map errorPipeline warnings, tcm2)+        setupFinderCache (map fst deps) +        let modSummary = pm_mod_summary pm+            dflags = ms_hspp_opts modSummary++        mapM_ (uncurry loadDepModule . snd) deps+        modSummary' <- initPlugins modSummary+        (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->+            GHC.typecheckModule $ enableTopLevelWarnings+                                $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}+        tcm2 <- mkTcModuleResult tcm+        let errorPipeline = unDefer . hideDiag dflags+        return (map errorPipeline warnings, tcm2)+    where+        demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id+ initPlugins :: GhcMonad m => ModSummary -> m ModSummary initPlugins modSummary = do #if MIN_GHC_API_VERSION(8,6,0)@@ -124,18 +154,25 @@     return modSummary #endif +-- | Whether we should run the -O0 simplifier when generating core.+--+-- This is required for template Haskell to work but we disable this in DAML.+-- See #256+newtype RunSimplifier = RunSimplifier Bool+ -- | Compile a single type-checked module to a 'CoreModule' value, or -- provide errors. compileModule-    :: HscEnv-    -> [TcModuleResult]+    :: RunSimplifier+    -> HscEnv+    -> [(ModSummary, HomeModInfo)]     -> TcModuleResult     -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))-compileModule packageState deps tmr =+compileModule (RunSimplifier simplify) packageState deps tmr =     fmap (either (, Nothing) (second Just)) $-    runGhcEnv packageState $+    evalGhcEnv packageState $         catchSrcErrors "compile" $ do-            setupEnv (deps ++ [tmr])+            setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])              let tm = tmrModule tmr             session <- getSession@@ -144,20 +181,30 @@                 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}                 let tm' = tm{tm_parsed_module  = pm'}                 GHC.dm_core_module <$> GHC.desugarModule tm'-+            let tc_result = fst (tm_internals_ (tmrModule tmr))+            desugared_guts <-+                if simplify+                    then do+                        plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+                        liftIO $ hscSimplify session plugins desugar+                    else pure desugar             -- give variables unique OccNames-            (guts, details) <- liftIO $ tidyProgram session desugar+            (guts, details) <- liftIO $ tidyProgram session desugared_guts             return (map snd warnings, (mg_safe_haskell desugar, guts, details)) -generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable) generateByteCode hscEnv deps tmr guts =     fmap (either (, Nothing) (second Just)) $-    runGhcEnv hscEnv $+    evalGhcEnv hscEnv $       catchSrcErrors "bytecode" $ do-          setupEnv (deps ++ [tmr])+          setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])           session <- getSession           (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->-              liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)+#if MIN_GHC_API_VERSION(8,10,0)+                liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)+#else+                liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)+#endif           let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr           let unlinked = BCOs bytecode sptEntries           let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]@@ -179,9 +226,10 @@ enableTopLevelWarnings :: ParsedModule -> ParsedModule enableTopLevelWarnings =   (update_pm_mod_summary . update_hspp_opts)-  (`wopt_set` Opt_WarnMissingSignatures)+  ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .+   (`wopt_set` Opt_WarnMissingSignatures))   -- the line below would show also warnings for let bindings without signature-  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))+  -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))  update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}@@ -205,9 +253,9 @@ hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) hideDiag originalFlags (Reason warning, (nfp, _sh, fd))   | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))-hideDiag _originalFlags t = t +hideDiag _originalFlags t = t -addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags addRelativeImport fp modu dflags = dflags     {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} @@ -217,25 +265,81 @@     -> m TcModuleResult mkTcModuleResult tcm = do     session <- getSession-    (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv+    let sf = modInfoSafe (tm_checked_module_info tcm)+#if MIN_GHC_API_VERSION(8,10,0)+    iface <- liftIO $ mkIfaceTc session sf details tcGblEnv+#else+    (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv+#endif     let mod_info = HomeModInfo iface details Nothing     return $ TcModuleResult tcm mod_info   where     (tcGblEnv, details) = tm_internals_ tcm +atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()+atomicFileWrite targetPath write = do+  let dir = takeDirectory targetPath+  createDirectoryIfMissing True dir+  (tempFilePath, cleanUp) <- newTempFileWithin dir+  (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp++generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]+generateAndWriteHieFile hscEnv tcm =+  handleGenerationErrors dflags "extended interface generation" $ do+    case tm_renamed_source tcm of+      Just rnsrc -> do+        hf <- runHsc hscEnv $+          GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""+        atomicFileWrite targetPath $ flip GHC.writeHieFile hf+      _ ->+        return ()+  where+    dflags       = hsc_dflags hscEnv+    mod_summary  = pm_mod_summary $ tm_parsed_module tcm+    mod_location = ms_location mod_summary+    targetPath   = Compat.ml_hie_file mod_location++generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]+generateAndWriteHiFile hscEnv tc =+  handleGenerationErrors dflags "interface generation" $ do+    atomicFileWrite targetPath $ \fp ->+      writeIfaceFile dflags fp modIface+  where+    modIface = hm_iface $ tmrModInfo tc+    modSummary = tmrModSummary tc+    targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc+    withBootSuffix = case ms_hsc_src modSummary of+                HsBootFile -> addBootSuffix+                _ -> id+    dflags = hsc_dflags hscEnv++handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]+handleGenerationErrors dflags source action =+  action >> return [] `catches`+    [ Handler $ return . diagFromGhcException source dflags+    , Handler $ return . diagFromString source DsError (noSpan "<internal>")+    . (("Error during " ++ T.unpack source) ++) . show @SomeException+    ]++ -- | Setup the environment that GHC needs according to our -- best understanding (!)-setupEnv :: GhcMonad m => [TcModuleResult] -> m ()-setupEnv tmsIn = do-    -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file-    -- takes precedence, so put the .hs-boot file earlier in the list-    let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule-        tms = sortBy (compare `on` Down . isSourceFile) tmsIn+--+-- This involves setting up the finder cache and populating the+-- HPT.+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()+setupEnv tms = do+    setupFinderCache (map fst tms)+    -- load dependent modules, which must be in topological order.+    modifySession $ \e ->+      foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms +-- | Initialise the finder cache, dependencies should be topologically+-- sorted.+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()+setupFinderCache mss = do     session <- getSession -    let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms-     -- set the target and module graph in the session     let graph = mkModuleGraph mss     setSession session { hsc_mod_graph = graph }@@ -254,26 +358,40 @@     newFinderCacheVar <- liftIO $ newIORef $! newFinderCache     modifySession $ \s -> s { hsc_FC = newFinderCacheVar } -    -- load dependent modules, which must be in topological order.-    mapM_ loadModuleHome tms - -- | Load a module, quickly. Input doesn't need to be desugared. -- A module must be loaded before dependent modules can be typechecked. -- This variant of loadModuleHome will *never* cause recompilation, it just -- modifies the session.+--+-- The order modules are loaded is important when there are hs-boot files.+-- In particular you should make sure to load the .hs version of a file after the+-- .hs-boot version. loadModuleHome-    :: (GhcMonad m)-    => TcModuleResult-    -> m ()-loadModuleHome tmr = modifySession $ \e ->-    e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }-  where-    ms       = pm_mod_summary . tm_parsed_module . tmrModule $ tmr-    mod_info = tmrModInfo tmr-    mod      = ms_mod_name ms+    :: HomeModInfo+    -> HscEnv+    -> HscEnv+loadModuleHome mod_info e =+    e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }+    where+      mod_name = moduleName $ mi_module $ hm_iface mod_info +-- | Load module interface.+loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv+loadDepModuleIO iface linkable hsc = do+    details <- liftIO $ fixIO $ \details -> do+        let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }+        initIfaceLoad hsc' (typecheckIface iface)+    let mod_info = HomeModInfo iface details linkable+    return $ loadModuleHome mod_info hsc+    where+      mod = moduleName $ mi_module iface +loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()+loadDepModule iface linkable = do+  e <- getSession+  e' <- liftIO $ loadDepModuleIO iface linkable e+  setSession e'  -- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's -- name and its imports.@@ -294,30 +412,18 @@     , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"     ]) - -- | Produce a module summary from a StringBuffer. getModSummaryFromBuffer     :: GhcMonad m     => FilePath-    -> SB.StringBuffer     -> DynFlags     -> GHC.ParsedSource     -> ExceptT [FileDiagnostic] m ModSummary-getModSummaryFromBuffer fp contents dflags parsed = do+getModSummaryFromBuffer fp dflags parsed = do   (modName, imports) <- liftEither $ getImportsParsed dflags parsed -  let modLoc = ModLocation-          { ml_hs_file  = Just fp-          , ml_hi_file  = derivedFile "hi"-          , ml_obj_file = derivedFile "o"-#if MIN_GHC_API_VERSION(8,8,0)-          , ml_hie_file = derivedFile "hie"-#endif-          -- This does not consider the dflags configuration-          -- (-osuf and -hisuf, object and hi dir.s).-          -- However, we anyway don't want to generate them.-          }-      InstalledUnitId unitId = thisInstalledUnitId dflags+  modLoc <- liftIO $ mkHomeModLocation dflags modName fp+  let InstalledUnitId unitId = thisInstalledUnitId dflags   return $ ModSummary     { ms_mod          = mkModule (fsToUnitId unitId) modName     , ms_location     = modLoc@@ -329,7 +435,7 @@     , ms_textual_imps = [imp | (False, imp) <- imports]     , ms_hspp_file    = fp     , ms_hspp_opts    = dflags-    , ms_hspp_buf     = Just contents+    , ms_hspp_buf     = Nothing      -- defaults:     , ms_hsc_src      = sourceType@@ -342,27 +448,71 @@     , ms_parsed_mod   = Nothing     }     where-      (sourceType, derivedFile) =-          let (stem, ext) = splitExtension fp in-          if "-boot" `isSuffixOf` ext-          then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")-          else (HsSrcFile , \newExt -> stem <.> newExt)+      sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile +-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.+--   Runs preprocessors as needed.+getModSummaryFromImports+  :: (HasDynFlags m, ExceptionMonad m, MonadIO m)+  => FilePath+  -> Maybe SB.StringBuffer+  -> ExceptT [FileDiagnostic] m ModSummary+getModSummaryFromImports fp contents = do+    (contents, dflags) <- preprocessor fp contents+    (srcImports, textualImports, L _ moduleName) <-+        ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp --- | Given a buffer, flags, file path and module summary, produce a+    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily+    liftIO $ evaluate $ rnf srcImports+    liftIO $ evaluate $ rnf textualImports++    modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp++    let mod = mkModule (thisPackage dflags) moduleName+        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile+        summary =+            ModSummary+                { ms_mod          = mod+#if MIN_GHC_API_VERSION(8,8,0)+                , ms_hie_date     = Nothing+#endif+                , ms_hs_date      = error "Rules should not depend on ms_hs_date"+        -- When we are working with a virtual file we do not have a file date.+        -- To avoid silent issues where something is not processed because the date+        -- has not changed, we make sure that things blow up if they depend on the date.+                , ms_hsc_src      = sourceType+                , ms_hspp_buf     = Nothing+                , ms_hspp_file    = fp+                , ms_hspp_opts    = dflags+                , ms_iface_date   = Nothing+                , ms_location     = modLoc+                , ms_obj_date     = Nothing+                , ms_parsed_mod   = Nothing+                , ms_srcimps      = srcImports+                , ms_textual_imps = textualImports+                }+    return summary+++-- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors parseFileContents        :: GhcMonad m        => (GHC.ParsedSource -> IdePreprocessedSource)        -> DynFlags -- ^ flags to use+       -> [PackageName] -- ^ The package imports to ignore        -> FilePath  -- ^ the filename (for source locations)        -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)-parseFileContents customPreprocessor dflags filename contents = do+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do    let loc  = mkRealSrcLoc (mkFastString filename) 1 1    case unP Parser.parseModule (mkPState dflags contents loc) of+#if MIN_GHC_API_VERSION(8,10,0)+     PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags+#else      PFailed _ locErr msgErr ->       throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr+#endif      POk pst rdr_module ->          let hpm_annotations =                (Map.fromListWith (++) $ annotations pst,@@ -386,14 +536,63 @@                -- Ok, we got here. It's safe to continue.                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module                unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs+               let parsed' = removePackageImports comp_pkgs parsed                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns-               ms <- getModSummaryFromBuffer filename contents dflags parsed+               ms <- getModSummaryFromBuffer filename dflags parsed'                let pm =                      ParsedModule {                          pm_mod_summary = ms-                       , pm_parsed_source = parsed+                       , pm_parsed_source = parsed'                        , pm_extra_src_files=[] -- src imports not allowed                        , pm_annotations = hpm_annotations                       }                    warnings = diagFromErrMsgs "parser" dflags warns                pure (warnings ++ preproc_warnings, pm)+++-- | After parsing the module remove all package imports referring to+-- these packages as we have already dealt with what they map to.+removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource+removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })+  where+    imports' = map do_one_import hsmodImports+    do_one_import (L l i@ImportDecl{ideclPkgQual}) =+      case PackageName . sl_fs <$> ideclPkgQual of+        Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })+        _ -> L l i+#if MIN_GHC_API_VERSION(8,6,0)+    do_one_import l = l+#endif++loadHieFile :: FilePath -> IO GHC.HieFile+loadHieFile f = do+        u <- mkSplitUniqSupply 'a'+        let nameCache = initNameCache u []+        fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f++-- | Retuns an up-to-date module interface if available.+--   Assumes file exists.+--   Requires the 'HscEnv' to be set up with dependencies+loadInterface+  :: HscEnv+  -> ModSummary+  -> [HiFileResult]+  -> IO (Either String ModIface)+loadInterface session ms deps = do+  let hiFile = case ms_hsc_src ms of+                HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)+                _ -> ml_hi_file $ ms_location ms+  r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile+  case r of+    Maybes.Succeeded iface -> do+      session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps+      (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)+      return $ maybeToEither (showReason reason) iface'+    Maybes.Failed err -> do+      let errMsg = showSDoc (hsc_dflags session) err+      return $ Left errMsg++showReason :: RecompileRequired -> String+showReason MustCompile = "Stale"+showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"+showReason UpToDate = "Up to date"

@@ -3,8 +3,9 @@  module Development.IDE.Core.Debouncer     ( Debouncer-    , newDebouncer     , registerEvent+    , newAsyncDebouncer+    , noopDebouncer     ) where  import Control.Concurrent.Extra@@ -22,13 +23,14 @@ -- by delaying each event for a given time. If another event -- is registered for the same key within that timeframe, -- only the new event will fire.-newtype Debouncer k = Debouncer (Var (HashMap k (Async ())))+--+-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable+-- debouncing in the DAML CLI compiler.+newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () } --- | Create a new empty debouncer.-newDebouncer :: IO (Debouncer k)-newDebouncer = do-    m <- newVar Map.empty-    pure $ Debouncer m+-- | Debouncer used in the IDE that delays events as expected.+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty  -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then.@@ -36,11 +38,15 @@ -- If there is a pending event for the same key, the pending event will be killed. -- Events are run unmasked so it is up to the user of `registerEvent` -- to mask if required.-registerEvent :: (Eq k, Hashable k) => Debouncer k -> Seconds -> k -> IO () -> IO ()-registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do     whenJust (Map.lookup k m) cancel     a <- asyncWithUnmask $ \unmask -> unmask $ do         sleep delay         fire         modifyVar_ d (pure . Map.delete k)     pure $ Map.insert k a m++-- | Debouncer used in the DAML CLI compiler that emits events immediately.+noopDebouncer :: Debouncer k+noopDebouncer = Debouncer $ \_ _ a -> a

@@ -14,13 +14,15 @@ import qualified Data.Aeson                    as A import           Data.Binary import qualified Data.ByteString               as BS-import           Data.Map.Strict                ( Map )-import qualified Data.Map.Strict               as Map+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import           Data.Maybe import qualified Data.Text                     as T import           Development.IDE.Core.FileStore+import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.Shake import           Development.IDE.Types.Location+import           Development.IDE.Types.Logger import           Development.Shake import           Development.Shake.Classes import           GHC.Generics@@ -30,7 +32,7 @@ import qualified System.Directory as Dir  -- | A map for tracking the file existence-type FileExistsMap = (Map NormalizedFilePath Bool)+type FileExistsMap = (HashMap NormalizedFilePath Bool)  -- | A wrapper around a mutable 'FileExistsMap' newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)@@ -53,12 +55,12 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () modifyFileExists state changes = do   FileExistsMapVar var <- getIdeGlobalState state-  changesMap           <- evaluate $ Map.fromList changes+  changesMap           <- evaluate $ HashMap.fromList changes    -- Masked to ensure that the previous values are flushed together with the map update   mask $ \_ -> do     -- update the map-    modifyVar_ var $ evaluate . Map.union changesMap+    modifyVar_ var $ evaluate . HashMap.union changesMap     -- flush previous values     mapM_ (deleteValue state GetFileExists . fst) changes @@ -89,20 +91,34 @@ --   Provides a fast implementation if client supports dynamic watched files. --   Creates a global state as a side effect in that case. fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()-fileExistsRules getLspId ClientCapabilities{_workspace}-  | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace-  , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles-  , Just True <- _dynamicRegistration-  = fileExistsRulesFast getLspId-  | otherwise = fileExistsRulesSlow+fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do+  -- Create the global always, although it should only be used if we have fast rules.+  -- But there's a chance someone will send unexpected notifications anyway,+  -- e.g. https://github.com/digital-asset/ghcide/issues/599+  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])+  case () of+    _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+      , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+      , Just True <- _dynamicRegistration+        -> fileExistsRulesFast getLspId vfs+      | otherwise -> do+        logger <- logger <$> getShakeExtrasRules+        liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"+        fileExistsRulesSlow vfs  --   Requires an lsp client that provides WatchedFiles notifications. fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()-fileExistsRulesFast getLspId vfs = do-  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])+fileExistsRulesFast getLspId vfs =   defineEarlyCutoff $ \GetFileExists file -> do+    isWf <- isWorkspaceFile file+    if isWf+        then fileExistsFast getLspId vfs file+        else fileExistsSlow vfs file++fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))+fileExistsFast getLspId vfs file = do     fileExistsMap <- getFileExistsMapUntracked-    let mbFilesWatched = Map.lookup file fileExistsMap+    let mbFilesWatched = HashMap.lookup file fileExistsMap     case mbFilesWatched of       Just fv -> pure (summarizeExists fv, ([], Just fv))       Nothing -> do@@ -113,7 +129,7 @@         -- taking the FileExistsMap lock to prevent race conditions         -- that would lead to multiple listeners for the same path         modifyFileExistsAction $ \x -> do-          case Map.insertLookupWithKey (\_ x _ -> x) file exist x of+          case HashMap.alterF (,Just exist) file x of             (Nothing, x') -> do             -- if the listener addition fails, we never recover. This is a bug.               addListener eventer file@@ -134,9 +150,10 @@                                   WorkspaceDidChangeWatchedFiles                                   (Just (A.toJSON regOptions))       regOptions =-        DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }-      watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp-                                  , kind        = Just 5 -- Create and Delete events only+        DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }+      watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}+      watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp+                                  , _kind        = Just watchKind                                   }      eventer $ ReqRegisterCapability req@@ -145,8 +162,11 @@ summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty  fileExistsRulesSlow:: VFSHandle -> Rules ()-fileExistsRulesSlow vfs = do-  defineEarlyCutoff $ \GetFileExists file -> do+fileExistsRulesSlow vfs =+  defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file++fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))+fileExistsSlow vfs file = do     alwaysRerun     exist <- liftIO $ getFileExistsVFS vfs file     pure (summarizeExists exist, ([], Just exist))@@ -159,29 +179,3 @@     handle (\(_ :: IOException) -> return False) $         (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^         Dir.doesFileExist (fromNormalizedFilePath file)------------------------------------------------------------------------------------------------------- The message definitions below probably belong in haskell-lsp-types--data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions-    { watchers :: List FileSystemWatcher-    }--instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where-  toJSON DidChangeWatchedFilesRegistrationOptions {..} =-    A.object ["watchers" A..= watchers]--data FileSystemWatcher = FileSystemWatcher-    { -- | The glob pattern to watch.-      --   For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles-      globPattern :: String-        -- | The kind of event to subscribe to. Defaults to all.-        --   Defined as a bitmap of Create(1), Change(2), and Delete(4)-    , kind        :: Maybe Int-    }--instance A.ToJSON FileSystemWatcher where-  toJSON FileSystemWatcher {..} =-    A.object-      $  ["globPattern" A..= globPattern]-      ++ [ "kind" A..= x | Just x <- [kind] ]

@@ -95,11 +95,12 @@ getModificationTimeRule vfs =     defineEarlyCutoff $ \GetModificationTime file -> do         let file' = fromNormalizedFilePath file-        let wrap time = (Just time, ([], Just $ ModificationTime time))+        let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))         alwaysRerun         mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file         case mbVirtual of-            Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))+            Just (virtualFileVersion -> ver) ->+                pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))             Nothing -> liftIO $ fmap wrap (getModTime file')               `catch` \(e :: IOException) -> do                 let err | isDoesNotExistError e = "File does not exist: " ++ file'@@ -115,11 +116,13 @@     -- We might also want to try speeding this up on Windows at some point.     -- TODO leverage DidChangeWatchedFile lsp notifications on clients that     -- support them, as done for GetFileExists-    getModTime :: FilePath -> IO BS.ByteString+    getModTime :: FilePath -> IO (Int,Int)     getModTime f = #ifdef mingw32_HOST_OS         do time <- Dir.getModificationTime f-           pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)+           let !day = fromInteger $ toModifiedJulianDay $ utctDay time+               !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time+           pure (day, dayTime) #else         withCString f $ \f' ->         alloca $ \secPtr ->@@ -127,7 +130,7 @@             Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr             sec <- peek secPtr             nsec <- peek nsecPtr-            pure $! BS.pack $ show sec <> "." <> show nsec+            pure (fromEnum sec, fromIntegral nsec)  -- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow -- as doing the FFI call ourselves :(.

@@ -0,0 +1,71 @@+{-# LANGUAGE DuplicateRecordFields #-}+module Development.IDE.Core.IdeConfiguration+  ( IdeConfiguration(..)+  , registerIdeConfiguration+  , parseConfiguration+  , parseWorkspaceFolder+  , isWorkspaceFile+  , modifyWorkspaceFolders+  )+where++import           Control.Concurrent.Extra+import           Control.Monad+import           Data.HashSet                   (HashSet, singleton)+import           Data.Text                      (Text, isPrefixOf)+import           Development.IDE.Core.Shake+import           Development.IDE.Types.Location+import           Development.Shake+import           Language.Haskell.LSP.Types+import           System.FilePath (isRelative)++-- | Lsp client relevant configuration details+data IdeConfiguration = IdeConfiguration+  { workspaceFolders :: HashSet NormalizedUri+  }+  deriving (Show)++newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}++instance IsIdeGlobal IdeConfigurationVar++registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()+registerIdeConfiguration extras =+  addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar++getIdeConfiguration :: Action IdeConfiguration+getIdeConfiguration =+  getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef++parseConfiguration :: InitializeParams -> IdeConfiguration+parseConfiguration InitializeParams {..} =+  IdeConfiguration { .. }+ where+  workspaceFolders =+    foldMap (singleton . toNormalizedUri) _rootUri+      <> (foldMap . foldMap)+           (singleton . parseWorkspaceFolder)+           _workspaceFolders++parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri+parseWorkspaceFolder =+  toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)++modifyWorkspaceFolders+  :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()+modifyWorkspaceFolders ide f = do+  IdeConfigurationVar var <- getIdeGlobalState ide+  IdeConfiguration    ws  <- readVar var+  writeVar var (IdeConfiguration (f ws))++isWorkspaceFile :: NormalizedFilePath -> Action Bool+isWorkspaceFile file =+  if isRelative (fromNormalizedFilePath file)+    then return True+    else do+      IdeConfiguration {..} <- getIdeConfiguration+      let toText = getUri . fromNormalizedUri+      return $+        any+          (\root -> toText root `isPrefixOf` toText (filePathToUri' file))+          workspaceFolders

@@ -19,8 +19,8 @@ import Data.Typeable import qualified Data.ByteString.UTF8 as BS import Control.Exception-import Data.Set (Set)-import qualified Data.Set as Set+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import qualified Data.Text as T import Data.Tuple.Extra import Data.Functor@@ -31,10 +31,10 @@ import Development.IDE.Core.Shake  -newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath)) instance IsIdeGlobal OfInterestVar -type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath  data GetFilesOfInterest = GetFilesOfInterest     deriving (Eq, Show, Typeable, Generic)@@ -46,7 +46,7 @@ -- | The rule that initialises the files of interest state. ofInterestRules :: Rules () ofInterestRules = do-    addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)+    addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)     defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do         alwaysRerun         filesOfInterest <- getFilesOfInterestUntracked@@ -54,7 +54,7 @@   -- | Get the files that are open in the IDE.-getFilesOfInterest :: Action (Set NormalizedFilePath)+getFilesOfInterest :: Action (HashSet NormalizedFilePath) getFilesOfInterest = useNoFile_ GetFilesOfInterest  @@ -64,19 +64,19 @@  -- | Set the files-of-interest - not usually necessary or advisable. --   The LSP client will keep this information up to date.-setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO () setFilesOfInterest state files = modifyFilesOfInterest state (const files) -getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath) getFilesOfInterestUntracked = do     OfInterestVar var <- getIdeGlobalAction     liftIO $ readVar var  -- | Modify the files-of-interest - not usually necessary or advisable. --   The LSP client will keep this information up to date.-modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()+modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO () modifyFilesOfInterest state f = do     OfInterestVar var <- getIdeGlobalState state     files <- modifyVar var $ pure . dupe . f-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)+    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)     void $ shakeRun state []

@@ -2,10 +2,15 @@ -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping   ( PositionMapping(..)+  , fromCurrentPosition+  , toCurrentPosition+  , PositionDelta(..)+  , addDelta+  , mkDelta   , toCurrentRange   , fromCurrentRange   , applyChange-  , idMapping+  , zeroMapping   -- toCurrent and fromCurrent are mainly exposed for testing   , toCurrent   , fromCurrent@@ -14,12 +19,25 @@ import Control.Monad import qualified Data.Text as T import Language.Haskell.LSP.Types+import Data.List -data PositionMapping = PositionMapping-  { toCurrentPosition :: !(Position -> Maybe Position)-  , fromCurrentPosition :: !(Position -> Maybe Position)+-- The position delta is the difference between two versions+data PositionDelta = PositionDelta+  { toDelta :: !(Position -> Maybe Position)+  , fromDelta :: !(Position -> Maybe Position)   } +fromCurrentPosition :: PositionMapping -> Position -> Maybe Position+fromCurrentPosition (PositionMapping pm) = fromDelta pm++toCurrentPosition :: PositionMapping -> Position -> Maybe Position+toCurrentPosition (PositionMapping pm) = toDelta pm++-- A position mapping is the difference from the current version to+-- a specific version+newtype PositionMapping = PositionMapping PositionDelta++ toCurrentRange :: PositionMapping -> Range -> Maybe Range toCurrentRange mapping (Range a b) =     Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b@@ -28,13 +46,33 @@ fromCurrentRange mapping (Range a b) =     Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b -idMapping :: PositionMapping-idMapping = PositionMapping Just Just+zeroMapping :: PositionMapping+zeroMapping = PositionMapping idDelta -applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping-applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping-    { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping-    , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t+-- | Compose two position mappings. Composes in the same way as function+-- composition (ie the second argument is applyed to the position first).+composeDelta :: PositionDelta+                -> PositionDelta+                -> PositionDelta+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =+  PositionDelta (to1 <=< to2)+                (from1 >=> from2)++idDelta :: PositionDelta+idDelta = PositionDelta Just Just++-- | Convert a set of changes into a delta from k  to k + 1+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta+mkDelta cs = foldl' applyChange idDelta cs++-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n+addDelta :: PositionDelta -> PositionMapping -> PositionMapping+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)++applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta+    { toDelta = toCurrent r t <=< toDelta+    , fromDelta = fromDelta <=< fromCurrent r t     } applyChange posMapping _ = posMapping 

@@ -29,11 +29,15 @@ import Data.Text (Text) import qualified Data.Text as T import Outputable (showSDoc)+import Control.DeepSeq (NFData(rnf))+import Control.Exception (evaluate)+import Control.Monad.IO.Class (MonadIO)+import Exception (ExceptionMonad)   -- | Given a file and some contents, apply any necessary preprocessors, --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.-preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags) preprocessor filename mbContents = do     -- Perform unlit     (isOnDisk, contents) <-@@ -96,7 +100,7 @@  diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs =-  map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $+  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $     go [] logs   where     -- On errors, CPP calls logAction with a real span for the initial log and@@ -118,7 +122,8 @@           _code = Nothing,           _source = Just "CPP",           _message = T.unlines $ cdMessage d,-          _relatedInformation = Nothing+          _relatedInformation = Nothing,+          _tags = Nothing         }  @@ -128,13 +133,17 @@  -- | This reads the pragma information directly from the provided buffer. parsePragmasIntoDynFlags-    :: GhcMonad m+    :: (ExceptionMonad m, HasDynFlags m, MonadIO m)     => FilePath     -> SB.StringBuffer     -> m (Either [FileDiagnostic] DynFlags) parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do-    dflags0  <- getSessionDynFlags+    dflags0  <- getDynFlags     let opts = Hdr.getOptions dflags0 contents fp++    -- Force bits that might keep the dflags and stringBuffer alive unnecessarily+    liftIO $ evaluate $ rnf opts+     (dflags, _, _) <- parseDynamicFilePragma dflags0 opts     return dflags @@ -166,18 +175,11 @@     escape (c:cs)    = c : escape cs     escape []        = [] --modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags-modifyOptP op = onSettings (onOptP op)-  where-    onSettings f x = x{settings = f $ settings x}-    onOptP f x = x{sOpt_P = f $ sOpt_P x}- -- | Run CPP on a file runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer runCpp dflags filename contents = withTempDir $ \dir -> do     let out = dir </> takeFileName filename <.> "out"-    dflags <- pure $ modifyOptP ("-D__GHCIDE__":) dflags+    dflags <- pure $ addOptP "-D__GHCIDE__" dflags      case contents of         Nothing -> do

@@ -15,7 +15,6 @@ import Data.Binary import           Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Util-import Development.IDE.Types.Location import           Data.Hashable import           Data.Typeable import qualified Data.Set as S@@ -25,9 +24,9 @@ import           GHC import Module (InstalledUnitId) import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)-import Development.IDE.GHC.Compat  import           Development.IDE.Spans.Type+import           Development.IDE.Import.FindImports (ArtifactsLocation)   -- NOTATION@@ -58,6 +57,22 @@ instance NFData TcModuleResult where     rnf = rwhnf +tmrModSummary :: TcModuleResult -> ModSummary+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule++data HiFileResult = HiFileResult+    { hirModSummary :: !ModSummary+    -- Bang patterns here are important to stop the result retaining+    -- a reference to a typechecked module+    , hirModIface :: !ModIface+    }++instance NFData HiFileResult where+    rnf = rwhnf++instance Show HiFileResult where+    show = show . hirModSummary+ -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult @@ -75,17 +90,25 @@  -- | Resolve the imports in a module to the file path of a module -- in the same package or the package id of another package.-type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)  -- | This rule is used to report import cycles. It depends on GetDependencyInformation. -- We cannot report the cycles directly from GetDependencyInformation since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () --- | Read the given HIE file.-type instance RuleResult GetHieFile = HieFile+-- | Read the module interface file+type instance RuleResult GetHiFile = HiFileResult +-- | Get a module interface, either from an interface file or a typechecked module+type instance RuleResult GetModIface = HiFileResult +type instance RuleResult IsFileOfInterest = Bool++-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.+-- without needing to parse the entire source+type instance RuleResult GetModSummary = ModSummary+ data GetParsedModule = GetParsedModule     deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule@@ -146,10 +169,26 @@ instance NFData   GhcSession instance Binary   GhcSession --- Note that we embed the filepath here instead of using the filepath associated with Shake keys.--- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.-data GetHieFile = GetHieFile FilePath+data GetHiFile = GetHiFile     deriving (Eq, Show, Typeable, Generic)-instance Hashable GetHieFile-instance NFData   GetHieFile-instance Binary   GetHieFile+instance Hashable GetHiFile+instance NFData   GetHiFile+instance Binary   GetHiFile++data GetModIface = GetModIface+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModIface+instance NFData   GetModIface+instance Binary   GetModIface++data IsFileOfInterest = IsFileOfInterest+    deriving (Eq, Show, Typeable, Generic)+instance Hashable IsFileOfInterest+instance NFData   IsFileOfInterest+instance Binary   IsFileOfInterest++data GetModSummary = GetModSummary+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetModSummary+instance NFData   GetModSummary+instance Binary   GetModSummary

@@ -1,16 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE DuplicateRecordFields #-}+#include "ghc-api-version.h"  -- | A Shake implementation of the compiler service, built --   using the "Shaker" abstraction layer for in-memory use. -- module Development.IDE.Core.Rules(     IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),-    Priority(..),+    Priority(..), GhcSessionIO(..), GhcSessionFun(..),     priorityTypeCheck,     priorityGenerateCore,     priorityFilesOfInterest,@@ -26,11 +28,13 @@  import Fingerprint -import Data.Binary-import Control.Monad+import Data.Binary hiding (get, put)+import Data.Bifunctor (first, second)+import Control.Monad.Extra import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Development.IDE.Core.Compile+import Development.IDE.Core.OfInterest import Development.IDE.Types.Options import Development.IDE.Spans.Calculate import Development.IDE.Import.DependencyInformation@@ -39,35 +43,40 @@ import           Development.IDE.Core.FileStore        (getFileContents) import           Development.IDE.Types.Diagnostics import Development.IDE.Types.Location+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) import Development.IDE.GHC.Util-import Data.Coerce+import Development.IDE.GHC.WithDynFlags import Data.Either.Extra import Data.Maybe import           Data.Foldable import qualified Data.IntMap.Strict as IntMap-import qualified Data.IntSet as IntSet+import Data.IntMap.Strict (IntMap) import Data.List+import Data.Ord import qualified Data.Set                                 as Set import qualified Data.Text                                as T import           Development.IDE.GHC.Error import           Development.Shake                        hiding (Diagnostic) import Development.IDE.Core.RuleTypes import Development.IDE.Spans.Type+import qualified Data.ByteString.Char8 as BS -import           GHC hiding (parseModule, typecheckModule) import qualified GHC.LanguageExtensions as LangExt-import Development.IDE.GHC.Compat (hie_file_result, readHieFile)-import           UniqSupply-import NameCache import HscTypes-import DynFlags (xopt)+import PackageConfig+import DynFlags (gopt_set, xopt) import GHC.Generics(Generic)  import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Core.Service import Development.IDE.Core.Shake-import Development.Shake.Classes+import Development.Shake.Classes hiding (get, put)+import Control.Monad.Trans.Except (runExceptT)+import Data.ByteString (ByteString)+import Control.Concurrent.Async (concurrently) +import Control.Monad.State+ -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing -- warnings while also producing a result.@@ -80,14 +89,14 @@ useE k = MaybeT . use k  useNoFileE :: IdeRule k v => k -> MaybeT Action v-useNoFileE k = useE k ""+useNoFileE k = useE k emptyFilePath  usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v] usesE k = MaybeT . fmap sequence . uses k  defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = define $ \k file -> do-    if file == "" then do res <- f k; return ([], Just res) else+    if file == emptyFilePath then do res <- f k; return ([], Just res) else         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"  @@ -111,10 +120,59 @@ getDefinition file pos = fmap join $ runMaybeT $ do     opts <- lift getIdeOptions     spans <- useE GetSpanInfo file-    pkgState <- hscEnv <$> useE GhcSession file-    let getHieFile x = useNoFile (GetHieFile x)-    lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos+    lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos +getHieFile+  :: NormalizedFilePath -- ^ file we're editing+  -> Module -- ^ module dep we want info for+  -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module+getHieFile file mod = do+  TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file+  case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of+    Just NamedModuleDep{nmdFilePath=nfp} -> do+        let modPath = fromNormalizedFilePath nfp+        (_diags, hieFile) <- getHomeHieFile nfp+        return $ (, modPath) <$> hieFile+    _ -> getPackageHieFile mod file+++getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)+getHomeHieFile f = do+  ms <- use_ GetModSummary f+  let normal_hie_f = toNormalizedFilePath' hie_f+      hie_f = ml_hie_file $ ms_location ms+  mbHieTimestamp <- use GetModificationTime normal_hie_f+  srcTimestamp   <- use_ GetModificationTime f+  let isUpToDate+        | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT+        | otherwise = False++  unless isUpToDate $+       void $ use_ TypeCheck f++  hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)+  return ([], hf)++getPackageHieFile :: Module             -- ^ Package Module to load .hie file for+                  -> NormalizedFilePath -- ^ Path of home module importing the package module+                  -> Action (Maybe (HieFile, FilePath))+getPackageHieFile mod file = do+    pkgState  <- hscEnv <$> use_ GhcSession file+    IdeOptions {..} <- getIdeOptions+    let unitId = moduleUnitId mod+    case lookupPackageConfig unitId pkgState of+        Just pkgConfig -> do+            -- 'optLocateHieFile' returns Nothing if the file does not exist+            hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod+            path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod+            case (hieFile, path) of+                (Just hiePath, Just modPath) ->+                    -- deliberately loaded outside the Shake graph+                    -- to avoid dependencies on non-workspace files+                        liftIO $ Just . (, modPath) <$> loadHieFile hiePath+                _ -> return Nothing+        _ -> return Nothing+ -- | Parse the contents of a daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) getParsedModule file = use GetParsedModule file@@ -133,31 +191,60 @@ priorityFilesOfInterest = Priority (-2)  getParsedModuleRule :: Rules ()-getParsedModuleRule =-    defineEarlyCutoff $ \GetParsedModule file -> do-        (_, contents) <- getFileContents file-        packageState <- hscEnv <$> use_ GhcSession file-        opt <- getIdeOptions-        (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)-        case res of-            Nothing -> pure (Nothing, (diag, Nothing))-            Just (contents, modu) -> do-                mbFingerprint <- if isNothing $ optShakeFiles opt-                    then pure Nothing-                    else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents-                pure (mbFingerprint, (diag, Just modu))+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do+    sess <- use_ GhcSession file+    let hsc = hscEnv sess+        -- These packages are used when removing PackageImports from a+        -- parsed module+        comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)+    opt <- getIdeOptions+    (_, contents) <- getFileContents file +    let dflags    = hsc_dflags hsc+        mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents++    -- Parse again (if necessary) to capture Haddock parse errors+    if gopt Opt_Haddock dflags+        then+            liftIO mainParse+        else do+            let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}+                haddockParse = do+                    (_, (!diagsHaddock, _)) <-+                        getParsedModuleDefinition hscHaddock opt comp_pkgs file contents+                    return diagsHaddock++            ((fingerPrint, (diags, res)), diagsHaddock) <-+                -- parse twice, with and without Haddocks, concurrently+                -- we cannot ignore Haddock parse errors because files of+                -- non-interest are always parsed with Haddocks+                liftIO $ concurrently mainParse haddockParse++            return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))++getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))+getParsedModuleDefinition packageState opt comp_pkgs file contents = do+    (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)+    case res of+        Nothing -> pure (Nothing, (diag, Nothing))+        Just (contents, modu) -> do+            mbFingerprint <- if isNothing $ optShakeFiles opt+                then pure Nothing+                else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents+            pure (mbFingerprint, (diag, Just modu))+ getLocatedImportsRule :: Rules () getLocatedImportsRule =     define $ \GetLocatedImports file -> do-        pm <- use_ GetParsedModule file-        let ms = pm_mod_summary pm+        ms <- use_ GetModSummary file         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]-        env <- hscEnv <$> use_ GhcSession file-        let dflags = addRelativeImport file pm $ hsc_dflags env+        env_eq <- use_ GhcSession file+        let env = hscEnv env_eq+        let import_dirs = deps env_eq+        let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env         opt <- getIdeOptions         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do-            diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource+            diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource             case diagOrImp of                 Left diags -> pure (diags, Left (modName, Nothing))                 Right (FileImport path) -> pure ([], Left (modName, Just path))@@ -171,48 +258,109 @@             Nothing -> pure (concat diags, Nothing)             Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports)) +type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a +execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)+execRawDepM act =+    execStateT act+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty+        , IntMap.empty+        )+ -- | Given a target file path, construct the raw dependency results by following -- imports recursively.-rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation-rawDependencyInformation f = do-    let (initialId, initialMap) = getPathId f emptyPathIdMap-    go (IntSet.singleton $ getFilePathId initialId)-       (RawDependencyInformation IntMap.empty initialMap)+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation+rawDependencyInformation fs = do+    (rdi, ss) <- execRawDepM (mapM_ go fs)+    let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss+    return (rdi { rawBootMap = bm })   where-    go fs rawDepInfo =-        case IntSet.minView fs of-            -- Queue is empty-            Nothing -> pure rawDepInfo-            -- Pop f from the queue and process it-            Just (f, fs) -> do-                let fId = FilePathId f-                importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId-                case importsOrErr of-                  Nothing ->-                    -- File doesn’t parse-                    let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo-                    in go fs rawDepInfo'-                  Just (modImports, pkgImports) -> do-                    let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))-                        f pathMap (imp, mbPath) = case mbPath of-                            Nothing -> (pathMap, (imp, Nothing))-                            Just path ->-                                let (pathId, pathMap') = getPathId path pathMap-                                in (pathMap', (imp, Just pathId))-                    -- Convert paths in imports to ids and update the path map-                    let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports-                    -- Files that we haven’t seen before are added to the queue.-                    let newFiles =-                            IntSet.fromList (coerce $ mapMaybe snd modImports')-                            IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)-                    let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo-                    go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })+    go :: NormalizedFilePath -- ^ Current module being processed+       -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId+    go f = do+      -- First check to see if we have already processed the FilePath+      -- If we have, just return its Id but don't update any of the state.+      -- Otherwise, we need to process its imports.+      checkAlreadyProcessed f $ do+          al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f+          -- Get a fresh FilePathId for the new file+          fId <- getFreshFid al+          -- Adding an edge to the bootmap so we can make sure to+          -- insert boot nodes before the real files.+          addBootMap al fId+          -- Try to parse the imports of the file+          importsOrErr <- lift $ use GetLocatedImports f+          case importsOrErr of+            Nothing -> do+            -- File doesn't parse so add the module as a failure into the+            -- dependency information, continue processing the other+            -- elements in the queue+              modifyRawDepInfo (insertImport fId (Left ModuleParseError))+              return fId+            Just (modImports, pkgImports) -> do+              -- Get NFPs of the imports which have corresponding files+              -- Imports either come locally from a file or from a package.+              let (no_file, with_file) = splitImports modImports+                  (mns, ls) = unzip with_file+              -- Recursively process all the imports we just learnt about+              -- and get back a list of their FilePathIds+              fids <- mapM (go . artifactFilePath) ls+              -- Associate together the ModuleName with the FilePathId+              let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)+              -- Insert into the map the information about this modules+              -- imports.+              modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)+              return fId ++    checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId+    checkAlreadyProcessed nfp k = do+      (rawDepInfo, _) <- get+      maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)++    modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()+    modifyRawDepInfo f = modify (first f)++    addBootMap ::  ArtifactsLocation -> FilePathId -> RawDepM ()+    addBootMap al fId =+      modify (\(rd, ss) -> (rd, if isBootLocation al+                                  then IntMap.insert (getFilePathId fId) al ss+                                  else ss))++    getFreshFid :: ArtifactsLocation -> RawDepM FilePathId+    getFreshFid al = do+      (rawDepInfo, ss) <- get+      let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)+      -- Insert the File into the bootmap if it's a boot module+      let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }+      put (rawDepInfo', ss)+      return fId++    -- Split in (package imports, local imports)+    splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]+                 -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])+    splitImports = foldr splitImportsLoop ([],[])++    splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)+    splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)++    updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =+      if not artifactIsSource+        then+          let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)+          in case msource_mod_id of+               Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm+               Nothing -> bm+        else bm++    dropBootSuffix :: ModLocation -> FilePath+    dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src+    dropBootSuffix _ = error "dropBootSuffix"+ getDependencyInformationRule :: Rules () getDependencyInformationRule =     define $ \GetDependencyInformation file -> do-       rawDepInfo <- rawDependencyInformation file+       rawDepInfo <- rawDependencyInformation [file]        pure ([], Just $ processDependencyInformation rawDepInfo)  reportImportCyclesRule :: Rules ()@@ -240,12 +388,13 @@             , _message = "Cyclic module dependency between " <> showCycle mods             , _code = Nothing             , _relatedInformation = Nothing+            , _tags = Nothing             }             where loc = srcSpanToLocation (getLoc imp)-                  fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)+                  fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)           getModuleName file = do-           pm <- use_ GetParsedModule file-           pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)+           ms <- use_ GetModSummary file+           pure (moduleNameString . moduleName . ms_mod $ ms)           showCycle mods  = T.intercalate ", " (map T.pack mods)  -- returns all transitive dependencies in topological order.@@ -253,7 +402,7 @@ getDependenciesRule :: Rules () getDependenciesRule =     defineEarlyCutoff $ \GetDependencies file -> do-        depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file+        depInfo <- use_ GetDependencyInformation file         let allFiles = reachableModules depInfo         _ <- uses_ ReportImportCycles allFiles         opts <- getIdeOptions@@ -265,50 +414,101 @@ getSpanInfoRule =     define $ \GetSpanInfo file -> do         tc <- use_ TypeCheck file-        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file-        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)-        (fileImports, _) <- use_ GetLocatedImports file         packageState <- hscEnv <$> use_ GhcSession file-        x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms+        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file+        let tdeps = transitiveModuleDeps deps++-- When possible, rely on the haddocks embedded in our interface files+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)+        let parsedDeps = []+#else+        parsedDeps <- uses_ GetParsedModule tdeps+#endif++        ifaces <- uses_ GetModIface tdeps+        (fileImports, _) <- use_ GetLocatedImports file+        let imports = second (fmap artifactFilePath) <$> fileImports+        x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)         return ([], Just x)  -- Typechecks a module. typeCheckRule :: Rules ()-typeCheckRule =-    define $ \TypeCheck file -> do-        pm <- use_ GetParsedModule file-        deps <- use_ GetDependencies file-        packageState <- hscEnv <$> use_ GhcSession file-        -- Figure out whether we need TemplateHaskell or QuasiQuotes support-        let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState-            file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)-            any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq-        tms <- if any_uses_th_qq-                  -- If we use TH or QQ, we must obtain the bytecode-                  then do-                    bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)-                    tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)-                    pure (zipWith addByteCode bytecodes tmrs)-                  else uses_ TypeCheck (transitiveModuleDeps deps)-        setPriority priorityTypeCheck-        IdeOptions{ optDefer = defer} <- getIdeOptions-        liftIO $ typecheckModule defer packageState tms pm-    where-        uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags-        addByteCode :: Linkable -> TcModuleResult -> TcModuleResult-        addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }+typeCheckRule = define $ \TypeCheck file -> do+    pm <- use_ GetParsedModule file+    -- do not generate interface files as this rule is called+    -- for files of interest on every keystroke+    typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles -generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))-generateCore file = do+data GenerateInterfaceFiles+    = DoGenerateInterfaceFiles+    | SkipGenerationOfInterfaceFiles+    deriving (Show)++-- This is factored out so it can be directly called from the GetModIface+-- rule. Directly calling this rule means that on the initial load we can+-- garbage collect all the intermediate typechecked modules rather than+-- retain the information forever in the shake graph.+typeCheckRuleDefinition+    :: NormalizedFilePath     -- ^ Path to source file+    -> ParsedModule+    -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?+    -> Action (IdeResult TcModuleResult)+typeCheckRuleDefinition file pm generateArtifacts = do+  deps <- use_ GetDependencies file+  hsc  <- hscEnv <$> use_ GhcSession file+  -- Figure out whether we need TemplateHaskell or QuasiQuotes support+  let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc+      file_uses_th_qq   = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)+      any_uses_th_qq    = graph_needs_th_qq || file_uses_th_qq+  mirs      <- uses_ GetModIface (transitiveModuleDeps deps)+  bytecodes <- if any_uses_th_qq+    then -- If we use TH or QQ, we must obtain the bytecode+      fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)+    else+      pure $ repeat Nothing++  setPriority priorityTypeCheck+  IdeOptions { optDefer = defer } <- getIdeOptions++  addUsageDependencies $ liftIO $ do+    res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm+    case res of+      (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do+        diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)+        diagsHi  <- generateAndWriteHiFile hsc tcm+        return (diags <> diagsHi <> diagsHie, Just tcm)+      (diags, res) ->+        return (diags, snd <$> res)+ where+  unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))+  uses_th_qq dflags =+    xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags++  addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)+  addUsageDependencies a = do+    r@(_, mtc) <- a+    forM_ mtc $ \tc -> do+      let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))+          udep (UsageFile fp _h) = Just fp+          udep _ = Nothing+      -- Add a dependency on these files which are added by things like+      -- qAddDependentFile+      void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)+    return r+++generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))+generateCore runSimplifier file = do     deps <- use_ GetDependencies file     (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)     setPriority priorityGenerateCore     packageState <- hscEnv <$> use_ GhcSession file-    liftIO $ compileModule packageState tms tm+    liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm  generateCoreRule :: Rules () generateCoreRule =-    define $ \GenerateCore -> generateCore+    define $ \GenerateCore -> generateCore (RunSimplifier True)  generateByteCodeRule :: Rules () generateByteCodeRule =@@ -317,7 +517,7 @@       (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)       session <- hscEnv <$> use_ GhcSession file       (_, guts, _) <- use_ GenerateCore file-      liftIO $ generateByteCode session tms tm guts+      liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts  -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule.@@ -329,7 +529,7 @@ instance NFData   GhcSessionIO instance Binary   GhcSessionIO -newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq)) instance Show GhcSessionFun where show _ = "GhcSessionFun" instance NFData GhcSessionFun where rnf !_ = () @@ -338,21 +538,120 @@ loadGhcSession = do     defineNoFile $ \GhcSessionIO -> do         opts <- getIdeOptions-        liftIO $ GhcSessionFun <$> optGhcSession opts+        GhcSessionFun <$> optGhcSession opts+    -- This function should always be rerun because it consults a cache to+    -- see what HscEnv needs to be used for the file, which can change.+    -- However, it should also cut-off early if it's the same HscEnv as+    -- last time     defineEarlyCutoff $ \GhcSession file -> do         GhcSessionFun fun <- useNoFile_ GhcSessionIO+        alwaysRerun         val <- fun $ fromNormalizedFilePath file++        -- TODO: What was this doing before?         opts <- getIdeOptions-        return ("" <$ optShakeFiles opts, ([], Just val))+        let cutoffHash =+              case optShakeFiles opts of+                -- optShakeFiles is only set in the DAML case.+                -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915+                Just {} -> ""+                -- Hash the HscEnvEq returned so cutoff if it didn't change+                -- from last time+                Nothing -> BS.pack (show (hash (snd val)))+        return (Just cutoffHash, val) +getHiFileRule :: Rules ()+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do+  -- get all dependencies interface files, to check for freshness+  (deps,_) <- use_ GetLocatedImports f+  depHis  <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps) -getHieFileRule :: Rules ()-getHieFileRule =-    defineNoFile $ \(GetHieFile f) -> do-        u <- liftIO $ mkSplitUniqSupply 'a'-        let nameCache = initNameCache u []-        liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f+  ms <- use_ GetModSummary f+  let hiFile = toNormalizedFilePath'+             $ case ms_hsc_src ms of+                HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)+                _ -> ml_hi_file $ ms_location ms +  case sequence depHis of+    Nothing -> pure (Nothing, ([], Nothing))+    Just deps -> do+      gotHiFile <- getFileExists hiFile+      if not gotHiFile+        then pure (Nothing, ([], Nothing))+        else do+          hiVersion  <- use_ GetModificationTime hiFile+          modVersion <- use_ GetModificationTime f+          let sourceModified = modificationTime hiVersion < modificationTime modVersion+          if sourceModified+            then do+              pure (Nothing, ([], Nothing))+            else do+              session <- hscEnv <$> use_ GhcSession f+              r <- liftIO $ loadInterface session ms deps+              case r of+                Right iface -> do+                  let result = HiFileResult ms iface+                  return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))+                Left err -> do+                  let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err+                  return (Nothing, (pure diag, Nothing))++getModSummaryRule :: Rules ()+getModSummaryRule = define $ \GetModSummary f -> do+    dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f+    (_, mFileContent) <- getFileContents f+    modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $+        getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)+    return $ either (,Nothing) (([], ) . Just) modS++getModIfaceRule :: Rules ()+getModIfaceRule = define $ \GetModIface f -> do+    fileOfInterest <- use_ IsFileOfInterest f+    let useHiFile =+          -- Never load interface files for files of interest+          not fileOfInterest+    mbHiFile <- if useHiFile then use GetHiFile f else return Nothing+    case mbHiFile of+        Just x ->+            return ([], Just x)+        Nothing+          | fileOfInterest -> do+            -- For files of interest only, create a Shake dependency on typecheck+            tmr <- use TypeCheck f+            return ([], extract tmr)+          | otherwise -> do+            -- the interface file does not exist or is out of date.+            -- Invoke typechecking directly to update it without incurring a dependency+            -- on the parsed module and the typecheck rules+            sess <- use_ GhcSession f+            let hsc = hscEnv sess+                -- After parsing the module remove all package imports referring to+                -- these packages as we have already dealt with what they map to.+                comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)+            opt <- getIdeOptions+            (_, contents) <- getFileContents f+            -- Embed --haddocks in the interface file+            hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}+            (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents+            case mb_pm of+                Nothing -> return (diags, Nothing)+                Just pm -> do+                    (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles+                    -- Bang pattern is important to avoid leaking 'tmr'+                    let !res = extract tmr+                    return (diags <> diags', res)+    where+      extract Nothing = Nothing+      extract (Just tmr) =+        -- Bang patterns are important to force the inner fields+        Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)++isFileOfInterestRule :: Rules ()+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do+    filesOfInterest <- getFilesOfInterest+    let res = f `elem` filesOfInterest+    return (Just (if res then "1" else ""), ([], Just res))+ -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do@@ -366,4 +665,7 @@     generateCoreRule     generateByteCodeRule     loadGhcSession-    getHieFileRule+    getHiFileRule+    getModIfaceRule+    isFileOfInterestRule+    getModSummaryRule

@@ -23,6 +23,7 @@ import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) import Control.Monad+import Development.IDE.Core.Debouncer import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules) import           Development.IDE.Core.FileExists (fileExistsRules) import           Development.IDE.Core.OfInterest@@ -49,14 +50,16 @@            -> IO LSP.LspId            -> (LSP.FromServerMessage -> IO ())            -> Logger+           -> Debouncer LSP.NormalizedUri            -> IdeOptions            -> VFSHandle            -> IO IdeState-initialise caps mainRule getLspId toDiags logger options vfs =+initialise caps mainRule getLspId toDiags logger debouncer options vfs =     shakeOpen         getLspId         toDiags         logger+        debouncer         (optShakeProfiling options)         (optReportProgress options)         shakeOptions

@@ -19,8 +19,8 @@ --   always stored as real Haskell values, whereas Shake serialises all 'A' values --   between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake(-    IdeState,-    ShakeExtras(..), getShakeExtras,+    IdeState, shakeExtras,+    ShakeExtras(..), getShakeExtras, getShakeExtrasRules,     IdeRule, IdeResult, GetModificationTime(..),     shakeOpen, shakeShut,     shakeRun,@@ -30,13 +30,13 @@     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,     getDiagnostics, unsafeClearDiagnostics,     getHiddenDiagnostics,-    IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,+    IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,     garbageCollect,     setPriority,     sendEvent,     ideLogger,     actionLogger,-    FileVersion(..),+    FileVersion(..), modificationTime,     Priority(..),     updatePositionMapping,     deleteValue,@@ -49,12 +49,11 @@ import           Development.Shake.Rule import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map-import qualified Data.Map.Merge.Strict as Map import qualified Data.ByteString.Char8 as BS import           Data.Dynamic import           Data.Maybe import Data.Map.Strict (Map)-import           Data.List.Extra (foldl', partition, takeEnd)+import           Data.List.Extra (partition, takeEnd) import qualified Data.Set as Set import qualified Data.Text as T import Data.Traversable (for)@@ -70,7 +69,7 @@ import Development.IDE.Types.Options import           Control.Concurrent.Async import           Control.Concurrent.Extra-import           Control.Exception+import           Control.Exception.Extra import           Control.DeepSeq import           System.Time.Extra import           Data.Typeable@@ -95,13 +94,15 @@     ,state :: Var Values     ,diagnostics :: Var DiagnosticStore     ,hiddenDiagnostics :: Var DiagnosticStore-    ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])+    ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])     -- ^ This represents the set of diagnostics that we have published.     -- Due to debouncing not every change might get published.-    ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))+    ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))     -- ^ Map from a text document version to a PositionMapping that describes how to map     -- positions in a version of that document to positions in the latest version-    ,inProgress :: Var (Map NormalizedFilePath Int)+    -- First mapping is delta from previous version and second one is an+    -- accumlation of all previous mappings.+    ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)     -- ^ How many rules are running for each file     } @@ -115,22 +116,29 @@     Just x <- getShakeExtraRules @ShakeExtras     return x -- class Typeable a => IsIdeGlobal a where  addIdeGlobal :: IsIdeGlobal a => a -> Rules ()-addIdeGlobal x@(typeOf -> ty) = do-    ShakeExtras{globals} <- getShakeExtrasRules+addIdeGlobal x = do+    extras <- getShakeExtrasRules+    liftIO $ addIdeGlobalExtras extras x++addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =     liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of-        Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty+        Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty         Nothing -> return $! HMap.insert ty (toDyn x) mp   getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do-    Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals-    return $ fromDyn x $ error "Serious error, corrupt globals"+    let typ = typeRep (Proxy :: Proxy a)+    x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals+    case x of+        Just x+            | Just x <- fromDynamic x -> pure x+            | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"+        Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ  getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras@@ -153,7 +161,7 @@                      | otherwise = False  instance Hashable Key where-    hashWithSalt salt (Key key) = hashWithSalt salt key+    hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)  -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, --   and a value is in the Maybe. For operations that throw an error you@@ -163,9 +171,6 @@ --   get empty diagnostics and a Nothing, to indicate this phase throws no fresh --   errors but still failed. -----   A rule on a file should only return diagnostics for that given file. It should---   not propagate diagnostic errors through multiple phases.-type IdeResult v = ([FileDiagnostic], Maybe v)  data Value v     = Succeeded TextDocumentVersion v@@ -200,14 +205,14 @@     Failed -> Nothing  mappingForVersion-    :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)+    :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))     -> NormalizedFilePath     -> TextDocumentVersion     -> PositionMapping mappingForVersion allMappings file ver =-    fromMaybe idMapping $+    maybe zeroMapping snd $     Map.lookup ver =<<-    Map.lookup (filePathToUri' file) allMappings+    HMap.lookup (filePathToUri' file) allMappings  type IdeRule k v =   ( Shake.RuleResult k ~ v@@ -238,7 +243,6 @@                 shakeProfileDatabase shakeDb $ dir </> file                 return (dir </> file)         return (res, proFile)-    where  {-# NOINLINE profileStartTime #-} profileStartTime :: String@@ -294,21 +298,21 @@ shakeOpen :: IO LSP.LspId           -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler           -> Logger+          -> Debouncer NormalizedUri           -> Maybe FilePath           -> IdeReportProgress           -> ShakeOptions           -> Rules ()           -> IO IdeState-shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do-    inProgress <- newVar Map.empty+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do+    inProgress <- newVar HMap.empty     shakeExtras <- do         globals <- newVar HMap.empty         state <- newVar HMap.empty         diagnostics <- newVar mempty         hiddenDiagnostics <- newVar mempty         publishedDiagnostics <- newVar mempty-        debouncer <- newDebouncer-        positionMapping <- newVar Map.empty+        positionMapping <- newVar HMap.empty         pure ShakeExtras{..}     (shakeDb, shakeClose) <-         shakeOpenDatabase@@ -323,7 +327,7 @@     shakeDb <- shakeDb     return IdeState{..} -lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO ()+lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO () lspShakeProgress getLspId sendMsg inProgress = do     -- first sleep a bit, so we only show progress messages if it's going to take     -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)@@ -356,8 +360,8 @@         loop id prev = do             sleep sample             current <- readVar inProgress-            let done = length $ filter (== 0) $ Map.elems current-            let todo = Map.size current+            let done = length $ filter (== 0) $ HMap.elems current+            let todo = HMap.size current             let next = Just $ T.pack $ show done <> "/" <> show todo             when (next /= prev) $                 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification@@ -413,8 +417,8 @@                             Right _ -> "completed"                        profile = case res of                             Right (_, Just fp) ->-                                let link = case filePathToUri' $ toNormalizedFilePath fp of-                                                NormalizedUri x -> x+                                let link = case filePathToUri' $ toNormalizedFilePath' fp of+                                                NormalizedUri _ x -> x                                 in ", profile saved at " <> T.unpack link                             _ -> ""                    let logMsg = logDebug logger $ T.pack $@@ -452,9 +456,9 @@                return $! dupe values            modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags            modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags-           modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags+           modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags            let versionsForFile =-                   Map.fromListWith Set.union $+                   HMap.fromListWith Set.union $                    mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $                    HMap.toList newState            modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings@@ -472,25 +476,25 @@ useWithStale key file = head <$> usesWithStale key [file]  useNoFile :: IdeRule k v => k -> Action (Maybe v)-useNoFile key = use key ""+useNoFile key = use key emptyFilePath  use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = head <$> uses_ key [file]  useNoFile_ :: IdeRule k v => k -> Action v-useNoFile_ key = use_ key ""+useNoFile_ key = use_ key emptyFilePath  uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v] uses_ key files = do     res <- uses key files     case sequence res of-        Nothing -> liftIO $ throwIO BadDependency+        Nothing -> liftIO $ throwIO $ BadDependency (show key)         Just v -> return v   -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency --   which short-circuits the rest of the action-data BadDependency = BadDependency deriving Show+data BadDependency = BadDependency String deriving Show instance Exception BadDependency  isBadDependency :: SomeException -> Bool@@ -509,12 +513,10 @@  -- | Invariant: the 'v' must be in normal form (fully evaluated). --   Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database--- Note (MK) I am not sure why we need the ShakeValue here, maybe we--- can just remove it?-data A v = A (Value v) ShakeValue+newtype A v = A (Value v)     deriving Show -instance NFData (A v) where rnf (A v x) = v `seq` rnf x+instance NFData (A v) where rnf (A v) = v `seq` ()  -- In the Shake database we only store one type of key/result pairs, -- namely Q (question) / A (answer).@@ -524,19 +526,22 @@ -- | Return up2date results. Stale results will be ignored. uses :: IdeRule k v     => k -> [NormalizedFilePath] -> Action [Maybe v]-uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)  -- | Return the last computed result which might be stale. usesWithStale :: IdeRule k v     => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] usesWithStale key files = do-    values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)-    mapM (uncurry lastValue) (zip files values)+    values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)+    zipWithM lastValue files values  -withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b+withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b withProgress var file = actionBracket (f succ) (const $ f pred) . const-    where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file+    -- This functions are deliberately eta-expanded to avoid space leaks.+    -- Do not remove the eta-expansion without profiling a session with at+    -- least 1000 modifications.+    where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x   defineEarlyCutoff@@ -553,16 +558,16 @@                 case v of                     -- No changes in the dependencies and we have                     -- an existing result.-                    Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)+                    Just v -> return $ Just $ RunResult ChangedNothing old $ A v                     _ -> return Nothing             _ -> return Nothing         case val of             Just res -> return res             Nothing -> do                 (bs, (diags, res)) <- actionCatch-                    (do v <- op key file; liftIO $ evaluate $ force $ v) $+                    (do v <- op key file; liftIO $ evaluate $ force v) $                     \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))-                modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file+                modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file                 (bs, res) <- case res of                     Nothing -> do                         staleV <- liftIO $ getValues state key file@@ -572,7 +577,7 @@                                 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)                                 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)                                 Failed -> (toShakeValue ShakeResult bs, Failed)-                    Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)+                    Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)                 liftIO $ setValues state key file res                 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags                 let eq = case (bs, fmap decodeShakeValue old) of@@ -584,7 +589,7 @@                 return $ RunResult                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)                     (encodeShakeValue bs) $-                    A res bs+                    A res   -- | Rule type, input file@@ -655,12 +660,12 @@ needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () needOnDisk k file = do     successfull <- apply1 (QDisk k file)-    liftIO $ unless successfull $ throwIO BadDependency+    liftIO $ unless successfull $ throwIO $ BadDependency (show k)  needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action () needOnDisks k files = do     successfulls <- apply $ map (QDisk k) files-    liftIO $ unless (and successfulls) $ throwIO BadDependency+    liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)  toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue toShakeValue = maybe ShakeNoCutoff@@ -699,7 +704,7 @@   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results   -> Action () updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do-    modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp+    modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current     mask_ $ do         -- Mask async exceptions to ensure that updated diagnostics are always@@ -712,7 +717,7 @@             let newDiags = getFileDiagnostics fp newDiagsStore             _ <- evaluate newDiagsStore             _ <- evaluate newDiags-            pure $! (newDiagsStore, newDiags)+            pure (newDiagsStore, newDiags)         modifyVar_ hiddenDiagnostics $ \old -> do             let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)                                   (T.pack $ show k) (map snd currentHidden) old@@ -724,10 +729,10 @@         let delay = if null newDiags then 0.1 else 0         registerEvent debouncer delay uri $ do              mask_ $ modifyVar_ publishedDiagnostics $ \published -> do-                 let lastPublish = Map.findWithDefault [] uri published+                 let lastPublish = HMap.lookupDefault [] uri published                  when (lastPublish /= newDiags) $                      eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags-                 pure $! Map.insert uri newDiags published+                 pure $! HMap.insert uri newDiags published  publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage publishDiagnosticsNotification uri diags =@@ -738,7 +743,7 @@ newtype Priority = Priority Double  setPriority :: Priority -> Action ()-setPriority (Priority p) = deprioritize p+setPriority (Priority p) = reschedule p  sendEvent :: LSP.FromServerMessage -> Action () sendEvent e = do@@ -763,19 +768,22 @@ -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion --- | We store the modification time as a ByteString since we need--- a ByteString anyway for Shake and we do not care about how times--- are represented.-data FileVersion = VFSVersion Int | ModificationTime BS.ByteString+data FileVersion+    = VFSVersion !Int+    | ModificationTime+      !Int   -- ^ Large unit (platform dependent, do not make assumptions)+      !Int   -- ^ Small unit (platform dependent, do not make assumptions)     deriving (Show, Generic)  instance NFData FileVersion  vfsVersion :: FileVersion -> Maybe Int vfsVersion (VFSVersion i) = Just i-vfsVersion (ModificationTime _) = Nothing-+vfsVersion ModificationTime{} = Nothing +modificationTime :: FileVersion -> Maybe (Int, Int)+modificationTime VFSVersion{} = Nothing+modificationTime (ModificationTime large small) = Just (large, small)  getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags@@ -800,7 +808,7 @@     DiagnosticStore ->     [FileDiagnostic] getAllDiagnostics =-    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList+    concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList  getFileDiagnostics ::     NormalizedFilePath ->@@ -808,29 +816,34 @@     [LSP.Diagnostic] getFileDiagnostics fp ds =     maybe [] getDiagnosticsFromStore $-    Map.lookup (filePathToUri' fp) ds+    HMap.lookup (filePathToUri' fp) ds  filterDiagnostics ::     (NormalizedFilePath -> Bool) ->     DiagnosticStore ->     DiagnosticStore filterDiagnostics keep =-    Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)+    HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)  filterVersionMap-    :: Map NormalizedUri (Set.Set TextDocumentVersion)-    -> Map NormalizedUri (Map TextDocumentVersion a)-    -> Map NormalizedUri (Map TextDocumentVersion a)+    :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)+    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)+    -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) filterVersionMap =-    Map.merge Map.dropMissing Map.dropMissing $-    Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep+    HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep  updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()-updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do     modifyVar_ positionMapping $ \allMappings -> do         let uri = toNormalizedUri _uri-        let mappingForUri = Map.findWithDefault Map.empty uri allMappings-        let updatedMapping =-                Map.insert _version idMapping $-                Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri-        pure $! Map.insert uri updatedMapping allMappings+        let mappingForUri = HMap.lookupDefault Map.empty uri allMappings+        let (_, updatedMapping) =+                -- Very important to use mapAccum here so that the tails of+                -- each mapping can be shared, otherwise quadratic space is+                -- used which is evident in long running sessions.+                Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))+                  zeroMapping+                  (Map.insert _version (shared_change, zeroMapping) mappingForUri)+        pure $! HMap.insert uri updatedMapping allMappings+  where+    shared_change = mkDelta changes

@@ -19,7 +19,8 @@ -- ----------------------------------------------------------------------------- -module Development.IDE.GHC.CPP(doCpp) where+module Development.IDE.GHC.CPP(doCpp, addOptP)+where  import Development.IDE.GHC.Compat import Packages@@ -33,6 +34,10 @@ #elif MIN_GHC_API_VERSION(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif+#if MIN_GHC_API_VERSION (8,10,0)+import Fingerprint+import ToolSettings+#endif  import System.Directory import System.FilePath@@ -59,7 +64,11 @@     let verbFlags = getVerbFlags dflags      let cpp_prog args | raw       = SysTools.runCpp dflags args+#if MIN_GHC_API_VERSION(8,10,0)+                      | otherwise = SysTools.runCc Nothing+#else                       | otherwise = SysTools.runCc+#endif                                           dflags (SysTools.Option "-E" : args)      let target_defs =@@ -157,6 +166,22 @@  getBackendDefs _ =     return []++addOptP :: String -> DynFlags -> DynFlags+#if MIN_GHC_API_VERSION (8,10,0)+addOptP f = alterToolSettings $ \s -> s+          { toolSettings_opt_P             = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+  where+    fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss+    alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }+#else+addOptP opt = onSettings (onOptP (opt:))+  where+    onSettings f x = x{settings = f $ settings x}+    onOptP f x = x{sOpt_P = f $ sOpt_P x}+#endif  -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal)

@@ -7,22 +7,38 @@  -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(+    getHeaderImports,     HieFileResult(..),-    HieFile(..),+    HieFile,+    hieExportNames,+    hie_module,     mkHieFile,     writeHieFile,     readHieFile,+    supportsHieFiles,+    setDefaultHieDir,+    dontWriteHieFiles,+#if !MIN_GHC_API_VERSION(8,8,0)+    ml_hie_file,+#endif     hPutStringBuffer,     includePathsGlobal,     includePathsQuote,     addIncludePathsQuote,+    getModuleHash,+    getPackageName,     pattern DerivD,     pattern ForD,     pattern InstD,     pattern TyClD,     pattern ValD,     pattern ClassOpSig,+    pattern IEThingAll,     pattern IEThingWith,+    GHC.ModLocation,+    Module.addBootSuffix,+    pattern ModLocation,+    getConArgs,      module GHC     ) where@@ -30,41 +46,62 @@ import StringBuffer import DynFlags import FieldLabel+import Fingerprint (Fingerprint)+import qualified Module+import Packages  import qualified GHC-import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)+import GHC hiding (+      ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation+#if MIN_GHC_API_VERSION(8,6,0)+    , getConArgs+#endif+    )+import qualified HeaderInfo as Hdr+import Avail+import ErrUtils (ErrorMessages)+import FastString (FastString) +#if MIN_GHC_API_VERSION(8,10,0)+import HscTypes (mi_mod_hash)+#endif+ #if MIN_GHC_API_VERSION(8,8,0)-import HieAst+import Control.Applicative ((<|>))+import Development.IDE.GHC.HieAst (mkHieFile) import HieBin import HieTypes++supportsHieFiles :: Bool+supportsHieFiles = True++hieExportNames :: HieFile -> [(SrcSpan, Name)]+hieExportNames = nameListFromAvails . hie_exports+ #else-import GhcPlugins++#if MIN_GHC_API_VERSION(8,6,0)+import BinIface+import Data.IORef+import IfaceEnv+#endif++import Binary+import Control.Exception (catch)+import Data.ByteString (ByteString)+import GhcPlugins hiding (ModLocation) import NameCache-import Avail import TcRnTypes import System.IO import Foreign.ForeignPtr+import MkIface  -#if !MIN_GHC_API_VERSION(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur)     = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->              hPutBuf hdl ptr len-#endif -mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile-mkHieFile _ _ _ = return (HieFile () [])--writeHieFile :: FilePath -> HieFile -> IO ()-writeHieFile _ _ = return ()--readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())-readHieFile _ _ = return (HieFileResult (HieFile () []), ())--data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}-data HieFileResult = HieFileResult { hie_file_result :: HieFile } #endif  #if !MIN_GHC_API_VERSION(8,6,0)@@ -137,3 +174,136 @@ #else     GHC.IEThingWith a b c d #endif++pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation+pattern ModLocation a b c <-+#if MIN_GHC_API_VERSION(8,8,0)+    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""+#else+    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c+#endif++pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass+pattern IEThingAll a <-+#if MIN_GHC_API_VERSION(8,6,0)+    GHC.IEThingAll _ a+#else+    GHC.IEThingAll a+#endif++setDefaultHieDir :: FilePath -> DynFlags -> DynFlags+setDefaultHieDir _f d =+#if MIN_GHC_API_VERSION(8,8,0)+    d { hieDir     = hieDir d <|> Just _f}+#else+    d+#endif++dontWriteHieFiles :: DynFlags -> DynFlags+dontWriteHieFiles d =+#if MIN_GHC_API_VERSION(8,8,0)+    gopt_unset d Opt_WriteHie+#else+    d+#endif++nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]+nameListFromAvails as =+  map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)++#if !MIN_GHC_API_VERSION(8,8,0)+-- Reimplementations of functions for HIE files for GHC 8.6++mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)+  where+    es = nameListFromAvails (mkIfaceExports (tcg_exports ts))++ml_hie_file :: GHC.ModLocation -> FilePath+ml_hie_file ml = ml_hi_file ml ++ ".hie"++data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}++hieExportNames :: HieFile -> [(SrcSpan, Name)]+hieExportNames = hie_exports++instance Binary HieFile where+  put_ bh (HieFile m es) = do+    put_ bh m+    put_ bh es++  get bh = do+    mod <- get bh+    es <- get bh+    return (HieFile mod es)++data HieFileResult = HieFileResult { hie_file_result :: HieFile }++writeHieFile :: FilePath -> HieFile -> IO ()+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())+supportsHieFiles :: Bool++#if MIN_GHC_API_VERSION(8,6,0)++writeHieFile fp hie = do+  bh <- openBinMem (1024 * 1024)+  putWithUserData (const $ return ()) bh hie+  writeBinMem bh fp++readHieFile nc fp = do+  bh <- readBinMem fp+  nc' <- newIORef nc+  hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh+  return (HieFileResult hie_file, ())++supportsHieFiles = True++#else++supportsHieFiles = False++writeHieFile _ _ = return ()++readHieFile _ _ = return undefined++#endif++#endif++getHeaderImports+  :: DynFlags+  -> StringBuffer+  -> FilePath+  -> FilePath+  -> IO+       ( Either+           ErrorMessages+           ( [(Maybe FastString, Located ModuleName)]+           , [(Maybe FastString, Located ModuleName)]+           , Located ModuleName+           )+       )+#if MIN_GHC_API_VERSION(8,8,0)+getHeaderImports = Hdr.getImports+#else+getHeaderImports a b c d =+    catch (Right <$> Hdr.getImports a b c d)+          (return . Left . srcErrorMessages)+#endif++getModuleHash :: ModIface -> Fingerprint+#if MIN_GHC_API_VERSION(8,10,0)+getModuleHash = mi_mod_hash . mi_final_exts+#else+getModuleHash = mi_mod_hash+#endif++getConArgs :: ConDecl pass -> HsConDeclDetails pass+#if MIN_GHC_API_VERSION(8,6,0)+getConArgs = GHC.getConArgs+#else+getConArgs = GHC.getConDetails+#endif++getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))