ghcide 0.4.0 → 0.5.0

raw patch · 56 files changed

+2714/−9943 lines, 56 filesdep +Globdep +fingertreedep +hie-compatdep ~ghcdep ~implicit-hie-cradledep ~lsp-testPVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, fingertree, hie-compat

Dependency ranges changed: ghc, implicit-hie-cradle, lsp-test, shake

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−0
• bench/exe/Main.hs +1/−1
• bench/hist/Main.hs +89/−64
• bench/lib/Experiments.hs +195/−144
• bench/lib/Experiments/Types.hs +67/−0
• ghcide.cabal +20/−31
• session-loader/Development/IDE/Session.hs +62/−59
• src-ghc810/Development/IDE/GHC/HieAst.hs +0/−1928
• src-ghc810/Development/IDE/GHC/HieBin.hs +0/−399
• src-ghc86/Development/IDE/GHC/HieAst.hs +0/−1784
• src-ghc86/Development/IDE/GHC/HieBin.hs +0/−388
• src-ghc86/Development/IDE/GHC/HieDebug.hs +0/−145
• src-ghc86/Development/IDE/GHC/HieTypes.hs +0/−534
• src-ghc86/Development/IDE/GHC/HieUtils.hs +0/−451
• src-ghc88/Development/IDE/GHC/HieAst.hs +0/−1789
• src-ghc88/Development/IDE/GHC/HieBin.hs +0/−389
• src/Development/IDE/Core/Compile.hs +362/−278
• src/Development/IDE/Core/FileExists.hs +119/−71
• src/Development/IDE/Core/FileStore.hs +1/−1
• src/Development/IDE/Core/IdeConfiguration.hs +24/−4
• src/Development/IDE/Core/OfInterest.hs +6/−6
• src/Development/IDE/Core/PositionMapping.hs +6/−7
• src/Development/IDE/Core/Preprocessor.hs +9/−13
• src/Development/IDE/Core/RuleTypes.hs +121/−39
• src/Development/IDE/Core/Rules.hs +279/−182
• src/Development/IDE/Core/Service.hs +1/−1
• src/Development/IDE/Core/Shake.hs +37/−20
• src/Development/IDE/GHC/CPP.hs +0/−1
• src/Development/IDE/GHC/Compat.hs +76/−288
• src/Development/IDE/GHC/Error.hs +15/−12
• src/Development/IDE/GHC/Orphans.hs +38/−8
• src/Development/IDE/GHC/Util.hs +15/−5
• src/Development/IDE/GHC/Warnings.hs +3/−12
• src/Development/IDE/GHC/WithDynFlags.hs +0/−30
• src/Development/IDE/Import/DependencyInformation.hs +11/−4
• src/Development/IDE/Import/FindImports.hs +8/−9
• src/Development/IDE/LSP/HoverDefinition.hs +6/−1
• src/Development/IDE/LSP/LanguageServer.hs +6/−3
• src/Development/IDE/LSP/Notifications.hs +55/−2
• src/Development/IDE/LSP/Outline.hs +12/−16
• src/Development/IDE/Plugin/CodeAction.hs +76/−38
• src/Development/IDE/Plugin/Completions.hs +20/−46
• src/Development/IDE/Plugin/Completions/Logic.hs +77/−68
• src/Development/IDE/Plugin/Completions/Types.hs +2/−1
• src/Development/IDE/Plugin/Test.hs +8/−0
• src/Development/IDE/Spans/AtPoint.hs +103/−121
• src/Development/IDE/Spans/Calculate.hs +0/−268
• src/Development/IDE/Spans/Common.hs +23/−23
• src/Development/IDE/Spans/Documentation.hs +65/−23
• src/Development/IDE/Spans/LocalBindings.hs +134/−0
• src/Development/IDE/Spans/Type.hs +0/−77
• src/Development/IDE/Types/Diagnostics.hs +1/−1
• src/Development/IDE/Types/Exports.hs +18/−1
• test/data/hover/GotoHover.hs +4/−1
• test/exe/Main.hs +498/−153
• test/src/Development/IDE/Test.hs +17/−3

@@ -1,3 +1,27 @@+### 0.5.0 (2020-10-08)+* Use implicit-hie-0.1.2.0 (#880) - (Javier Neira)+* Clarify and downgrade implicit-hie message (#883) - (Avi Dessauer)+* Switch back to bytecode (#873) - (wz1000)+* Add code action for remove all redundant imports (#867) - (Potato Hatsue)+* Fix pretty printer for diagnostic ranges (#871) - (Martin Huschenbett)+* Canonicalize import dirs (#870) - (Pepe Iborra)+* Do not show internal hole names (#852) - (Alejandro Serrano)+* Downgrade file watch debug log to logDebug from logInfo (#848) - (Matthew Pickering)+* Pull in local bindings (#845) - (Sandy Maguire)+* Use object code for Template Haskell, emit desugarer warnings (#836) - (wz1000)+* Fix code action for adding missing constraints to type signatures (#839) - (Jan Hrcek)+* Fix duplicated completions (#837) - (Vitalii)+* FileExists: set one watcher instead of thousands (#831) - (Michael Peyton Jones)+* Drop 8.4 support (#834) - (wz1000)+* Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784) - (wz1000)+* Tag unused warning as such (#815) - (Alejandro Serrano)+* Update instructions for stty error in windows (#825) - (Javier Neira)+* Fix docs tooltip for base libraries on Windows (#814) - (Nick Dunets)+* Fix documentation (or source) link when html file is less specific than module (#766) - (Nick Dunets)+* Add completion tests for records. (#804) - (Guru Devanla)+* Restore identifiers missing from hi file (#741) - (maralorn)+* Fix import suggestions when dot is typed (#800) - (Marcelo Lazaroni)+ ### 0.4.0 (2020-09-15) * Fixes for GHC source plugins: dotpreprocessor works now - (srid) * Use implicit-hie when no explicit hie.yaml (#782) - (Javier Neira)

@@ -45,6 +45,6 @@    output "starting test" -  cleanUp <- setup+  SetupResult{..} <- setup    runBenchmarks experiments `finally` cleanUp

@@ -2,25 +2,28 @@      A Shake script to analyze the performance of ghcide over the git history of the project -    Driven by a config file `bench/hist.yaml` containing the list of Git references to analyze.+    Driven by a config file `bench/config.yaml` containing the list of Git references to analyze.      Builds each one of them and executes a set of experiments using the ghcide-bench suite.      The results of the benchmarks and the analysis are recorded in the file     system with the following structure: -    bench-hist-    ├── <git-reference>                       - one folder per version-    │   ├── <experiment>.benchmark-gcStats    - RTS -s output-    │   ├── <experiment>.csv                  - stats for the experiment-    │   ├── <experiment>.svg                  - Graph of bytes over elapsed time-    │   ├── <experiment>.diff.svg             - idem, including the previous version-    │   ├── <experiment>.log                  - ghcide-bench output-    │   ├── ghc.path                          - path to ghc used to build the binary-    │   ├── ghcide                            - binary for this version-    │   └── results.csv                       - results of all the experiments for the version+    bench-results+    ├── <git-reference>+    │   ├── ghc.path                          - path to ghc used to build the binary+    │   ├── ghcide                            - binary for this version+    ├─ <example>+    │   ├── results.csv                           - aggregated results for all the versions+    │   └── <git-reference>+    │       ├── <experiment>.benchmark-gcStats    - RTS -s output+    │       ├── <experiment>.csv                  - stats for the experiment+    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time+    │       ├── <experiment>.diff.svg             - idem, including the previous version+    │       ├── <experiment>.log                  - ghcide-bench output+    │       └── results.csv                       - results of all the experiments for the example     ├── results.csv        - aggregated results of all the experiments and versions-    ├── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions+    └── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions     For diff graphs, the "previous version" is the preceding entry in the list of versions    in the config file. A possible improvement is to obtain this info via `git rev-list`.@@ -31,10 +34,11 @@     To build a specific analysis, enumerate the desired file artifacts -   > stack bench --ba "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg"-   > cabal bench --benchmark-options "bench-hist/HEAD/results.csv bench-hist/HEAD/edit.diff.svg"+   > stack bench --ba "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"+   > cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"   -}+{-# LANGUAGE ApplicativeDo     #-} {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DerivingStrategies#-} {-# LANGUAGE TypeFamilies      #-}@@ -49,6 +53,7 @@ import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow) import Development.Shake import Development.Shake.Classes (Binary, Hashable, NFData)+import Experiments.Types (getExampleName, exampleToOptions, Example(..)) import GHC.Exts (IsList (..)) import GHC.Generics (Generic) import qualified Graphics.Rendering.Chart.Backend.Diagrams as E@@ -59,32 +64,30 @@ import System.FilePath import qualified Text.ParserCombinators.ReadP as P import Text.Read (Read (..), get, readMaybe, readP_to_Prec)+import GHC.Stack (HasCallStack)+import Data.List (transpose)  config :: FilePath-config = "bench/hist.yaml"+config = "bench/config.yaml"  -- | Read the config without dependency readConfigIO :: FilePath -> IO Config readConfigIO = decodeFileThrow +newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)+newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)- newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)- newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)- newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)- newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult GetExample = Maybe Example+type instance RuleResult GetExamples = [Example] type instance RuleResult GetSamples = Natural- type instance RuleResult GetExperiments = [Unescaped String]- type instance RuleResult GetVersions = [GitCommit]- type instance RuleResult GetParent = Text- type instance RuleResult GetCommitId = String  main :: IO ()@@ -96,12 +99,16 @@   _ <- addOracle $ \GetSamples {} -> samples <$> readConfig config   _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config   _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config+  _ <- addOracle $ \GetExamples{} -> examples <$> readConfig config   _ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config+  _ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config    let readVersions = askOracle $ GetVersions ()       readExperiments = askOracle $ GetExperiments ()+      readExamples = askOracle $ GetExamples ()       readSamples = askOracle $ GetSamples ()       getParent = askOracle . GetParent+      getExample = askOracle . GetExample    configStatic <- liftIO $ readConfigIO config   ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)@@ -111,16 +118,16 @@   phony "all" $ do     Config {..} <- readConfig config -    forM_ versions $ \ver ->-      need [build </> T.unpack (humanName ver) </> "results.csv"]-     need $+      [build </> getExampleName e </> "results.csv" | e <- examples ] ++       [build </> "results.csv"]-        ++ [ build </> escaped (escapeExperiment e) <.> "svg"+        ++ [ build </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"              | e <- experiments+             , ex <- examples            ]-        ++ [ build </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"+        ++ [ build </> getExampleName ex </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"              | e <- experiments,+               ex <- examples,                ver <- versions,                mode <- ["", "diff"]            ]@@ -135,14 +142,14 @@       Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]       writeFileChanged out $ init commitid -  priority 10 $ [build -/- "HEAD/ghcide"+  priority 10 $ [ build -/- "HEAD/ghcide"                 , build -/- "HEAD/ghc.path"                 ]     &%> \[out, ghcpath] -> do       liftIO $ createDirectoryIfMissing True $ dropFileName out       need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]       cmd_ $ buildGhcide buildSystem (takeDirectory out)-      ghcLoc <- findGhc buildSystem+      ghcLoc <- findGhc "." buildSystem       writeFile' ghcpath ghcLoc    [ build -/- "*/ghcide",@@ -154,12 +161,11 @@       commitid <- readFile' $ b </> ver </> "commitid"       cmd_ $ "git worktree add bench-temp " ++ commitid       flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do-        ghcLoc <- findGhc buildSystem+        ghcLoc <- findGhc "bench-temp" buildSystem         cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)         writeFile' ghcpath ghcLoc -  priority 8000 $-    build -/- "*/results.csv" %> \out -> do+  build -/- "*/*/results.csv" %> \out -> do       experiments <- readExperiments        let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]@@ -172,16 +178,17 @@   ghcideBenchResource <- newResource "ghcide-bench" 1    priority 0 $-    [ build -/- "*/*.csv",-      build -/- "*/*.benchmark-gcStats",-      build -/- "*/*.log"+    [ build -/- "*/*/*.csv",+      build -/- "*/*/*.benchmark-gcStats",+      build -/- "*/*/*.log"     ]       &%> \[outcsv, _outGc, outLog] -> do-        let [_, _, exp] = splitDirectories outcsv+        let [_, exampleName, ver, exp] = splitDirectories outcsv+        example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName         samples <- readSamples         liftIO $ createDirectoryIfMissing True $ dropFileName outcsv-        let ghcide = dropFileName outcsv </> "ghcide"-            ghcpath = dropFileName outcsv </> "ghc.path"+        let ghcide = build </> ver </> "ghcide"+            ghcpath = build </> ver </> "ghc.path"         need [ghcide, ghcpath]         ghcPath <- readFile' ghcpath         withResource ghcideBenchResource 1 $ do@@ -197,58 +204,71 @@                 "-v",                 "--samples=" <> show samples,                 "--csv=" <> outcsv,-                "--example-package-version=3.0.0.0",                 "--ghcide-options= +RTS -I0.5 -RTS",                 "--ghcide=" <> ghcide,                 "--select",                 unescaped (unescapeExperiment (Escaped $ dropExtension exp))               ] +++              exampleToOptions example ++               [ "--stack" | Stack == buildSystem]           cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv    build -/- "results.csv" %> \out -> do-    versions <- readVersions-    let allResultFiles =-          [build </> T.unpack (humanName v) </> "results.csv" | v <- versions]+    examples <- map getExampleName <$> readExamples+    let allResultFiles = [build </> e </> "results.csv" | e <- examples] -    need [build </> T.unpack (humanName v) </> "ghcide" | v <- versions]+    allResults <- traverse readFileLines allResultFiles +    let header = head $ head allResults+        results = map tail allResults+        header' = "example, " <> header+        results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results++    writeFileChanged out $ unlines $ header' : concat results'++  build -/- "*/results.csv" %> \out -> do+    versions <- map (T.unpack . humanName) <$> readVersions+    let example = takeFileName $ takeDirectory out+        allResultFiles =+          [build </> example </> v </> "results.csv" | v <- versions]+     allResults <- traverse readFileLines allResultFiles      let header = head $ head allResults         results = map tail allResults         header' = "version, " <> header-        results' = zipWith (\v -> map (\l -> T.unpack (humanName v) <> ", " <> l)) versions results+        results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results -    writeFileChanged out $ unlines $ header' : concat results'+    writeFileChanged out $ unlines $ header' : interleave results'    priority 2 $-    build -/- "*/*.diff.svg" %> \out -> do-      let [b, ver, exp_] = splitDirectories out+    build -/- "*/*/*.diff.svg" %> \out -> do+      let [b, example, ver, exp_] = splitDirectories out           exp = Escaped $ dropExtension $ dropExtension exp_       prev <- getParent $ T.pack ver -      runLog <- loadRunLog b exp ver-      runLogPrev <- loadRunLog b exp $ T.unpack prev+      runLog <- loadRunLog b example exp ver+      runLogPrev <- loadRunLog b example exp $ T.unpack prev        let diagram = Diagram Live [runLog, runLogPrev] title           title = show (unescapeExperiment exp) <> " - live bytes over time compared"       plotDiagram True diagram out    priority 1 $-    build -/- "*/*.svg" %> \out -> do-      let [b, ver, exp] = splitDirectories out-      runLog <- loadRunLog b (Escaped $ dropExtension exp) ver+    build -/- "*/*/*.svg" %> \out -> do+      let [b, example, ver, exp] = splitDirectories out+      runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver       let diagram = Diagram Live [runLog] title           title = ver <> " live bytes over time"       plotDiagram True diagram out -  build -/- "*.svg" %> \out -> do+  build -/- "*/*.svg" %> \out -> do     let exp = Escaped $ dropExtension $ takeFileName out+        example = takeFileName $ takeDirectory out     versions <- readVersions      runLogs <- forM (filter include versions) $ \v -> do-      loadRunLog build exp $ T.unpack $ humanName v+      loadRunLog build example exp $ T.unpack $ humanName v      let diagram = Diagram Live runLogs title         title = show (unescapeExperiment exp) <> " - live bytes over time"@@ -270,17 +290,18 @@         <> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts"  -findGhc :: BuildSystem -> Action FilePath-findGhc Cabal =+findGhc :: FilePath -> BuildSystem -> Action FilePath+findGhc _cwd Cabal =     liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"-findGhc Stack = do-    Stdout ghcLoc <- cmd (s "stack exec which ghc")+findGhc cwd Stack = do+    Stdout ghcLoc <- cmd [Cwd cwd] (s "stack exec which ghc")     return ghcLoc  --------------------------------------------------------------------------------  data Config = Config   { experiments :: [Unescaped String],+    examples :: [Example],     samples :: Natural,     versions :: [GitCommit],     -- | Path to the ghcide-bench binary for the experiments@@ -290,7 +311,7 @@     buildTool :: BuildSystem   }   deriving (Generic, Show)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (FromJSON)  data GitCommit = GitCommit   { -- | A git hash, tag or branch name (e.g. v0.1.0)@@ -399,14 +420,15 @@ -- | A file path containing the output of -S for a given run data RunLog = RunLog   { runVersion :: !String,+    _runExample :: !String,     _runExperiment :: !String,     runFrames :: ![Frame],     runSuccess :: !Bool   } -loadRunLog :: FilePath -> Escaped FilePath -> FilePath -> Action RunLog-loadRunLog buildF exp ver = do-  let log_fp = buildF </> ver </> escaped exp <.> "benchmark-gcStats"+loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog+loadRunLog buildF example exp ver = do+  let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"       csv_fp = replaceExtension log_fp "csv"   log <- readFileLines log_fp   csv <- readFileLines csv_fp@@ -420,7 +442,7 @@       success = case map (T.split (== ',') . T.pack) csv of           [_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s           _ -> error $ "Cannot parse: " <> csv_fp-  return $ RunLog ver (dropExtension $ escaped exp) frames success+  return $ RunLog ver example (dropExtension $ escaped exp) frames success  plotDiagram :: Bool -> Diagram -> FilePath -> Action () plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do@@ -460,6 +482,9 @@   where     f '_' = ' '     f other = other++interleave :: [[a]] -> [a]+interleave = concat . transpose  myColors :: [E.AlphaColour Double] myColors = map E.opaque

@@ -1,6 +1,8 @@+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImpredicativeTypes #-}  module Experiments ( Bench(..)@@ -8,78 +10,79 @@ , Config(..) , Verbosity(..) , CabalStack(..)+, SetupResult(..)+, Example(..) , experiments , configP , defConfig , output , setup , runBench-, runBenchmarks+, exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.IO.Class+import Data.Aeson (Value(Null)) import Data.Char (isDigit) import Data.List import Data.Maybe+import qualified Data.Text as T import Data.Version+import Development.IDE.Plugin.Test+import Experiments.Types import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory+import System.Environment.Blank (getEnv) import System.FilePath ((</>)) import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S)-import System.Environment.Blank (getEnv) --- Points to a string in the target file,--- convenient for hygienic edits-hygienicP :: Position-hygienicP = Position 854 23--hygienicEdit :: TextDocumentContentChangeEvent+hygienicEdit :: (?hygienicP :: Position) => TextDocumentContentChangeEvent hygienicEdit =     TextDocumentContentChangeEvent-    { _range = Just (Range hygienicP hygienicP),+    { _range = Just (Range ?hygienicP ?hygienicP),         _rangeLength = Nothing,         _text = " "     } -breakingEdit :: TextDocumentContentChangeEvent+breakingEdit :: (?identifierP :: Position) => TextDocumentContentChangeEvent breakingEdit =     TextDocumentContentChangeEvent-    { _range = Just (Range identifierP identifierP),+    { _range = Just (Range ?identifierP ?identifierP),         _rangeLength = Nothing,         _text = "a"     } --- Points to the middle of an identifier,--- convenient for requesting goto-def, hover and completions-identifierP :: Position-identifierP = Position 853 12+-- | Experiments have access to these special positions:+-- - hygienicP points to a string in the target file, convenient for hygienic edits+-- - identifierP points to the middle of an identifier, convenient for goto-def, hover and completions+type HasPositions = (?hygienicP :: Position, ?identifierP :: Position)  experiments :: [Bench] experiments =     [ ---------------------------------------------------------------------------------------       bench "hover" 10 $ \doc ->-        isJust <$> getHover doc identifierP,+        isJust <$> getHover doc ?identifierP,       ---------------------------------------------------------------------------------------       bench "edit" 10 $ \doc -> do         changeDoc doc [hygienicEdit]-        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+        waitForProgressDone         return True,       ---------------------------------------------------------------------------------------       bench "hover after edit" 10 $ \doc -> do         changeDoc doc [hygienicEdit]-        isJust <$> getHover doc identifierP,+        isJust <$> getHover doc ?identifierP,       ---------------------------------------------------------------------------------------       bench "getDefinition" 10 $ \doc ->-        not . null <$> getDefinitions doc identifierP,+        not . null <$> getDefinitions doc ?identifierP,       ---------------------------------------------------------------------------------------       bench "documentSymbols" 100 $         fmap (either (not . null) (not . null)) . getDocumentSymbols,@@ -90,15 +93,15 @@       ---------------------------------------------------------------------------------------       bench "completions after edit" 10 $ \doc -> do         changeDoc doc [hygienicEdit]-        not . null <$> getCompletions doc identifierP,+        not . null <$> getCompletions doc ?identifierP,       ---------------------------------------------------------------------------------------       benchWithSetup         "code actions"         10         ( \doc -> do             changeDoc doc [breakingEdit]-            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)-            return identifierP+            waitForProgressDone+            return ?identifierP         )         ( \p doc -> do             not . null <$> getCodeActions doc (Range p p)@@ -109,7 +112,7 @@         10         ( \doc -> do             changeDoc doc [breakingEdit]-            return identifierP+            return ?identifierP         )         ( \p doc -> do             changeDoc doc [hygienicEdit]@@ -120,40 +123,12 @@  --------------------------------------------------------------------------------------------- -examplePackageName :: HasConfig => String-examplePackageName = name-  where-      (name, _, _) = examplePackageUsed ?config--examplePackage :: HasConfig => String-examplePackage = name <> "-" <> showVersion version-  where-      (name, version, _) = examplePackageUsed ?config- exampleModulePath :: HasConfig => FilePath-exampleModulePath = path-  where-      (_,_, path) = examplePackageUsed ?config+exampleModulePath = exampleModule (example ?config)  examplesPath :: FilePath examplesPath = "bench/example" -data Verbosity = Quiet | Normal | All-  deriving (Eq, Show)-data Config = Config-  { verbosity :: !Verbosity,-    -- For some reason, the Shake profile files are truncated and won't load-    shakeProfiling :: !(Maybe FilePath),-    outputCSV :: !FilePath,-    buildTool :: !CabalStack,-    ghcideOptions :: ![String],-    matches :: ![String],-    repetitions :: Maybe Natural,-    ghcide :: FilePath,-    timeoutLsp :: Int,-    examplePackageUsed :: (String, Version, String)-  }-  deriving (Eq, Show)  defConfig :: Config Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []@@ -162,9 +137,6 @@ verbose = (== All) . verbosity quiet   = (== Quiet) . verbosity -data CabalStack = Cabal | Stack-  deriving (Eq, Show)- type HasConfig = (?config :: Config)  configP :: Parser Config@@ -182,9 +154,15 @@     <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))     <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")     <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")-    <*> ( (,,) <$> strOption (long "example-package-name" <> value "Cabal")+    <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal")+               <*> moduleOption                <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0]))-               <*> strOption (long "example-package-module" <> metavar "PATH" <> value "Distribution/Simple.hs"))+         <|>+          UsePackage <$> strOption (long "example-path")+                     <*> moduleOption+         )+  where+      moduleOption = strOption (long "example-module" <> metavar "PATH" <> value "Distribution/Simple.hs")  versionP :: ReadM Version versionP = maybeReader $ extract . readP_to_S parseVersion@@ -203,8 +181,8 @@   { name :: !String,     enabled :: !Bool,     samples :: !Natural,-    benchSetup :: TextDocumentIdentifier -> Session setup,-    experiment :: setup -> Experiment+    benchSetup :: HasPositions => TextDocumentIdentifier -> Session setup,+    experiment :: HasPositions => setup -> Experiment   }  select :: HasConfig => Bench -> Bool@@ -216,38 +194,51 @@ benchWithSetup ::   String ->   Natural ->-  (TextDocumentIdentifier -> Session p) ->-  (p -> Experiment) ->+  (HasPositions => TextDocumentIdentifier -> Session p) ->+  (HasPositions => p -> Experiment) ->   Bench benchWithSetup name samples benchSetup experiment = Bench {..}   where     enabled = True -bench :: String -> Natural -> Experiment -> Bench+bench :: String -> Natural -> (HasPositions => Experiment) -> Bench bench name defSamples userExperiment =   benchWithSetup name defSamples (const $ pure ()) experiment   where     experiment () = userExperiment -runBenchmarks :: HasConfig => [Bench] -> IO ()-runBenchmarks allBenchmarks = do+runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()+runBenchmarksFun dir allBenchmarks = do   let benchmarks = [ b{samples = fromMaybe (samples b) (repetitions ?config) }                    | b <- allBenchmarks                    , select b ]   results <- forM benchmarks $ \b@Bench{name} ->-                let run dir = runSessionWithConfig conf (cmd name dir) lspTestCaps dir+                let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir                 in (b,) <$> runBench run b    -- output raw data as CSV-  let headers = ["name", "success", "samples", "startup", "setup", "experiment", "maxResidency"]+  let headers =+        [ "name"+        , "success"+        , "samples"+        , "startup"+        , "setup"+        , "userTime"+        , "delayedTime"+        , "totalTime"+        , "maxResidency"+        , "allocatedBytes"]       rows =         [ [ name,             show success,             show samples,             show startup,             show runSetup',+            show userWaits,+            show delayedWork,             show runExperiment,-            showMB maxResidency+            show maxResidency,+            show allocations           ]           | (Bench {name, samples}, BenchRun {..}) <- results,             let runSetup' = if runSetup < 0.01 then 0 else runSetup@@ -265,8 +256,11 @@             show samples,             showDuration startup,             showDuration runSetup',+            showDuration userWaits,+            showDuration delayedWork,             showDuration runExperiment,-            showMB maxResidency+            showMB maxResidency,+            showMB allocations           ]           | (Bench {name, samples}, BenchRun {..}) <- results,             let runSetup' = if runSetup < 0.01 then 0 else runSetup@@ -280,6 +274,7 @@       unwords $         [ ghcide ?config,           "--lsp",+          "--test",           "--cwd",           dir,           "+RTS",@@ -288,9 +283,9 @@         ]           ++ ghcideOptions ?config           ++ concat-            [ ["--shake-profiling", path]-              | Just path <- [shakeProfiling ?config]+            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]             ]+          ++ ["--verbose" | verbose ?config]     lspTestCaps =       fullCaps {_window = Just $ WindowClientCapabilities $ Just True}     conf =@@ -305,108 +300,164 @@   { startup :: !Seconds,     runSetup :: !Seconds,     runExperiment :: !Seconds,+    userWaits :: !Seconds,+    delayedWork :: !Seconds,     success :: !Bool,-    maxResidency :: !Int+    maxResidency :: !Int,+    allocations :: !Int   }  badRun :: BenchRun-badRun = BenchRun 0 0 0 False 0+badRun = BenchRun 0 0 0 0 0 False 0 0  waitForProgressDone :: Session () waitForProgressDone =       void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) -runBench :: (?config::Config) => (String -> Session BenchRun -> IO BenchRun) -> Bench -> IO BenchRun-runBench runSess Bench {..} = handleAny (\e -> print e >> return badRun)-  $ runSess dir+runBench ::+  (?config :: Config) =>+  (Session BenchRun -> IO BenchRun) ->+  (HasPositions => Bench) ->+  IO BenchRun+runBench runSess b = handleAny (\e -> print e >> return badRun)+  $ runSess   $ do     doc <- openDoc exampleModulePath "haskell"-    (startup, _) <- duration $ do-      waitForProgressDone-      -- wait again, as the progress is restarted once while loading the cradle-      -- make an edit, to ensure this doesn't block-      changeDoc doc [hygienicEdit]-      waitForProgressDone +    -- Setup the special positions used by the experiments+    lastLine <- length . T.lines <$> documentContents doc+    changeDoc doc [TextDocumentContentChangeEvent+        { _range = Just (Range (Position lastLine 0) (Position lastLine 0))+        , _rangeLength = Nothing+        , _text = T.unlines+               [ "_hygienic = \"hygienic\""+               , "_identifier = _hygienic"+               ]+        }]+    let+      -- Points to a string in the target file,+      -- convenient for hygienic edits+      ?hygienicP = Position lastLine 15+    let+      -- Points to the middle of an identifier,+      -- convenient for requesting goto-def, hover and completions+      ?identifierP = Position (lastLine+1) 15 -    liftIO $ output $ "Running " <> name <> " benchmark"-    (runSetup, userState) <- duration $ benchSetup doc-    let loop 0 = return True-        loop n = do-          (t, res) <- duration $ experiment userState doc-          if not res-            then return False-            else do-              output (showDuration t)-              loop (n -1)+    case b of+     Bench{..} -> do+      (startup, _) <- duration $ do+        waitForProgressDone+        -- wait again, as the progress is restarted once while loading the cradle+        -- make an edit, to ensure this doesn't block+        changeDoc doc [hygienicEdit]+        waitForProgressDone -    (runExperiment, success) <- duration $ loop samples+      liftIO $ output $ "Running " <> name <> " benchmark"+      (runSetup, userState) <- duration $ benchSetup doc+      let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork)+          loop !userWaits !delayedWork n = do+            (t, res) <- duration $ experiment userState doc+            if not res+              then return Nothing+              else do+                output (showDuration t)+                -- Wait for the delayed actions to finish+                waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue+                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId+                case resp of+                    ResponseMessage{_result=Right Null} -> do+                      loop (userWaits+t) (delayedWork+td) (n -1)+                    _ ->+                    -- Assume a ghcide build lacking the WaitForShakeQueue command+                      loop (userWaits+t) delayedWork (n -1) -    -- sleep to give ghcide a chance to GC-    liftIO $ threadDelay 1100000+      (runExperiment, result) <- duration $ loop 0 0 samples+      let success = isJust result+          (userWaits, delayedWork) = fromMaybe (0,0) result+          gcStats = escapeSpaces (name <> ".benchmark-gcStats") -    maxResidency <- liftIO $-        ifM (doesFileExist gcStats)-            (parseMaxResidency <$> readFile gcStats)-            (pure 0)+      -- sleep to give ghcide a chance to GC+      liftIO $ threadDelay 1100000 -    return BenchRun {..}-  where-    dir = "bench/example/" <> examplePackage-    gcStats = escapeSpaces (name <> ".benchmark-gcStats")+      (maxResidency, allocations) <- liftIO $+          ifM (doesFileExist gcStats)+              (parseMaxResidencyAndAllocations <$> readFile gcStats)+              (pure (0,0)) -setup :: HasConfig => IO (IO ())+      return BenchRun {..}++data SetupResult = SetupResult {+    runBenchmarks :: [Bench] -> IO (),+    -- | Path to the setup benchmark example+    benchDir :: FilePath,+    cleanUp :: IO ()+}++setup :: HasConfig => IO SetupResult setup = do   alreadyExists <- doesDirectoryExist examplesPath   when alreadyExists $ removeDirectoryRecursive examplesPath-  let path = examplesPath </> examplePackage-  case buildTool ?config of-      Cabal -> do-        callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath-        writeFile-            (path </> "hie.yaml")-            ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")-        -- Need this in case there is a parent cabal.project somewhere-        writeFile-            (path </> "cabal.project")-            "packages: ."-        writeFile-            (path </> "cabal.project.local")-            ""-      Stack -> do-        callCommand $ "stack --silent unpack " <> examplePackage <> " --to " <> examplesPath-        -- Generate the stack descriptor to match the one used to build ghcide-        stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"-        stack_yaml_lines <- lines <$> readFile stack_yaml-        writeFile (path </> stack_yaml)-                  (unlines $-                   "packages: [.]" :-                    [ l-                    | l <- stack_yaml_lines-                    , any (`isPrefixOf` l)-                        ["resolver"-                        ,"allow-newer"-                        ,"compiler"]-                    ]-                  )+  benchDir <- case example ?config of+      UsePackage{..} -> return examplePath+      GetPackage{..} -> do+        let path = examplesPath </> package+            package = exampleName <> "-" <> showVersion exampleVersion+        case buildTool ?config of+            Cabal -> do+                callCommand $ "cabal get -v0 " <> package <> " -d " <> examplesPath+                writeFile+                    (path </> "hie.yaml")+                    ("cradle: {cabal: {component: " <> exampleName <> "}}")+                -- Need this in case there is a parent cabal.project somewhere+                writeFile+                    (path </> "cabal.project")+                    "packages: ."+                writeFile+                    (path </> "cabal.project.local")+                    ""+            Stack -> do+                callCommand $ "stack --silent unpack " <> package <> " --to " <> examplesPath+                -- Generate the stack descriptor to match the one used to build ghcide+                stack_yaml <- fromMaybe "stack.yaml" <$> getEnv "STACK_YAML"+                stack_yaml_lines <- lines <$> readFile stack_yaml+                writeFile (path </> stack_yaml)+                        (unlines $+                        "packages: [.]" :+                            [ l+                            | l <- stack_yaml_lines+                            , any (`isPrefixOf` l)+                                ["resolver"+                                ,"allow-newer"+                                ,"compiler"]+                            ]+                        ) -        writeFile-            (path </> "hie.yaml")-            ("cradle: {stack: {component: " <> show (examplePackageName <> ":lib") <> "}}")+                writeFile+                    (path </> "hie.yaml")+                    ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}")+        return path    whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True -  return $ removeDirectoryRecursive examplesPath+  let cleanUp = case example ?config of+        GetPackage{} -> removeDirectoryRecursive examplesPath+        UsePackage{} -> return () ---------------------------------------------------------------------------------------------+      runBenchmarks = runBenchmarksFun benchDir --- Parse the max residency in RTS -s output-parseMaxResidency :: String -> Int-parseMaxResidency input =-  case find ("maximum residency" `isInfixOf`) (reverse $ lines input) of-    Just l -> read $ filter isDigit $ head (words l)-    Nothing -> -1+  return SetupResult{..} +--------------------------------------------------------------------------------------------++-- Parse the max residency and allocations in RTS -s output+parseMaxResidencyAndAllocations :: String -> (Int, Int)+parseMaxResidencyAndAllocations input =+    (f "maximum residency", f "bytes allocated in the heap")+  where+    inps = reverse $ lines input+    f label = case find (label `isInfixOf`) inps of+        Just l -> read $ filter isDigit $ head $ words l+        Nothing -> -1  escapeSpaces :: String -> String escapeSpaces = map f

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+module Experiments.Types where++import Data.Aeson+import Data.Version+import Numeric.Natural+import System.FilePath (isPathSeparator)+import Development.Shake.Classes+import GHC.Generics++data CabalStack = Cabal | Stack+  deriving (Eq, Show)++data Verbosity = Quiet | Normal | All+  deriving (Eq, Show)+data Config = Config+  { verbosity :: !Verbosity,+    -- For some reason, the Shake profile files are truncated and won't load+    shakeProfiling :: !(Maybe FilePath),+    outputCSV :: !FilePath,+    buildTool :: !CabalStack,+    ghcideOptions :: ![String],+    matches :: ![String],+    repetitions :: Maybe Natural,+    ghcide :: FilePath,+    timeoutLsp :: Int,+    example :: Example+  }+  deriving (Eq, Show)++data Example+    = GetPackage {exampleName, exampleModule :: String, exampleVersion :: Version}+    | UsePackage {examplePath :: FilePath, exampleModule :: String}+  deriving (Eq, Generic, Show)+  deriving anyclass (Binary, Hashable, NFData)++getExampleName :: Example -> String+getExampleName UsePackage{examplePath} = map replaceSeparator examplePath+  where+      replaceSeparator x+        | isPathSeparator x = '_'+        | otherwise = x+getExampleName GetPackage{exampleName, exampleVersion} =+    exampleName <> "-" <> showVersion exampleVersion++instance FromJSON Example where+    parseJSON = withObject "example" $ \x -> do+        exampleModule <- x .: "module"+        path <- x .:? "path"+        case path of+            Just examplePath -> return UsePackage{..}+            Nothing -> do+                exampleName <- x .: "name"+                exampleVersion <- x .: "version"+                return GetPackage {..}++exampleToOptions :: Example -> [String]+exampleToOptions GetPackage{..} =+    ["--example-package-name", exampleName+    ,"--example-package-version", showVersion exampleVersion+    ,"--example-module", exampleModule+    ]+exampleToOptions UsePackage{..} =+    ["--example-path", examplePath+    ,"--example-module", exampleModule+    ]

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.4.0+version:            0.5.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -13,7 +13,7 @@     A library for building Haskell IDE's on top of the GHC API. homepage:           https://github.com/haskell/ghcide#readme bug-reports:        https://github.com/haskell/ghcide/issues-tested-with:        GHC>=8.4.4+tested-with:        GHC>=8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md                     test/data/hover/*.hs                     test/data/multi/cabal.project@@ -48,10 +48,13 @@         extra,         fuzzy,         filepath,+        fingertree,+        Glob,         haddock-library >= 1.8,         hashable,         haskell-lsp-types == 0.22.*,         haskell-lsp == 0.22.*,+        hie-compat,         mtl,         network-uri,         prettyprinter-ansi-terminal,@@ -80,14 +83,14 @@       build-depends:         ghc-boot-th,         ghc-boot,-        ghc >= 8.4,+        ghc >= 8.6,         -- These dependencies are used by Development.IDE.Session and are         -- Haskell specific. So don't use them when building with -fghc-lib!         ghc-check >=0.5.0.1,         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,         hie-bios >= 0.7.1 && < 0.8.0,-        implicit-hie-cradle >= 0.2.0.0 && < 0.3,+        implicit-hie-cradle >= 0.2.0.1 && < 0.3,         base16-bytestring >=0.1.1 && <0.2     if os(windows)       build-depends:@@ -126,12 +129,14 @@         Development.IDE.Core.IdeConfiguration         Development.IDE.Core.OfInterest         Development.IDE.Core.PositionMapping+        Development.IDE.Core.Preprocessor         Development.IDE.Core.Rules         Development.IDE.Core.RuleTypes         Development.IDE.Core.Service         Development.IDE.Core.Shake         Development.IDE.GHC.Compat         Development.IDE.GHC.Error+        Development.IDE.GHC.Orphans         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation         Development.IDE.LSP.HoverDefinition@@ -140,6 +145,8 @@         Development.IDE.LSP.Protocol         Development.IDE.LSP.Server         Development.IDE.Spans.Common+        Development.IDE.Spans.AtPoint+        Development.IDE.Spans.LocalBindings         Development.IDE.Types.Diagnostics         Development.IDE.Types.Exports         Development.IDE.Types.Location@@ -165,42 +172,18 @@         Development.IDE.Session.VersionCheck     other-modules:         Development.IDE.Core.Compile-        Development.IDE.Core.Preprocessor         Development.IDE.Core.FileExists         Development.IDE.GHC.CPP-        Development.IDE.GHC.Orphans         Development.IDE.GHC.Warnings-        Development.IDE.GHC.WithDynFlags         Development.IDE.Import.FindImports         Development.IDE.LSP.Notifications-        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         Development.IDE.Types.Action-    if (impl(ghc > 8.5) && impl(ghc < 8.7)) && !flag(ghc-lib)-      hs-source-dirs: src-ghc86-      other-modules:-        Development.IDE.GHC.HieAst-        Development.IDE.GHC.HieBin-        Development.IDE.GHC.HieTypes-        Development.IDE.GHC.HieDebug-        Development.IDE.GHC.HieUtils-    if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)-      hs-source-dirs: src-ghc88-      other-modules:-        Development.IDE.GHC.HieAst-        Development.IDE.GHC.HieBin-    if (impl(ghc > 8.9))-      hs-source-dirs: src-ghc810-      other-modules:-        Development.IDE.GHC.HieAst-        Development.IDE.GHC.HieBin     ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns  executable ghcide-test-preprocessor@@ -215,7 +198,9 @@     type: exitcode-stdio-1.0     default-language: Haskell2010     ghc-options: -Wall -Wno-name-shadowing -threaded-    main-is: bench/hist/Main.hs+    main-is: Main.hs+    hs-source-dirs: bench/hist bench/lib+    other-modules: Experiments.Types     build-tool-depends:         ghcide:ghcide,         ghcide:ghcide-bench@@ -335,7 +320,7 @@         haskell-lsp-types,         network-uri,         lens,-        lsp-test >= 0.11.0.5 && < 0.12,+        lsp-test >= 0.11.0.6 && < 0.12,         optparse-applicative,         process,         QuickCheck,@@ -362,6 +347,7 @@         Development.IDE.Test         Development.IDE.Test.Runfiles         Experiments+        Experiments.Types     default-extensions:         BangPatterns         DeriveFunctor@@ -394,13 +380,16 @@         lsp-test >= 0.11.0.2 && < 0.12,         optparse-applicative,         process,-        safe-exceptions+        safe-exceptions,+        shake,+        text     hs-source-dirs: bench/lib bench/exe     include-dirs: include     ghc-options: -threaded -Wall -Wno-name-shadowing     main-is: Main.hs     other-modules:         Experiments+        Experiments.Types     default-extensions:         BangPatterns         DeriveFunctor

@@ -34,7 +34,8 @@ import Development.IDE.Core.OfInterest import Development.IDE.Core.Shake import Development.IDE.Core.RuleTypes-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat hiding (Target, TargetModule, TargetFile)+import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics@@ -58,14 +59,12 @@ import System.IO  import GHCi-import DynFlags-import HscTypes+import HscTypes (ic_dflags, hsc_IC, hsc_dflags, hsc_NC) import Linker import Module import NameCache import Packages import Control.Exception (evaluate)-import Data.Char  -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file.@@ -111,15 +110,19 @@     IdeOptions{ optTesting = IdeTesting optTesting               , optCheckProject = CheckProject checkProject               , optCustomDynFlags+              , optExtensions               } <- getIdeOptions          -- populate the knownTargetsVar with all the         -- files in the project so that `knownFiles` can learn about them and         -- we can generate a complete module graph     let extendKnownTargets newTargets = do-          knownTargets <- forM newTargets $ \TargetDetails{..} -> do-            found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations-            return (targetModule, found)+          knownTargets <- forM newTargets $ \TargetDetails{..} ->+            case targetTarget of+              TargetFile f -> pure (targetTarget, [f])+              TargetModule _ -> do+                found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations+                return (targetTarget, found)           modifyVar_ knownTargetsVar $ traverseHashed $ \known -> do             let known' = HM.unionWith (<>) known $ HM.fromList knownTargets             when (known /= known') $@@ -198,7 +201,7 @@       let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)-                -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath]))+                -> IO (IdeResult HscEnvEq,[FilePath])         session args@(hieYaml, _cfp, _opts, _libDir) = do           (hscEnv, new, old_deps) <- packageSetup args @@ -227,7 +230,7 @@            -- 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 hieYaml hscEnv uids+          let new_cache = newComponentCache logger optExtensions hieYaml _cfp 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@@ -244,11 +247,21 @@           invalidateShakeCache           restartShakeSession [kick] -          let resultCachedTargets = concatMap targetLocations all_targets+          -- Typecheck all files in the project on startup+          unless (null cs || not checkProject) $ do+                cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)+                void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do+                    mmt <- uses GetModificationTime cfps'+                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)+                    modIfaces <- uses GetModIface cs_exist+                    -- update exports map+                    extras <- getShakeExtras+                    let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces+                    liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>) -          return (resultCachedTargets, second Map.keys res)+          return (second Map.keys res) -    let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))+    let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])         consultCradle hieYaml cfp = do            lfp <- flip makeRelative cfp <$> getCurrentDirectory            logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)@@ -275,7 +288,7 @@                  InstallationNotFound{..} ->                      error $ "GHC installation not found in libdir: " <> libdir                  InstallationMismatch{..} ->-                     return ([],(([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]))+                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])                  InstallationChecked _compileTime _ghcLibCheck ->                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)              -- Failure case, either a cradle error or the none cradle@@ -285,12 +298,12 @@                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 ([ncfp],(res,[]))+               return (res,[])      -- This caches the mapping from hie.yaml + Mod.hs -> [String]     -- Returns the Ghc session and the cradle dependencies     let sessionOpts :: (Maybe FilePath, FilePath)-                    -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath]))+                    -> IO (IdeResult HscEnvEq, [FilePath])         sessionOpts (hieYaml, file) = do           v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags           cfp <- canonicalizePath file@@ -305,37 +318,25 @@                   -- Keep the same name cache                   modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )                   consultCradle hieYaml cfp-                else return (HM.keys v, (opts, Map.keys old_di))+                else return (opts, Map.keys old_di)             Nothing -> consultCradle hieYaml cfp      -- The main function which gets options for a file. We only want one of these running     -- at a time. Therefore the IORef contains the currently running cradle, if we try     -- to get some more options then we wait for the currently running action to finish     -- before attempting to do so.-    let getOptions :: FilePath -> IO ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath]))+    let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])         getOptions file = do             hieYaml <- cradleLoc file             sessionOpts (hieYaml, file) `catch` \e ->-                return ([],(([renderPackageSetupException file e], Nothing),[]))+                return (([renderPackageSetupException file e], Nothing),[])      returnWithVersion $ \file -> do-      (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do+      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do         -- If the cradle is not finished, then wait for it to finish.         void $ wait as         as <- async $ getOptions file-        return (fmap snd as, wait as)-      unless (null cs) $ do-        cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs-        -- Typecheck all files in the project on startup-        void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do-          when checkProject $ do-            mmt <- uses GetModificationTime cfps'-            let cs_exist = catMaybes (zipWith (<$) cfps' mmt)-            modIfaces <- uses GetModIface cs_exist-            -- update xports map-            extras <- getShakeExtras-            let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces-            liftIO $ modifyVar_ (exportsMap extras) $ evaluate . (exportsMap' <>)+        return (as, wait as)       pure opts  -- | Run the specific cradle on a specific FilePath via hie-bios.@@ -369,42 +370,35 @@ emptyHscEnv nc libDir = do     env <- runGhc (Just libDir) getSession     initDynLinker env-    pure $ setNameCache nc env+    pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }  data TargetDetails = TargetDetails   {-      targetModule :: !ModuleName,+      targetTarget :: !Target,       targetEnv :: !(IdeResult HscEnvEq),       targetDepends :: !DependencyInfo,       targetLocations :: ![NormalizedFilePath]   }  fromTargetId :: [FilePath]          -- ^ import paths+             -> [String]            -- ^ extensions to consider              -> TargetId              -> IdeResult HscEnvEq              -> DependencyInfo              -> IO [TargetDetails] -- For a target module we consider all the import paths-fromTargetId is (TargetModule mod) env dep = do-    let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]-        exts = ["hs", "hs-boot", "lhs"]+fromTargetId is exts (GHC.TargetModule mod) env dep = do+    let fps = [i </> moduleNameSlashes mod -<.> ext <> boot+              | ext <- exts+              , i <- is+              , boot <- ["", "-boot"]+              ]     locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps-    return [TargetDetails mod env dep locs]+    return [TargetDetails (TargetModule mod) env dep locs] -- For a 'TargetFile' we consider all the possible module names-fromTargetId _ (TargetFile f _) env deps = do+fromTargetId _ _ (GHC.TargetFile f _) env deps = do     nf <- toNormalizedFilePath' <$> canonicalizePath f-    return [TargetDetails m env deps [nf] | m <- moduleNames f]---- >>> moduleNames "src/A/B.hs"--- [A.B,B]-moduleNames :: FilePath -> [ModuleName]-moduleNames f = map (mkModuleName .intercalate ".") $ init $ tails nameSegments-    where-        nameSegments = reverse-                     $ takeWhile (isUpper . head)-                     $ reverse-                     $ splitDirectories-                     $ dropExtension f+    return [TargetDetails (TargetFile nf) env deps [nf]]  toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} =@@ -417,12 +411,14 @@ -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache          :: Logger+         -> [String]       -- File extensions to consider          -> Maybe FilePath -- Path to cradle+         -> NormalizedFilePath -- Path to file that caused the creation of this component          -> HscEnv          -> [(InstalledUnitId, DynFlags)]          -> ComponentInfo          -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo))-newComponentCache logger cradlePath hsc_env uids ci = do+newComponentCache logger exts cradlePath cfp 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 } }@@ -434,7 +430,7 @@         res = (targetEnv, targetDepends)     logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) -    let mk t = fromTargetId (importPaths df) (targetId t) targetEnv targetDepends+    let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends     ctargets <- concatMapM mk (componentTargets ci)      -- A special target for the file which caused this wonderful@@ -442,7 +438,7 @@     -- 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 = TargetDetails (mkModuleName "special") targetEnv targetDepends [componentFP ci]+    let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci]     return (special_target:ctargets, res)  {- Note [Avoiding bad interface files]@@ -507,6 +503,7 @@     pure $ dflags           & setHiDir cacheDir           & setHieDir cacheDir+          & setODir cacheDir   renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic@@ -525,7 +522,7 @@   -- We do not want to use them unprocessed.   , rawComponentDynFlags :: DynFlags   -- | All targets of this components.-  , rawComponentTargets :: [Target]+  , rawComponentTargets :: [GHC.Target]   -- | Filepath which caused the creation of this component   , rawComponentFP :: NormalizedFilePath   -- | Component Options used to load the component.@@ -546,7 +543,7 @@   -- ComponentOptions.   , _componentInternalUnits :: [InstalledUnitId]   -- | All targets of this components.-  , componentTargets :: [Target]+  , componentTargets :: [GHC.Target]   -- | Filepath which caused the creation of this component   , componentFP :: NormalizedFilePath   -- | Component Options used to load the component.@@ -619,7 +616,7 @@             Just res -> return (mp, res)  -- | Throws if package flags are unsatisfiable-setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) setOptions (ComponentOptions theOpts compRoot _) dflags = do     (dflags', targets) <- addCmdOpts theOpts dflags     let dflags'' =@@ -663,6 +660,11 @@     -- override user settings to avoid conflicts leading to recompilation     d { hiDir      = Just f} +setODir :: FilePath -> DynFlags -> DynFlags+setODir f d =+    -- override user settings to avoid conflicts leading to recompilation+    d { objectDir = Just f}+ getCacheDir :: String -> [String] -> IO FilePath getCacheDir prefix opts = getXdgDirectory XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)     where@@ -677,10 +679,11 @@ notifyUserImplicitCradle:: FilePath -> FromServerMessage notifyUserImplicitCradle fp =     NotShowMessage $-    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtWarning $+    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $       "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "       <> T.pack fp <>-      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)"+      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\+      \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."  notifyCradleLoaded :: FilePath -> FromServerMessage notifyCradleLoaded fp =

@@ -1,1928 +0,0 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--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-        ]

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

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