packages feed

ghcide 1.7.0.0 → 1.8.0.0

raw patch · 192 files changed

+6602/−14361 lines, 192 filesdep +co-log-coredep +ekg-coredep +ekg-waidep −ghc-exactprintdep −processdep −quickcheck-instancesdep ~basedep ~extradep ~ghc-check

Dependencies added: co-log-core, ekg-core, ekg-wai, text-rope

Dependencies removed: ghc-exactprint, process, quickcheck-instances, retrie, rope-utf16-splay, safe, shake-bench, utf8-string, vector-algorithms, yaml

Dependency ranges changed: base, extra, ghc-check, haddock-library, hie-bios, hie-compat, hiedb, hls-graph, hls-plugin-api, lsp, lsp-test, lsp-types, prettyprinter, tasty-hunit

Files

− bench/exe/Main.hs 
@@ -1,59 +0,0 @@-{- An automated benchmark built around the simple experiment described in:--  > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html--  As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and-  loads the module 'Distribution.Simple'. The rationale for this choice is:--    - It's convenient to download with `cabal unpack Cabal-3.2.0.0`-    - It has very few dependencies, and all are already needed to build ghcide-    - Distribution.Simple has 235 transitive module dependencies, so non trivial--  The experiments are sequences of lsp commands scripted using lsp-test.-  A more refined approach would be to record and replay real IDE interactions,-  once the replay functionality is available in lsp-test.-  A more declarative approach would be to reuse ide-debug-driver:--  > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md--  The result of an experiment is a total duration in seconds after a preset-  number of iterations. There is ample room for improvement:-     - Statistical analysis to detect outliers and auto infer the number of iterations needed-     - GC stats analysis (currently -S is printed as part of the experiment)-     - Analyisis of performance over the commit history of the project--  How to run:-     1. `cabal exec cabal run ghcide-bench -- -- ghcide-bench-options`-     1. `stack build ghcide:ghcide-bench && stack exec ghcide-bench -- -- ghcide-bench-options`--  Note that the package database influences the response times of certain actions,-  e.g. code actions, and therefore the two methods above do not necessarily-  produce the same results.-- -}--{-# LANGUAGE ImplicitParams #-}--import           Control.Exception.Safe-import           Control.Monad-import           Experiments-import           Options.Applicative-import           System.IO--optsP :: Parser (Config, Bool)-optsP = (,) <$> configP <*> switch (long "no-clean")--main :: IO ()-main = do-  hSetBuffering stdout LineBuffering-  hSetBuffering stderr LineBuffering-  (config, noClean) <- execParser $ info (optsP <**> helper) fullDesc-  let ?config = config--  hPrint stderr config--  output "starting test"--  SetupResult{..} <- setup--  runBenchmarks experiments `finally` unless noClean cleanUp
− bench/hist/Main.hs 
@@ -1,192 +0,0 @@-{-  Bench history--    A Shake script to analyze the performance of ghcide over the git history of the project--    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-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>.gcStats.log          - 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--   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`.--   To execute the script:--   > cabal/stack bench--   To build a specific analysis, enumerate the desired file artifacts--   > 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 DeriveAnyClass     #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TypeFamilies       #-}-{-# OPTIONS -Wno-orphans #-}--import           Control.Monad.Extra-import           Data.Foldable               (find)-import           Data.Maybe-import           Data.Yaml                   (FromJSON (..), decodeFileThrow)-import           Development.Benchmark.Rules-import           Development.Shake-import           Development.Shake.Classes-import           Experiments.Types           (Example (exampleName),-                                              exampleToOptions)-import           GHC.Generics                (Generic)-import           Numeric.Natural             (Natural)-import           System.Console.GetOpt-import           System.FilePath--configPath :: FilePath-configPath = "bench/config.yaml"--configOpt :: OptDescr (Either String FilePath)-configOpt = Option [] ["config"] (ReqArg Right configPath) "config file"---- | Read the config without dependency-readConfigIO :: FilePath -> IO (Config BuildSystem)-readConfigIO = decodeFileThrow--instance IsExample Example where getExampleName = exampleName-type instance RuleResult GetExample = Maybe Example-type instance RuleResult GetExamples = [Example]--shakeOpts :: ShakeOptions-shakeOpts =-    shakeOptions{shakeChange = ChangeModtimeAndDigestInput, shakeThreads = 0}--main :: IO ()-main = shakeArgsWith shakeOpts [configOpt] $ \configs wants -> pure $ Just $ do-  let config = fromMaybe configPath $ listToMaybe configs-  _configStatic <- createBuildSystem config-  case wants of-      [] -> want ["all"]-      _  -> want wants--ghcideBuildRules :: MkBuildRules BuildSystem-ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide-  where-      projectDepends = do-        need . map ("../hls-graph/src" </>) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"]-        need . map ("../hls-plugin-api/src" </>) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"]-        need . map ("src" </>) =<< getDirectoryFiles "src" ["//*.hs"]-        need . map ("session-loader" </>) =<< getDirectoryFiles "session-loader" ["//*.hs"]-        need =<< getDirectoryFiles "." ["*.cabal"]------------------------------------------------------------------------------------data Config buildSystem = Config-  { experiments     :: [Unescaped String],-    examples        :: [Example],-    samples         :: Natural,-    versions        :: [GitCommit],-    -- | Output folder ('foo' works, 'foo/bar' does not)-    outputFolder    :: String,-    buildTool       :: buildSystem,-    profileInterval :: Maybe Double-  }-  deriving (Generic, Show)-  deriving anyclass (FromJSON)--createBuildSystem :: FilePath -> Rules (Config BuildSystem )-createBuildSystem config = do-  readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)--  _ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config-  _ <- addOracle $ \GetVersions {} -> versions <$> readConfig config-  _ <- versioned 1 $ addOracle $ \GetExamples{} -> examples <$> readConfig config-  _ <- versioned 1 $ addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config-  _ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config-  _ <- addOracle $ \GetSamples{} -> samples <$> readConfig config--  configStatic <- liftIO $ readConfigIO config-  let build = outputFolder configStatic--  buildRules build ghcideBuildRules-  benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide")-  csvRules build-  svgRules build-  heapProfileRules build-  phonyRules "" "ghcide" NoProfiling build (examples configStatic)--  whenJust (profileInterval configStatic) $ \i -> do-    phonyRules "profiled-" "ghcide" (CheapHeapProfiling i) build (examples configStatic)--  return configStatic--newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)-type instance RuleResult GetSamples = Natural------------------------------------------------------------------------------------buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()-buildGhcide Cabal args out = do-    command_ args "cabal"-        ["install"-        ,"exe:ghcide"-        ,"--installdir=" ++ out-        ,"--install-method=copy"-        ,"--overwrite-policy=always"-        ,"--ghc-options=-rtsopts"-        ,"--ghc-options=-eventlog"-        ]--buildGhcide Stack args out =-    command_ args "stack"-        ["--local-bin-path=" <> out-        ,"build"-        ,"ghcide:ghcide"-        ,"--copy-bins"-        ,"--ghc-options=-rtsopts"-        ,"--ghc-options=-eventlog"-        ]--benchGhcide-  :: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()-benchGhcide samples buildSystem args BenchProject{..} = do-  command_ args "ghcide-bench" $-    [ "--timeout=300",-      "--no-clean",-        "-v",-        "--samples=" <> show samples,-        "--csv="     <> outcsv,-        "--ghcide="  <> exePath,-        "--select",-        unescaped (unescapeExperiment experiment)-    ] ++-    exampleToOptions example exeExtraArgs ++-    [ "--stack" | Stack == buildSystem-    ]--warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action ()-warmupGhcide buildSystem exePath args example = do-  command args "ghcide-bench" $-    [ "--no-clean",-      "-v",-      "--samples=1",-      "--ghcide=" <> exePath,-      "--select=hover"-    ] ++-    exampleToOptions example [] ++-    [ "--stack" | Stack == buildSystem-    ]
− bench/lib/Experiments.hs 
@@ -1,684 +0,0 @@-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs                     #-}-{-# LANGUAGE ImplicitParams            #-}-{-# LANGUAGE ImpredicativeTypes        #-}-{-# LANGUAGE PolyKinds                 #-}-{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}--module Experiments-( Bench(..)-, BenchRun(..)-, Config(..)-, Verbosity(..)-, CabalStack(..)-, SetupResult(..)-, Example(..)-, experiments-, configP-, defConfig-, output-, setup-, runBench-, exampleToOptions-) where-import           Control.Applicative.Combinators (skipManyTill)-import           Control.Exception.Safe          (IOException, handleAny, try)-import           Control.Monad.Extra-import           Control.Monad.IO.Class-import           Data.Aeson                      (Value (Null), toJSON)-import           Data.Either                     (fromRight)-import           Data.List-import           Data.Maybe-import qualified Data.Text                       as T-import           Data.Version-import           Development.IDE.Plugin.Test-import           Development.IDE.Test            (getBuildEdgesCount,-                                                  getBuildKeysBuilt,-                                                  getBuildKeysChanged,-                                                  getBuildKeysVisited,-                                                  getStoredKeys,-                                                  getRebuildsCount,-                                                  )-import           Development.IDE.Test.Diagnostic-import           Development.Shake               (CmdOption (Cwd, FileStdout),-                                                  cmd_)-import           Experiments.Types-import           Language.LSP.Test-import           Language.LSP.Types              hiding-                                                 (SemanticTokenAbsolute (length, line),-                                                  SemanticTokenRelative (length),-                                                  SemanticTokensEdit (_start))-import           Language.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)--charEdit :: Position -> TextDocumentContentChangeEvent-charEdit p =-    TextDocumentContentChangeEvent-    { _range = Just (Range p p),-      _rangeLength = Nothing,-      _text = "a"-    }--data DocumentPositions = DocumentPositions {-    identifierP    :: Maybe Position,-    stringLiteralP :: !Position,-    doc            :: !TextDocumentIdentifier-}--allWithIdentifierPos :: Monad m => (DocumentPositions -> m Bool) -> [DocumentPositions] -> m Bool-allWithIdentifierPos f docs = allM f (filter (isJust . identifierP) docs)--experiments :: [Bench]-experiments =-    [ ----------------------------------------------------------------------------------------      bench "hover" $ allWithIdentifierPos $ \DocumentPositions{..} ->-        isJust <$> getHover doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} -> do-          changeDoc doc [charEdit stringLiteralP]-          -- wait for a fresh build start-          waitForProgressStart-        -- wait for the build to be finished-        waitForProgressDone-        return True,-      ----------------------------------------------------------------------------------------      bench "hover after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          isJust <$> getHover doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->-        either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "getDefinition after edit" $ \docs -> do-          forM_ docs $ \DocumentPositions{..} ->-            changeDoc doc [charEdit stringLiteralP]-          flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-            either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do-        fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,-      ----------------------------------------------------------------------------------------      bench "documentSymbols after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allM docs $ \DocumentPositions{..} ->-          either (not . null) (not . null) <$> getDocumentSymbols doc,-      ----------------------------------------------------------------------------------------      bench "completions" $ \docs -> do-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          not . null <$> getCompletions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      bench "completions after edit" $ \docs -> do-        forM_ docs $ \DocumentPositions{..} ->-          changeDoc doc [charEdit stringLiteralP]-        flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-          not . null <$> getCompletions doc (fromJust identifierP),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions"-        ( \docs -> do-            unless (any (isJust . identifierP) docs) $-                error "None of the example modules is suitable for this experiment"-            forM_ docs $ \DocumentPositions{..} -> do-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]-                waitForProgressStart-            waitForProgressDone-        )-        ( \docs -> not . null . catMaybes <$> forM docs (\DocumentPositions{..} ->-            forM identifierP $ \p ->-              getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions after edit"-        ( \docs -> do-            unless (any (isJust . identifierP) docs) $-                error "None of the example modules is suitable for this experiment"-            forM_ docs $ \DocumentPositions{..} ->-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]-        )-        ( \docs -> do-            forM_ docs $ \DocumentPositions{..} -> do-              changeDoc doc [charEdit stringLiteralP]-              waitForProgressStart-            waitForProgressDone-            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do-              forM identifierP $ \p ->-                getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "code actions after cradle edit"-        ( \docs -> do-            forM_ docs $ \DocumentPositions{..} -> do-                forM identifierP $ \p -> do-                    changeDoc doc [charEdit p]-                    waitForProgressStart-            void waitForBuildQueue-        )-        ( \docs -> do-            hieYamlUri <- getDocUri "hie.yaml"-            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"-            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [ FileEvent hieYamlUri FcChanged ]-            waitForProgressStart-            waitForProgressStart-            waitForProgressStart -- the Session logic restarts a second time-            waitForProgressDone-            not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do-              forM identifierP $ \p ->-                getCodeActions doc (Range p p))-        ),-      ----------------------------------------------------------------------------------------      bench-        "hover after cradle edit"-        (\docs -> do-            hieYamlUri <- getDocUri "hie.yaml"-            liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"-            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [ FileEvent hieYamlUri FcChanged ]-            flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)-        ),-      ----------------------------------------------------------------------------------------      benchWithSetup-        "hole fit suggestions"-        ( mapM_ $ \DocumentPositions{..} -> do-            let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent-                  { _range = Just Range {_start = bottom, _end = bottom}-                  , _rangeLength = Nothing, _text = t}-                bottom = Position maxBound 0-                t = T.unlines-                    [""-                    ,"holef :: [Int] -> [Int]"-                    ,"holef = _"-                    ,""-                    ,"holeg :: [()] -> [()]"-                    ,"holeg = _"-                    ]-            changeDoc doc [edit]-        )-        (\docs -> do-            forM_ docs $ \DocumentPositions{..} ->-              changeDoc doc [charEdit stringLiteralP]-            void waitForDiagnostics-            waitForProgressDone-            flip allM docs $ \DocumentPositions{..} -> do-                bottom <- pred . length . T.lines <$> documentContents doc-                diags <- getCurrentDiagnostics doc-                case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of-                    Nothing   -> pure True-                    Just _err -> pure False-        )-    ]-------------------------------------------------------------------------------------------------examplesPath :: FilePath-examplesPath = "bench/example"--defConfig :: Config-Success defConfig = execParserPure defaultPrefs (info configP fullDesc) []--quiet, verbose :: Config -> Bool-verbose = (== All) . verbosity-quiet   = (== Quiet) . verbosity--type HasConfig = (?config :: Config)--configP :: Parser Config-configP =-  Config-    <$> (flag' All (short 'v' <> long "verbose")-         <|> flag' Quiet (short 'q' <> long "quiet")-         <|> pure Normal-        )-    <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))-    <*> optional (strOption (long "ot-profiling" <> metavar "DIR" <> help "Enable OpenTelemetry and write eventlog for each benchmark in DIR"))-    <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)-    <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")-    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))-    <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))-    <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))-    <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")-    <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response")-    <*> ( Example "name"-               <$> (Right <$> packageP)-               <*> (some moduleOption <|> pure ["src/Distribution/Simple.hs"])-               <*> pure []-         <|>-          Example "name"-                <$> (Left <$> pathP)-                <*> some moduleOption-                <*> pure [])-  where-      moduleOption = strOption (long "example-module" <> metavar "PATH")--      packageP = ExamplePackage-            <$> strOption (long "example-package-name" <> value "Cabal")-            <*> option versionP (long "example-package-version" <> value (makeVersion [3,6,0,0]))-      pathP = strOption (long "example-path")--versionP :: ReadM Version-versionP = maybeReader $ extract . readP_to_S parseVersion-  where-      extract parses = listToMaybe [ res | (res,"") <- parses]--output :: (MonadIO m, HasConfig) => String -> m ()-output = if quiet?config then (\_ -> pure ()) else liftIO . putStrLn-------------------------------------------------------------------------------------------type Experiment = [DocumentPositions] -> Session Bool--data Bench =-  Bench-  { name       :: !String,-    enabled    :: !Bool,-    samples    :: !Natural,-    benchSetup :: [DocumentPositions] -> Session (),-    experiment :: Experiment-  }--select :: HasConfig => Bench -> Bool-select Bench {name, enabled} =-  enabled && (null mm || name `elem` mm)-  where-    mm = matches ?config--benchWithSetup ::-  String ->-  ([DocumentPositions] -> Session ()) ->-  Experiment ->-  Bench-benchWithSetup name benchSetup experiment = Bench {..}-  where-    enabled = True-    samples = 100--bench :: String -> Experiment -> Bench-bench name = benchWithSetup name (const $ pure ())--runBenchmarksFun :: HasConfig => FilePath -> [Bench] -> IO ()-runBenchmarksFun dir allBenchmarks = do-  let benchmarks = [ b{samples = fromMaybe 100 (repetitions ?config) }-                   | b <- allBenchmarks-                   , select b ]--  whenJust (otMemoryProfiling ?config) $ \eventlogDir ->-      createDirectoryIfMissing True eventlogDir--  results <- forM benchmarks $ \b@Bench{name} -> do-                let run = runSessionWithConfig conf (cmd name dir) lspTestCaps dir-                (b,) <$> runBench run b--  -- output raw data as CSV-  let headers =-        [ "name"-        , "success"-        , "samples"-        , "startup"-        , "setup"-        , "userTime"-        , "delayedTime"-        , "firstBuildTime"-        , "averageTimePerResponse"-        , "totalTime"-        , "buildRulesBuilt"-        , "buildRulesChanged"-        , "buildRulesVisited"-        , "buildRulesTotal"-        , "buildEdges"-        , "ghcRebuilds"-        ]-      rows =-        [ [ name,-            show success,-            show samples,-            show startup,-            show runSetup',-            show userWaits,-            show delayedWork,-            show $ firstResponse+firstResponseDelayed,-            -- Exclude first response as it has a lot of setup time included-            -- Assume that number of requests = number of modules * number of samples-            show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)),-            show runExperiment,-            show rulesBuilt,-            show rulesChanged,-            show rulesVisited,-            show rulesTotal,-            show edgesTotal,-            show rebuildsTotal-          ]-          | (Bench {name, samples}, BenchRun {..}) <- results,-            let runSetup' = if runSetup < 0.01 then 0 else runSetup-                modules = fromIntegral $ length $ exampleModules $ example ?config-        ]-      csv = unlines $ map (intercalate ", ") (headers : rows)-  writeFile (outputCSV ?config) csv--  -- print a nice table-  let pads = map (maximum . map length) (transpose (headers : rowsHuman))-      paddedHeaders = zipWith pad pads headers-      outputRow = putStrLn . intercalate " | "-      rowsHuman =-        [ [ name,-            show success,-            show samples,-            showDuration startup,-            showDuration runSetup',-            showDuration userWaits,-            showDuration delayedWork,-            showDuration firstResponse,-            showDuration runExperiment,-            show rulesBuilt,-            show rulesChanged,-            show rulesVisited,-            show rulesTotal,-            show edgesTotal,-            show rebuildsTotal-          ]-          | (Bench {name, samples}, BenchRun {..}) <- results,-            let runSetup' = if runSetup < 0.01 then 0 else runSetup-        ]-  outputRow paddedHeaders-  outputRow $ (map . map) (const '-') paddedHeaders-  forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row-  where-    ghcideCmd dir =-        [ ghcide ?config,-          "--lsp",-          "--test",-          "--cwd",-          dir,-          "+RTS"-        ]-    cmd name dir =-      unwords $-            ghcideCmd dir-          ++ case otMemoryProfiling ?config of-            Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]-            Nothing -> []-          ++ [ "-RTS" ]-          ++ ghcideOptions ?config-          ++ concat-            [ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]-            ]-          ++ ["--verbose" | verbose ?config]-          ++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]-    lspTestCaps =-      fullCaps {_window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }-    conf =-      defaultConfig-        { logStdErr = verbose ?config,-          logMessages = verbose ?config,-          logColor = False,-          messageTimeout = timeoutLsp ?config-        }--data BenchRun = BenchRun-  { startup       :: !Seconds,-    runSetup      :: !Seconds,-    runExperiment :: !Seconds,-    userWaits     :: !Seconds,-    delayedWork   :: !Seconds,-    firstResponse :: !Seconds,-    firstResponseDelayed :: !Seconds,-    rulesBuilt    :: !Int,-    rulesChanged  :: !Int,-    rulesVisited  :: !Int,-    rulesTotal    :: !Int,-    edgesTotal    :: !Int,-    rebuildsTotal :: !Int,-    success       :: !Bool-  }--badRun :: BenchRun-badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False--waitForProgressStart :: Session ()-waitForProgressStart = void $ do-    skipManyTill anyMessage $ satisfy $ \case-      FromServerMess SWindowWorkDoneProgressCreate _ -> True-      _                                              -> False---- | Wait for all progress to be done--- Needs at least one progress done notification to return-waitForProgressDone :: Session ()-waitForProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop---- | Wait for the build queue to be empty-waitForBuildQueue :: Session Seconds-waitForBuildQueue = do-    let m = SCustomMethod "test"-    waitId <- sendRequest m (toJSON WaitForShakeQueue)-    (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId-    case resp of-        ResponseMessage{_result=Right Null} -> return td-        -- assume a ghcide binary lacking the WaitForShakeQueue method-        _                                   -> return 0--runBench ::-  (?config :: Config) =>-  (Session BenchRun -> IO BenchRun) ->-  Bench ->-  IO BenchRun-runBench runSess b = handleAny (\e -> print e >> return badRun)-  $ runSess-  $ do-    case b of-     Bench{..} -> do-      (startup, docs) <- duration $ do-        (d, docs) <- duration $ setupDocumentContents ?config-        output $ "Setting up document contents took " <> showDuration d-        -- wait again, as the progress is restarted once while loading the cradle-        -- make an edit, to ensure this doesn't block-        let DocumentPositions{..} = head docs-        changeDoc doc [charEdit stringLiteralP]-        waitForProgressDone-        return docs--      liftIO $ output $ "Running " <> name <> " benchmark"-      (runSetup, ()) <- duration $ benchSetup docs-      let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse)-          loop' timeForFirstResponse !userWaits !delayedWork n = do-            (t, res) <- duration $ experiment docs-            if not res-              then return Nothing-            else do-                output (showDuration t)-                -- Wait for the delayed actions to finish-                td <- waitForBuildQueue-                loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1)-          loop = loop' Nothing--      (runExperiment, result) <- duration $ loop 0 0 samples-      let success = isJust result-          (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result--      rulesTotal <- length <$> getStoredKeys-      rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt-      rulesChanged <- either (const 0) length <$> getBuildKeysChanged-      rulesVisited <- either (const 0) length <$> getBuildKeysVisited-      edgesTotal   <- fromRight 0 <$> getBuildEdgesCount-      rebuildsTotal <- fromRight 0 <$> getRebuildsCount--      return BenchRun {..}--data SetupResult = SetupResult {-    runBenchmarks :: [Bench] -> IO (),-    -- | Path to the setup benchmark example-    benchDir      :: FilePath,-    cleanUp       :: IO ()-}--callCommandLogging :: HasConfig => String -> IO ()-callCommandLogging cmd = do-    output cmd-    callCommand cmd--setup :: HasConfig => IO SetupResult-setup = do---   when alreadyExists $ removeDirectoryRecursive examplesPath-  benchDir <- case exampleDetails(example ?config) of-      Left examplePath -> do-          let hieYamlPath = examplePath </> "hie.yaml"-          alreadyExists <- doesFileExist hieYamlPath-          unless alreadyExists $-                cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)-          return examplePath-      Right ExamplePackage{..} -> do-        let path = examplesPath </> package-            package = packageName <> "-" <> showVersion packageVersion-            hieYamlPath = path </> "hie.yaml"-        alreadySetup <- doesDirectoryExist path-        unless alreadySetup $-          case buildTool ?config of-            Cabal -> do-                let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))-                callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath-                let hieYamlPath = path </> "hie.yaml"-                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String)-                -- Need this in case there is a parent cabal.project somewhere-                writeFile-                    (path </> "cabal.project")-                    "packages: ."-                writeFile-                    (path </> "cabal.project.local")-                    ""-            Stack -> do-                let stackVerbosity = case verbosity ?config of-                        Quiet  -> "--silent"-                        Normal -> ""-                        All    -> "--verbose"-                callCommandLogging $ "stack " <> stackVerbosity <> " 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"]-                            ]-                        )--                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String]-        return path--  whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True--  let cleanUp = case exampleDetails(example ?config) of-        Right _ -> removeDirectoryRecursive examplesPath-        Left _  -> return ()--      runBenchmarks = runBenchmarksFun benchDir--  return SetupResult{..}--setupDocumentContents :: Config -> Session [DocumentPositions]-setupDocumentContents config =-        forM (exampleModules $ example config) $ \m -> do-        doc <- openDoc m "haskell"--        -- Setup the special positions used by the experiments-        lastLine <- fromIntegral . length . T.lines <$> documentContents doc-        changeDoc doc [TextDocumentContentChangeEvent-            { _range = Just (Range (Position lastLine 0) (Position lastLine 0))-            , _rangeLength = Nothing-            , _text = T.unlines [ "_hygienic = \"hygienic\"" ]-            }]-        let-        -- Points to a string in the target file,-        -- convenient for hygienic edits-            stringLiteralP = Position lastLine 15--        -- Find an identifier defined in another file in this project-        symbols <- getDocumentSymbols doc-        let endOfImports = case symbols of-                Left symbols | Just x <- findEndOfImports symbols -> x-                _ -> error $ "symbols: " <> show symbols-        contents <- documentContents doc-        identifierP <- searchSymbol doc contents endOfImports-        return $ DocumentPositions{..}--findEndOfImports :: [DocumentSymbol] -> Maybe Position-findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) =-    Just $ Position (succ $ _line $ _end _range) 4-findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] =-    findEndOfImports cc-findEndOfImports (DocumentSymbol{_range} : _) =-    Just $ _start _range-findEndOfImports _ = Nothing------------------------------------------------------------------------------------------------pad :: Int -> String -> String-pad n []     = replicate n ' '-pad 0 _      = error "pad"-pad n (x:xx) = x : pad (n-1) xx---- | Search for a position where:---     - get definition works and returns a uri other than this file---     - get completions returns a non empty list-searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe Position)-searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do-    -- this search is expensive, so we cache the result on disk-    let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition"-    cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath-    case cachedRes of-        Left _ -> do-            result <- loop pos-            liftIO $ writeFile cachedPath $ show result-            return result-        Right res ->-            return res-  where-      loop pos-        | (fromIntegral $ _line pos) >= lll =-            return Nothing-        | (fromIntegral $ _character pos) >= lengthOfLine (fromIntegral $ _line pos) =-            loop (nextLine pos)-        | otherwise = do-                checks <- checkDefinitions pos &&^ checkCompletions pos-                if checks-                    then return $ Just pos-                    else loop (nextIdent pos)--      nextIdent p = p{_character = _character p + 2}-      nextLine p = Position (_line p + 1) 4--      lengthOfLine n = if n >= lll then 0 else T.length (ll !! n)-      ll = T.lines fileContents-      lll = length ll--      checkDefinitions pos = do-        defs <- getDefinitions doc pos-        case defs of-            (InL [Location uri _]) -> return $ uri /= _uri-            _                      -> return False-      checkCompletions pos =-        not . null <$> getCompletions doc pos-
− bench/lib/Experiments/Types.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE OverloadedStrings  #-}-module Experiments.Types (module Experiments.Types ) where--import           Data.Aeson-import           Data.Maybe                (fromMaybe)-import           Data.Version-import           Development.Shake.Classes-import           GHC.Generics-import           Numeric.Natural--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),-    otMemoryProfiling :: !(Maybe FilePath),-    outputCSV         :: !FilePath,-    buildTool         :: !CabalStack,-    ghcideOptions     :: ![String],-    matches           :: ![String],-    repetitions       :: Maybe Natural,-    ghcide            :: FilePath,-    timeoutLsp        :: Int,-    example           :: Example-  }-  deriving (Eq, Show)--data ExamplePackage = ExamplePackage {packageName :: !String, packageVersion :: !Version}-  deriving (Eq, Generic, Show)-  deriving anyclass (Binary, Hashable, NFData)--data Example = Example-    { exampleName      :: !String-    , exampleDetails   :: Either FilePath ExamplePackage-    , exampleModules   :: [FilePath]-    , exampleExtraArgs :: [String]}-  deriving (Eq, Generic, Show)-  deriving anyclass (Binary, Hashable, NFData)--instance FromJSON Example where-    parseJSON = withObject "example" $ \x -> do-        exampleName <- x .: "name"-        exampleModules <- x .: "modules"-        exampleExtraArgs <- fromMaybe [] <$> x .:? "extra-args"--        path <- x .:? "path"-        case path of-            Just examplePath -> do-                let exampleDetails = Left examplePath-                return Example{..}-            Nothing -> do-                packageName <- x .: "package"-                packageVersion <- x .: "version"-                let exampleDetails = Right ExamplePackage{..}-                return Example{..}--exampleToOptions :: Example -> [String] -> [String]-exampleToOptions Example{exampleDetails = Right ExamplePackage{..}, ..} extraArgs =-    ["--example-package-name", packageName-    ,"--example-package-version", showVersion packageVersion-    ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs-    ] ++-    ["--example-module=" <> m | m <- exampleModules]-exampleToOptions Example{exampleDetails = Left examplePath, ..} extraArgs =-    ["--example-path", examplePath-    ,"--ghcide-options", unwords $ exampleExtraArgs ++ extraArgs-    ] ++-    ["--example-module=" <> m | m <- exampleModules]
exe/Arguments.hs view
@@ -15,10 +15,12 @@     ,argsOTMemoryProfiling          :: Bool     ,argsTesting                    :: Bool     ,argsDisableKick                :: Bool+    ,argsVerifyCoreFile             :: Bool     ,argsThreads                    :: Int     ,argsVerbose                    :: Bool     ,argsCommand                    :: Command     ,argsConservativeChangeTracking :: Bool+    ,argsMonitoringPort             :: Int     }  getArguments :: IdePlugins IdeState -> IO Arguments@@ -36,10 +38,12 @@       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")       <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")+      <*> switch (long "verify-core-file" <> help "Verify core trips by roundtripping after serialization. Slow, only useful for testing purposes")       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")       <*> (commandP plugins <|> lspCommand <|> checkCommand)       <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")+      <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)")       where           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")
exe/Main.hs view
@@ -5,43 +5,50 @@  module Main(main) where -import           Arguments                         (Arguments (..),-                                                    getArguments)-import           Control.Monad.Extra               (unless)-import           Control.Monad.IO.Class            (liftIO)-import           Data.Default                      (def)-import           Data.Function                     ((&))-import           Data.Version                      (showVersion)-import           Development.GitRev                (gitHash)-import           Development.IDE                   (action)-import           Development.IDE.Core.OfInterest   (kick)-import           Development.IDE.Core.Rules        (mainRule)-import qualified Development.IDE.Core.Rules        as Rules-import           Development.IDE.Core.Tracing      (withTelemetryLogger)-import qualified Development.IDE.Main              as IDEMain-import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde-import           Development.IDE.Types.Logger      (Logger (Logger),-                                                    LoggingColumn (DataColumn, PriorityColumn),-                                                    Pretty (pretty),-                                                    Priority (Debug, Info, Error),-                                                    Recorder (Recorder),-                                                    WithPriority (WithPriority, priority),-                                                    cfilter, cmapWithPrio,-                                                    makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions)-import qualified Development.IDE.Types.Logger      as Logger+import           Arguments                                (Arguments (..),+                                                           getArguments)+import           Control.Monad.Extra                      (unless)+import           Control.Monad.IO.Class                   (liftIO)+import           Data.Default                             (def)+import           Data.Function                            ((&))+import           Data.Version                             (showVersion)+import           Development.GitRev                       (gitHash)+import           Development.IDE                          (action)+import           Development.IDE.Core.OfInterest          (kick)+import           Development.IDE.Core.Rules               (mainRule)+import qualified Development.IDE.Core.Rules               as Rules+import           Development.IDE.Core.Tracing             (withTelemetryLogger)+import qualified Development.IDE.Main                     as IDEMain+import qualified Development.IDE.Monitoring.EKG           as EKG+import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry+import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde+import           Development.IDE.Types.Logger             (Logger (Logger),+                                                           LoggingColumn (DataColumn, PriorityColumn),+                                                           Pretty (pretty),+                                                           Priority (Debug, Error, Info),+                                                           WithPriority (WithPriority, priority),+                                                           cfilter,+                                                           cmapWithPrio,+                                                           defaultLayoutOptions,+                                                           layoutPretty,+                                                           makeDefaultStderrRecorder,+                                                           renderStrict)+import qualified Development.IDE.Types.Logger             as Logger import           Development.IDE.Types.Options-import           GHC.Stack                         (emptyCallStack)-import           Language.LSP.Server               as LSP-import           Language.LSP.Types                as LSP-import           Ide.Plugin.Config                 (Config (checkParents, checkProject))-import           Ide.PluginUtils                   (pluginDescToIdePlugins)-import           Ide.Types                         (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)-import           Paths_ghcide                      (version)-import qualified System.Directory.Extra            as IO-import           System.Environment                (getExecutablePath)-import           System.Exit                       (exitSuccess)-import           System.IO                         (hPutStrLn, stderr)-import           System.Info                       (compilerVersion)+import           GHC.Stack                                (emptyCallStack)+import           Ide.Plugin.Config                        (Config (checkParents, checkProject))+import           Ide.PluginUtils                          (pluginDescToIdePlugins)+import           Ide.Types                                (PluginDescriptor (pluginNotificationHandlers),+                                                           defaultPluginDescriptor,+                                                           mkPluginNotificationHandler)+import           Language.LSP.Server                      as LSP+import           Language.LSP.Types                       as LSP+import           Paths_ghcide                             (version)+import qualified System.Directory.Extra                   as IO+import           System.Environment                       (getExecutablePath)+import           System.Exit                              (exitSuccess)+import           System.Info                              (compilerVersion)+import           System.IO                                (hPutStrLn, stderr)  data Log   = LogIDEMain IDEMain.Log@@ -141,5 +148,7 @@                 , optCheckParents = pure $ checkParents config                 , optCheckProject = pure $ checkProject config                 , optRunSubset = not argsConservativeChangeTracking+                , optVerifyCoreFile = argsVerifyCoreFile                 }+        , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort         }
ghcide.cabal view
@@ -1,8 +1,8 @@-cabal-version:      2.4+cabal-version:      3.0 build-type:         Simple category:           Development name:               ghcide-version:            1.7.0.0+version:            1.8.0.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/haskell-language-server/tree/master/ghcide#readme bug-reports:        https://github.com/haskell/haskell-language-server/issues-tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 || == 9.2.2+tested-with:        GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 extra-source-files: README.md CHANGELOG.md                     test/data/**/*.project                     test/data/**/*.cabal@@ -30,6 +30,11 @@     default:     False     manual:      True +flag ekg+    description: Enable EKG monitoring of the build graph and other metrics on port 8999+    default:     False+    manual:      True+ library     default-language:   Haskell2010     build-depends:@@ -41,6 +46,7 @@         binary,         bytestring,         case-insensitive,+        co-log-core,         containers,         data-default,         deepseq,@@ -54,32 +60,28 @@         filepath,         fingertree,         focus,-        ghc-exactprint,         ghc-trace-events,         Glob,         haddock-library >= 1.8 && < 1.11,         hashable,-        hie-compat ^>= 0.2.0.0,-        hls-plugin-api ^>= 1.4,+        hie-compat ^>= 0.3.0.0,+        hls-plugin-api ^>= 1.5,         lens,         list-t,-        hiedb == 0.4.1.*,-        lsp-types ^>= 1.4.0.1,-        lsp ^>= 1.4.0.0 ,+        hiedb == 0.4.2.*,+        lsp-types ^>= 1.6.0.0,+        lsp ^>= 1.6.0.0 ,         monoid-subclasses,         mtl,-        network-uri,         optparse-applicative,         parallel,         prettyprinter-ansi-terminal,-        prettyprinter,+        prettyprinter >= 1.6,         random,         regex-tdfa >= 1.3.1.0,-        retrie,-        rope-utf16-splay,-        safe,+        text-rope,         safe-exceptions,-        hls-graph ^>= 1.7,+        hls-graph ^>= 1.8,         sorted-list,         sqlite-simple,         stm,@@ -89,23 +91,21 @@         time,         transformers,         unordered-containers >= 0.2.10.0,-        utf8-string,         vector,-        vector-algorithms,         hslogger,         Diff ^>=0.4.0,         vector,         opentelemetry >=0.6.1,         heapsize ==0.3.*,-        unliftio,+        unliftio >= 0.2.6,         unliftio-core,         ghc-boot-th,         ghc-boot,         ghc >= 8.6,-        ghc-check >=0.5.0.4,+        ghc-check >=0.5.0.8,         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,-        hie-bios ^>= 0.9.1,+        hie-bios ^>= 0.11.0,         implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5,         base16-bytestring >=0.1.1 && <1.1     if os(windows)@@ -163,7 +163,6 @@         Development.IDE.GHC.Compat         Development.IDE.GHC.Compat.Core         Development.IDE.GHC.Compat.Env-        Development.IDE.GHC.Compat.ExactPrint         Development.IDE.GHC.Compat.Iface         Development.IDE.GHC.Compat.Logger         Development.IDE.GHC.Compat.Outputable@@ -172,15 +171,16 @@         Development.IDE.GHC.Compat.Units         Development.IDE.GHC.Compat.Util         Development.IDE.Core.Compile-        Development.IDE.GHC.Dump+        Development.IDE.GHC.CoreFile         Development.IDE.GHC.Error-        Development.IDE.GHC.ExactPrint         Development.IDE.GHC.Orphans         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation         Development.IDE.Import.FindImports+        Development.IDE.Monitoring.EKG         Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.LanguageServer+        Development.IDE.LSP.Notifications         Development.IDE.LSP.Outline         Development.IDE.LSP.Server         Development.IDE.Session@@ -195,13 +195,13 @@         Development.IDE.Types.KnownTargets         Development.IDE.Types.Location         Development.IDE.Types.Logger+        Development.IDE.Types.Monitoring+        Development.IDE.Monitoring.OpenTelemetry         Development.IDE.Types.Options         Development.IDE.Types.Shake         Development.IDE.Plugin         Development.IDE.Plugin.Completions         Development.IDE.Plugin.Completions.Types-        Development.IDE.Plugin.CodeAction-        Development.IDE.Plugin.CodeAction.ExactPrint         Development.IDE.Plugin.HLS         Development.IDE.Plugin.HLS.GhcIde         Development.IDE.Plugin.Test@@ -212,9 +212,6 @@         Development.IDE.Core.FileExists         Development.IDE.GHC.CPP         Development.IDE.GHC.Warnings-        Development.IDE.LSP.Notifications-        Development.IDE.Plugin.CodeAction.PositionIndexed-        Development.IDE.Plugin.CodeAction.Args         Development.IDE.Plugin.Completions.Logic         Development.IDE.Session.VersionCheck         Development.IDE.Types.Action@@ -233,6 +230,12 @@       exposed-modules:         Development.IDE.GHC.Compat.CPP +    if flag(ekg)+        build-depends:+            ekg-wai,+            ekg-core,+        cpp-options:   -DMONITORING_EKG+ flag test-exe     description: Build the ghcide-test-preprocessor executable     default: True@@ -248,45 +251,6 @@     if !flag(test-exe)         buildable: False -benchmark benchHist-    type: exitcode-stdio-1.0-    default-language: Haskell2010-    ghc-options: -Wall -Wno-name-shadowing -threaded-    main-is: Main.hs-    hs-source-dirs: bench/hist bench/lib-    other-modules: Experiments.Types-    build-tool-depends:-        ghcide:ghcide-bench,-        hp2pretty:hp2pretty,-        implicit-hie:gen-hie-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns--    build-depends:-        aeson,-        base == 4.*,-        shake-bench == 0.1.*,-        directory,-        extra,-        filepath,-        lens,-        optparse-applicative,-        shake,-        text,-        yaml- flag executable     description: Build the ghcide executable     default: True@@ -353,6 +317,11 @@      if !flag(executable)         buildable: False+    if flag(ekg)+        build-depends:+            ekg-wai,+            ekg-core,+        cpp-options:   -DMONITORING_EKG  test-suite ghcide-tests     type: exitcode-stdio-1.0@@ -365,8 +334,6 @@         aeson,         async,         base,-        binary,-        bytestring,         containers,         data-default,         directory,@@ -382,8 +349,6 @@         ghc,         --------------------------------------------------------------         ghcide,-        ghc-typelits-knownnat,-        haddock-library,         lsp,         lsp-types,         hls-plugin-api,@@ -392,98 +357,37 @@         lsp-test ^>= 0.14,         monoid-subclasses,         network-uri,-        optparse-applicative,-        parallel,-        process,         QuickCheck,-        quickcheck-instances,         random,-        rope-utf16-splay,         regex-tdfa ^>= 1.3.1,-        safe,-        safe-exceptions,         shake,         sqlite-simple,         stm,         stm-containers,-        hls-graph,         tasty,         tasty-expected-failure,-        tasty-hunit,+        tasty-hunit >= 0.10,         tasty-quickcheck,         tasty-rerun,         text,+        text-rope,         unordered-containers,-        vector,     if (impl(ghc >= 8.6) && impl(ghc < 9.2))       build-depends:           record-dot-preprocessor,           record-hasfield-    hs-source-dirs: test/cabal test/exe test/src bench/lib+    if impl(ghc < 9.3)+       build-depends:  ghc-typelits-knownnat+    hs-source-dirs: test/cabal test/exe test/src     ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors     main-is: Main.hs     other-modules:-        Development.IDE.Test-        Development.IDE.Test.Diagnostic         Development.IDE.Test.Runfiles-        Experiments-        Experiments.Types         FuzzySearch         Progress         HieDbRetry-    default-extensions:-        BangPatterns-        DeriveFunctor-        DeriveGeneric-        FlexibleContexts-        GeneralizedNewtypeDeriving-        LambdaCase-        NamedFieldPuns-        OverloadedStrings-        RecordWildCards-        ScopedTypeVariables-        StandaloneDeriving-        TupleSections-        TypeApplications-        ViewPatterns--flag bench-exe-    description: Build the ghcide-bench executable-    default: True--executable ghcide-bench-    default-language: Haskell2010-    build-tool-depends:-        ghcide:ghcide-    build-depends:-        aeson,-        base,-        bytestring,-        containers,-        data-default,-        directory,-        extra,-        filepath,-        ghcide,-        hls-plugin-api,-        lens,-        lsp-test,-        lsp-types,-        optparse-applicative,-        process,-        safe-exceptions,-        hls-graph,-        shake,-        tasty-hunit,-        text-    hs-source-dirs: bench/lib bench/exe test/src-    ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts-    main-is: Main.hs-    other-modules:         Development.IDE.Test         Development.IDE.Test.Diagnostic-        Experiments-        Experiments.Types     default-extensions:         BangPatterns         DeriveFunctor@@ -499,6 +403,3 @@         TupleSections         TypeApplications         ViewPatterns--    if !flag(bench-exe)-        buildable: False
session-loader/Development/IDE/Session.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE CPP                       #-}  {-| The logic for setting up a ghcide session by tapping into hie-bios.@@ -36,8 +37,8 @@ import           Data.Default import           Data.Either.Extra import           Data.Function-import qualified Data.HashMap.Strict                  as HM import           Data.Hashable+import qualified Data.HashMap.Strict                  as HM import           Data.IORef import           Data.List import qualified Data.Map.Strict                      as Map@@ -67,12 +68,14 @@                                                        Priority (Debug, Error, Info, Warning),                                                        Recorder, WithPriority,                                                        logWith, nest, vcat,-                                                       viaShow, (<+>))+                                                       viaShow, (<+>),+                                                       toCologActionWithPrio, cmapWithPrio) import           Development.IDE.Types.Options import           GHC.Check import qualified HIE.Bios                             as HieBios+import qualified HIE.Bios.Types                       as HieBios import           HIE.Bios.Environment                 hiding (getCacheDir)-import           HIE.Bios.Types+import           HIE.Bios.Types                       hiding (Log) import           Hie.Implicit.Cradle                  (loadImplicitHieCradle) import           Language.LSP.Server import           Language.LSP.Types@@ -87,6 +90,7 @@ import           Control.Concurrent.STM.Stats         (atomically, modifyTVar',                                                        readTVar, writeTVar) import           Control.Concurrent.STM.TQueue+import           Control.Monad.IO.Unlift              (MonadUnliftIO) import           Data.Foldable                        (for_) import           Data.HashMap.Strict                  (HashMap) import           Data.HashSet                         (HashSet)@@ -97,9 +101,11 @@ import           HieDb.Create import           HieDb.Types import           HieDb.Utils-import           System.Random                        (RandomGen) import qualified System.Random                        as Random+import           System.Random                        (RandomGen) import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Exception (evaluate)+import Control.DeepSeq  data Log   = LogSettingInitialDynFlags@@ -119,6 +125,7 @@   | LogCradle !(Cradle Void)   | LogNoneCradleFound FilePath   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)+  | LogHieBios HieBios.Log deriving instance Show Log  instance Pretty Log where@@ -188,6 +195,7 @@       "Cradle:" <+> viaShow cradle     LogNewComponentCache componentCache ->       "New component cache HscEnvEq:" <+> viaShow componentCache+    LogHieBios log -> pretty log  -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String@@ -208,11 +216,13 @@   , getCacheDirs           :: String -> [String] -> IO CacheDirs   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'   , getInitialGhcLibDir    :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir)+#if !MIN_VERSION_ghc(9,3,0)   , fakeUid                :: UnitId     -- ^ unit id used to tag the internal component built by ghcide     --   To reuse external interface files the unit ids must match,     --   thus make sure to build them with `--this-unit-id` set to the     --   same value as the ghcide fake uid+#endif   }  instance Default SessionLoadingOptions where@@ -221,7 +231,9 @@         ,loadCradle = loadWithImplicitCradle         ,getCacheDirs = getCacheDirsDefault         ,getInitialGhcLibDir = getInitialGhcLibDirDefault+#if !MIN_VERSION_ghc(9,3,0)         ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main")+#endif         }  -- | Find the cradle for a given 'hie.yaml' configuration.@@ -494,7 +506,11 @@               new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do                   -- Remove all inplace dependencies from package flags for                   -- components in this HscEnv+#if MIN_VERSION_ghc(9,3,0)+                  let (df2, uids) = (rawComponentDynFlags, [])+#else                   let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags+#endif                   let prefix = show rawComponentUnitId                   -- See Note [Avoiding bad interface files]                   let hscComponents = sort $ map show uids@@ -517,10 +533,14 @@               -- that I do not fully understand               log Info $ LogMakingNewHscEnv inplace               hscEnv <- emptyHscEnv ideNc libDir-              newHscEnv <-+              !newHscEnv <-                 -- Add the options for the current component to the HscEnv                 evalGhcEnv hscEnv $ do-                  _ <- setSessionDynFlags $ setHomeUnitId_ fakeUid df+                  _ <- setSessionDynFlags+#if !MIN_VERSION_ghc(9,3,0)+                          $ setHomeUnitId_ fakeUid+#endif+                          df                   getSession                -- Modify the map so the hieYaml now maps to the newly created@@ -700,7 +720,8 @@     --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"     -- Start off by getting the session options     logWith recorder Debug $ LogCradle cradle-    cradleRes <- HieBios.getCompilerOptions file cradle+    let logger = toCologActionWithPrio $ cmapWithPrio LogHieBios recorder+    cradleRes <- HieBios.getCompilerOptions logger file cradle     case cradleRes of         CradleSuccess r -> do             -- Now get the GHC lib dir@@ -718,7 +739,11 @@             logWith recorder Info $ LogNoneCradleFound file             return (Left []) +#if MIN_VERSION_ghc(9,3,0)+emptyHscEnv :: NameCache -> FilePath -> IO HscEnv+#else emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv+#endif emptyHscEnv nc libDir = do     env <- runGhc (Just libDir) getSession     initDynLinker env@@ -757,7 +782,11 @@     [ (l, (targetEnv, targetDepends)) | l <-  targetLocations]  +#if MIN_VERSION_ghc(9,3,0)+setNameCache :: NameCache -> HscEnv -> HscEnv+#else setNameCache :: IORef NameCache -> HscEnv -> HscEnv+#endif setNameCache nc hsc = hsc { hsc_NC = nc }  -- | Create a mapping from FilePaths to HscEnvEqs@@ -773,6 +802,11 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do     let df = componentDynFlags ci     hscEnv' <-+#if MIN_VERSION_ghc(9,3,0)+      -- Set up a multi component session with the other units on GHC 9.4+        Compat.initUnits (map snd uids) (hscSetFlags df hsc_env)+#elif MIN_VERSION_ghc(9,2,0)+      -- This initializes the units for GHC 9.2       -- Add the options for the current component to the HscEnv       -- We want to call `setSessionDynFlags` instead of `hscSetFlags`       -- because `setSessionDynFlags` also initializes the package database,@@ -782,7 +816,10 @@       evalGhcEnv hsc_env $ do         _ <- setSessionDynFlags $ df         getSession-+#else+      -- getOptions is enough to initialize units on GHC <9.2+      pure $ hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }+#endif      let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath     henv <- newFunc hscEnv' uids@@ -790,6 +827,7 @@         targetDepends = componentDependencyInfo ci         res = (targetEnv, targetDepends)     logWith recorder Debug $ LogNewComponentCache res+    evaluate $ liftRnf rwhnf $ componentTargets ci      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends     ctargets <- concatMapM mk (componentTargets ci)@@ -998,9 +1036,11 @@     -- initPackages parses the -package flags and     -- sets up the visibility for each component.     -- Throws if a -package flag cannot be satisfied.-    env <- hscSetFlags dflags'' <$> getSession-    final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env-    return (hsc_dflags final_env', targets)+    -- This only works for GHC <9.2+    -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which+    -- is done later in newComponentCache+    final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags''+    return (final_flags, targets)  setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df =
session-loader/Development/IDE/Session/VersionCheck.hs view
@@ -5,13 +5,11 @@ -- See https://github.com/haskell/ghcide/pull/697 module Development.IDE.Session.VersionCheck (ghcVersionChecker) where -import           Data.Maybe import           GHC.Check -- Only use this for checking against the compile time GHC libDir! -- Use getRuntimeGhcLibDir from hie-bios instead for everything else -- otherwise binaries will not be distributable since paths will be baked into them import qualified GHC.Paths-import           System.Environment  ghcVersionChecker :: GhcVersionChecker-ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))+ghcVersionChecker = $$(makeGhcVersionChecker (return GHC.Paths.libdir))
src/Development/IDE.hs view
@@ -16,15 +16,16 @@ import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),                                                              isWorkspaceFile) import           Development.IDE.Core.OfInterest       as X (getFilesOfInterestUntracked)-import           Development.IDE.Core.RuleTypes        as X import           Development.IDE.Core.Rules            as X (getClientConfigAction,                                                              getParsedModule)+import           Development.IDE.Core.RuleTypes        as X import           Development.IDE.Core.Service          as X (runAction) import           Development.IDE.Core.Shake            as X (FastResult (..),                                                              IdeAction (..),                                                              IdeRule, IdeState,                                                              RuleBody (..),                                                              ShakeExtras,+                                                             VFSModified (..),                                                              actionLogger,                                                              define,                                                              defineEarlyCutoff,@@ -40,8 +41,7 @@                                                              useWithStaleFast,                                                              useWithStaleFast',                                                              useWithStale_,-                                                             use_, uses, uses_,-                                                             VFSModified(..))+                                                             use_, uses, uses_) import           Development.IDE.GHC.Compat            as X (GhcVersion (..),                                                              ghcVersion) import           Development.IDE.GHC.Error             as X
src/Development/IDE/Core/Compile.hs view
@@ -31,41 +31,46 @@   , getDocsBatch   , lookupName   , mergeEnvs+  , ml_core_file+  , coreFileToLinkable+  , TypecheckHelpers(..)   ) where  import           Control.Concurrent.Extra import           Control.Concurrent.STM.Stats      hiding (orElse)-import           Control.DeepSeq                   (force, liftRnf, rnf, rwhnf)+import           Control.DeepSeq                   (NFData (..), force, liftRnf,+                                                    rnf, rwhnf) import           Control.Exception                 (evaluate) import           Control.Exception.Safe-import           Control.Lens                      hiding (List)+import           Control.Lens                      hiding (List, (<.>)) import           Control.Monad.Except import           Control.Monad.Extra import           Control.Monad.Trans.Except+import qualified Control.Monad.Trans.State.Strict  as S import           Data.Aeson                        (toJSON) import           Data.Bifunctor                    (first, second) import           Data.Binary-import qualified Data.Binary                       as B import qualified Data.ByteString                   as BS-import qualified Data.ByteString.Lazy              as LBS import           Data.Coerce import qualified Data.DList                        as DL import           Data.Functor+import           Data.Generics.Aliases+import           Data.Generics.Schemes import qualified Data.HashMap.Strict               as HashMap-import           Data.IORef import           Data.IntMap                       (IntMap) import qualified Data.IntMap.Strict                as IntMap+import           Data.IORef import           Data.List.Extra import           Data.Map                          (Map) import qualified Data.Map.Strict                   as Map+import qualified Data.Set                          as Set import           Data.Maybe import qualified Data.Text                         as T-import           Data.Time                         (UTCTime (..),-                                                    getCurrentTime)-import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)+import           Data.Time                         (UTCTime (..)) import           Data.Tuple.Extra                  (dupe) import           Data.Unique                       as Unique import           Debug.Trace+import           Development.IDE.Core.FileStore    (resetInterfaceStore) import           Development.IDE.Core.Preprocessor import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake@@ -76,17 +81,17 @@ import qualified Development.IDE.GHC.Compat        as Compat import qualified Development.IDE.GHC.Compat        as GHC import qualified Development.IDE.GHC.Compat.Util   as Util+import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Error import           Development.IDE.GHC.Orphans       () import           Development.IDE.GHC.Util import           Development.IDE.GHC.Warnings-import           Development.IDE.Spans.Common import           Development.IDE.Types.Diagnostics import           Development.IDE.Types.Location import           Development.IDE.Types.Options import           GHC                               (ForeignHValue,                                                     GetDocsFailure (..),-                                                    mgModSummaries,+                                                    GhcException (..),                                                     parsedSource) import qualified GHC.LanguageExtensions            as LangExt import           GHC.Serialized@@ -105,17 +110,27 @@  #if MIN_VERSION_ghc(9,0,1) import           GHC.Tc.Gen.Splice++#if MIN_VERSION_ghc(9,2,1)+import           GHC.Types.ForeignStubs+import           GHC.Types.HpcInfo+import           GHC.Types.TypeEnv #else+import           GHC.Driver.Types+#endif++#else+import           HscTypes import           TcSplice #endif  #if MIN_VERSION_ghc(9,2,0)-import           Development.IDE.GHC.Compat.Util   (emptyUDFM, fsLit,-                                                    plusUDFM_C) import           GHC                               (Anchor (anchor),                                                     EpaComment (EpaComment),                                                     EpaCommentTok (EpaBlockComment, EpaLineComment),-                                                    epAnnComments,+                                                    ModuleGraph, epAnnComments,+                                                    mgLookupModule,+                                                    mgModSummaries,                                                     priorComments) import qualified GHC                               as G import           GHC.Hs                            (LEpaComment)@@ -147,12 +162,18 @@             T.pack $ "unknown package: " ++ show pkg]         Just pkgInfo -> return $ Right $ unitDepends pkgInfo +data TypecheckHelpers+  = TypecheckHelpers+  { getLinkablesToKeep :: !(IO (ModuleEnv UTCTime))+  , getLinkables       :: !([NormalizedFilePath] -> IO [LinkableResult])+  }+ typecheckModule :: IdeDefer                 -> HscEnv-                -> ModuleEnv UTCTime -- ^ linkables not to unload+                -> TypecheckHelpers                 -> ParsedModule                 -> IO (IdeResult TcModuleResult)-typecheckModule (IdeDefer defer) hsc keep_lbls pm = do+typecheckModule (IdeDefer defer) hsc tc_helpers pm = do         let modSummary = pm_mod_summary pm             dflags = ms_hspp_opts modSummary         mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"@@ -167,7 +188,7 @@                   mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}                 in                   catchSrcErrors (hsc_dflags hsc) "typecheck" $ do-                    tcRnModule session keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''}+                    tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}             let errorPipeline = unDefer . hideDiag dflags . tagDiag                 diags = map errorPipeline warnings                 deferedError = any fst diags@@ -178,16 +199,16 @@         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id  -- | Install hooks to capture the splices as well as the runtime module dependencies-captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName)-captureSplicesAndDeps env k = do+captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString)+captureSplicesAndDeps TypecheckHelpers{..} env k = do   splice_ref <- newIORef mempty-  dep_ref <- newIORef emptyUniqSet+  dep_ref <- newIORef emptyModuleEnv   res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env)   splices <- readIORef splice_ref   needed_mods <- readIORef dep_ref   return (res, splices, needed_mods)   where-    addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks+    addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks     addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) }      -- We want to record exactly which linkables/modules the typechecker needed at runtime@@ -200,12 +221,12 @@     -- names in the compiled bytecode, recording the modules that those names     -- come from in the IORef,, as these are the modules on whose implementation     -- we depend.-    ---    -- Only compute direct dependencies instead of transitive dependencies.-    -- It is much cheaper to store the direct dependencies, we can compute-    -- the transitive ones when required.-    -- Also only record dependencies from the home package-    compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+    compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr+#if MIN_VERSION_ghc(9,3,0)+                     -> IO (ForeignHValue, [Linkable], PkgsLoaded)+#else+                     -> IO ForeignHValue+#endif     compile_bco_hook var hsc_env srcspan ds_expr       = do { let dflags = hsc_dflags hsc_env @@ -226,13 +247,21 @@            ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file   = Nothing,                                         ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",                                         ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }+#if MIN_VERSION_ghc(9,3,0)+                                        ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file",+                                        ml_dyn_hi_file  = panic "hscCompileCoreExpr':ml_dyn_hi_file",+#endif+                                        ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file"+                                        }            ; let ictxt = hsc_IC hsc_env             ; (binding_id, stg_expr, _, _) <-                myCoreToStgExpr (hsc_logger hsc_env)                                (hsc_dflags hsc_env)                                ictxt+#if MIN_VERSION_ghc(9,3,0)+                               True -- for bytecode+#endif                                (icInteractiveModule ictxt)                                iNTERACTIVELoc                                prepd_expr@@ -242,42 +271,117 @@                        (icInteractiveModule ictxt)                        stg_expr                        [] Nothing-           ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos-                                         , Just mod <- [nameModule_maybe n] -- Names from other modules-                                         , not (isWiredInName n) -- Exclude wired-in names-                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package-                                         ]+#else+             {- Convert to BCOs -}+           ; bcos <- coreExprToBCOs hsc_env+                       (icInteractiveModule (hsc_IC hsc_env)) prepd_expr+#endif+             -- Exclude wired-in names because we may not have read             -- their interface files, so getLinkDeps will fail             -- All wired-in names are in the base package, which we link             -- by default, so we can safely ignore them here. -             {- load it -}-           ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos-           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)+            -- Find the linkables for the modules we need+           ; let needed_mods = mkUniqSet [+#if MIN_VERSION_ghc(9,3,0)+                                           mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids #else-             {- Convert to BCOs -}-           ; bcos <- coreExprToBCOs hsc_env-                       (icInteractiveModule (hsc_IC hsc_env)) prepd_expr+                                           moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same+#endif -           ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)+#if MIN_VERSION_ghc(9,2,0)+                                         | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos+#else+                                         | n <- uniqDSetToList (bcoFreeNames bcos)+#endif                                          , Just mod <- [nameModule_maybe n] -- Names from other modules                                          , not (isWiredInName n) -- Exclude wired-in names-                                         , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package+                                         , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set                                          ]-            -- Exclude wired-in names because we may not have read-            -- their interface files, so getLinkDeps will fail-            -- All wired-in names are in the base package, which we link-            -- by default, so we can safely ignore them here.+                 home_unit_ids =+#if MIN_VERSION_ghc(9,3,0)+                    map fst (hugElts $ hsc_HUG hsc_env)+#else+                    [homeUnitId_ dflags]+#endif+                 mods_transitive = getTransitiveMods hsc_env needed_mods +                 -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same+                 mods_transitive_list = +#if MIN_VERSION_ghc(9,3,0)+                                         mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive+#else+                                        -- Non det OK as we will put it into maps later anyway+                                         map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive+#endif++#if MIN_VERSION_ghc(9,3,0)+           ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env)+#else+           ; moduleLocs <- readIORef (hsc_FC hsc_env)+#endif+           ; lbs <- getLinkables [toNormalizedFilePath' file+                                 | mod <- mods_transitive_list+                                 , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod+                                       file = case ifr of+                                         InstalledFound loc _ ->+                                           fromJust $ ml_hs_file loc+                                         _ -> panic "hscCompileCoreExprHook: module not found"+                                 ]+           ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env++             -- Essential to do this here after we load the linkables+           ; keep_lbls <- getLinkablesToKeep++           ; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls++#if MIN_VERSION_ghc(9,3,0)+             {- load it -}+           ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos+           ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs)+#elif MIN_VERSION_ghc(9,2,0)+             {- load it -}+           ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos+           ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)+#else              {- link it -}-           ; hval <- linkExpr hsc_env srcspan bcos+           ; hval <- linkExpr hsc_env' srcspan bcos #endif -           ; modifyIORef' var (unionUniqSets needed_mods)+           ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb])            ; return hval } +#if MIN_VERSION_ghc(9,3,0)+    -- TODO: support backpack+    nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule+    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod+    nodeKeyToInstalledModule _ = Nothing+    moduleToNodeKey :: Module -> NodeKey+    moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)+#endif +    -- Compute the transitive set of linkables required+    getTransitiveMods hsc_env needed_mods +#if MIN_VERSION_ghc(9,3,0)+      = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods+                                                              , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))]+                                                              ])+      where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after+#else+      = go emptyUniqSet needed_mods+      where+        hpt = hsc_HPT hsc_env+        go seen new+          | isEmptyUniqSet new = seen+          | otherwise = go seen' new'+            where+              seen' = seen `unionUniqSets` new+              new'  = new_deps `minusUniqSet` seen'+              new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info+                                           | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]+#endif+     -- | Add a Hook to the DynFlags which captures and returns the     -- typechecked splices before they are run. This information     -- is used for hover.@@ -310,18 +414,15 @@  tcRnModule   :: HscEnv-  -> ModuleEnv UTCTime -- ^ Program linkables not to unload+  -> TypecheckHelpers -- ^ Program linkables not to unload   -> ParsedModule   -> IO TcModuleResult-tcRnModule hsc_env keep_lbls pmod = do+tcRnModule hsc_env tc_helpers pmod = do   let ms = pm_mod_summary pmod       hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env-      hpt = hsc_HPT hsc_env -  unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls--  ((tc_gbl_env', mrn_info), splices, mods)-      <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp ->+  ((tc_gbl_env', mrn_info), splices, mod_env)+      <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp ->              do  hscTypecheckRename hsc_env_tmp ms $                           HsParsedModule { hpm_module = parsedSource pmod,                                            hpm_src_files = pm_extra_src_files pmod,@@ -330,25 +431,8 @@         Just x  -> x         Nothing -> error "no renamed info tcRnModule" -      -- Compute the transitive set of linkables required-      mods_transitive = go emptyUniqSet mods-        where-          go seen new-            | isEmptyUniqSet new = seen-            | otherwise = go seen' new'-              where-                seen' = seen `unionUniqSets` new-                new'  = new_deps `minusUniqSet` seen'-                new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info-                                             | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)]--      -- The linkables we depend on at runtime are the transitive closure of 'mods'-      -- restricted to the home package-      -- See Note [Recompilation avoidance in the presence of TH]-      mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported-       -- Serialize mod_env so we can read it from the interface-      mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time))+      mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)                          (moduleEnvToList mod_env)       tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }   pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)@@ -360,52 +444,128 @@       tcGblEnv = tmrTypechecked tcm   details <- makeSimpleDetails hsc_env_tmp tcGblEnv   sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv-#if MIN_VERSION_ghc(8,10,0)-  iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv-#else-  (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv-#endif-  let mod_info = HomeModInfo iface details Nothing-  pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)+  iface <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv+  pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing  mkHiFileResultCompile-    :: HscEnv+    :: ShakeExtras+    -> HscEnv     -> TcModuleResult     -> ModGuts-    -> LinkableType -- ^ use object code or byte code?     -> IO (IdeResult HiFileResult)-mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do+mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do   let session = hscSetFlags (ms_hspp_opts ms) session'       ms = pm_mod_summary $ tmrParsed tcm       tcGblEnv = tmrTypechecked tcm -  let genLinkable = case ltype of-        ObjectLinkable -> generateObjectCode-        BCOLinkable    -> generateByteCode--  (linkable, details, diags) <-+  (details, mguts) <-     if mg_hsc_src simplified_guts == HsBootFile     then do-        -- give variables unique OccNames         details <- mkBootModDetailsTc session tcGblEnv-        pure (Nothing, details, [])+        pure (details, Nothing)     else do+        -- write core file         -- give variables unique OccNames-        (guts, details) <- tidyProgram session simplified_guts-        (diags, linkable) <- genLinkable session ms guts-        pure (linkable, details, diags)+        tidy_opts <- initTidyOpts session+        (guts, details) <- tidyProgram tidy_opts simplified_guts+        pure (details, Just guts)+ #if MIN_VERSION_ghc(9,0,1)-  let !partial_iface = force (mkPartialIface session details simplified_guts)+  let !partial_iface = force $ mkPartialIface session details+#if MIN_VERSION_ghc(9,3,0)+                                              ms+#endif+                                              simplified_guts+   final_iface <- mkFullIface session partial_iface Nothing+#if MIN_VERSION_ghc(9,4,2)+                    Nothing+#endif+ #elif MIN_VERSION_ghc(8,10,0)   let !partial_iface = force (mkPartialIface session details simplified_guts)   final_iface <- mkFullIface session partial_iface #else   (final_iface,_) <- mkIface session Nothing details simplified_guts #endif-  let mod_info = HomeModInfo final_iface details linkable-  pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) +  -- Write the core file now+  core_file <- case mguts of+    Nothing -> pure Nothing -- no guts, likely boot file+    Just guts -> do+        let core_fp  = ml_core_file $ ms_location ms+            core_file = codeGutsToCoreFile iface_hash guts+            iface_hash = getModuleHash final_iface+        core_hash1 <- atomicFileWrite se core_fp $ \fp ->+          writeBinCoreFile fp core_file+        -- We want to drop references to guts and read in a serialized, compact version+        -- of the core file from disk (as it is deserialised lazily)+        -- This is because we don't want to keep the guts in memeory for every file in+        -- the project as it becomes prohibitively expensive+        -- The serialized file however is much more compact and only requires a few+        -- hundred megabytes of memory total even in a large project with 1000s of+        -- modules+        (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp+        pure $ assert (core_hash1 == core_hash2)+             $ Just (core_file, fingerprintToBS core_hash2)++  -- Verify core file by rountrip testing and comparison+  IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se+  case core_file of+    Just (core, _) | optVerifyCoreFile -> do+      let core_fp = ml_core_file $ ms_location ms+      traceIO $ "Verifying " ++ core_fp+      let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of+            Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists"+            Just g -> g+          mod = ms_mod ms+          data_tycons = filter isDataTyCon tycons+      CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core++      -- Run corePrep first as we want to test the final version of the program that will+      -- get translated to STG/Bytecode+#if MIN_VERSION_ghc(9,3,0)+      prepd_binds+#else+      (prepd_binds , _)+#endif+        <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons+#if MIN_VERSION_ghc(9,3,0)+      prepd_binds'+#else+      (prepd_binds', _)+#endif+        <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons+      let binds  = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds+          binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'++          -- diffBinds is unreliable, sometimes it goes down the wrong track.+          -- This fixes the order of the bindings so that it is less likely to do so.+          diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'+          -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')+          -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')++          diffs = diffs2+          go x y = S.state $ \s -> diffBinds True s x y++          -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these+          -- are used for generate core or bytecode, so we can safely ignore them+          -- SYB is slow but fine given that this is only used for testing+          noUnfoldings = everywhere $ mkT $ \v -> if isId v+            then+              let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v+                in setIdOccInfo v' noOccInfo+            else v+          isOtherUnfolding (OtherCon _) = True+          isOtherUnfolding _            = False+++      when (not $ null diffs) $+        panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))+    _ -> pure ()++  pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file)+   where     dflags = hsc_dflags session'     source = "compile"@@ -462,9 +622,17 @@                 withWarnings "object" $ \tweak -> do                       let env' = tweak (hscSetFlags (ms_hspp_opts summary) session)                           target = platformDefaultBackend (hsc_dflags env')-                          newFlags = setBackend target $ updOptLevel 0 $ setOutputFile dot_o $ hsc_dflags env'+                          newFlags = setBackend target $ updOptLevel 0 $ setOutputFile+#if MIN_VERSION_ghc(9,3,0)+                              (Just dot_o)+#else+                              dot_o+#endif+                            $ hsc_dflags env'                           session' = hscSetFlags newFlags session-#if MIN_VERSION_ghc(9,0,1)+#if MIN_VERSION_ghc(9,4,2)+                      (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts+#elif MIN_VERSION_ghc(9,0,1)                       (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else                       (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts@@ -475,7 +643,14 @@                                 summary #endif                                 fp-                      compileFile session' StopLn (outputFilename, Just (As False))+                      obj <- compileFile session' driverNoStop (outputFilename, Just (As False))+#if MIN_VERSION_ghc(9,3,0)+                      case obj of+                        Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code"+                        Just x -> pure x+#else+                      return obj+#endif               let unlinked = DotO dot_o_fp               -- Need time to be the modification time for recompilation checking               t <- liftIO $ getModificationTime dot_o_fp@@ -483,8 +658,10 @@                pure (map snd warnings, linkable) -generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)-generateByteCode hscEnv summary guts = do+newtype CoreFileTime = CoreFileTime UTCTime++generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)+generateByteCode (CoreFileTime time) hscEnv summary guts = do     fmap (either (, Nothing) (second Just)) $           catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do               (warnings, (_, bytecode, sptEntries)) <-@@ -499,9 +676,7 @@                                 summary' #endif               let unlinked = BCOs bytecode sptEntries-              time <- liftIO getCurrentTime               let linkable = LM time (ms_mod summary) [unlinked]-               pure (map snd warnings, linkable)  demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule@@ -524,10 +699,17 @@ update_pm_mod_summary up pm =   pm{pm_mod_summary = up $ pm_mod_summary pm} +#if MIN_VERSION_ghc(9,3,0)+unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic)+unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors)         , fd) = (True, upgradeWarningToError fd)+unDefer (Just (WarningWithFlag Opt_WarnTypedHoles)                 , fd) = (True, upgradeWarningToError fd)+unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd)+#else unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) unDefer (Reason Opt_WarnDeferredTypeErrors         , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnTypedHoles                 , fd) = (True, upgradeWarningToError fd) unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd)+#endif unDefer ( _                                        , fd) = (False, fd)  upgradeWarningToError :: FileDiagnostic -> FileDiagnostic@@ -536,10 +718,15 @@   warn2err :: T.Text -> T.Text   warn2err = T.intercalate ": error:" . T.splitOn ": warning:" +#if MIN_VERSION_ghc(9,3,0)+hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)+hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))+#else hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-hideDiag originalFlags (Reason warning, (nfp, _sh, fd))+hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))+#endif   | not (wopt warning originalFlags)-  = (Reason warning, (nfp, HideDiag, fd))+  = (w, (nfp, HideDiag, fd)) hideDiag _originalFlags t = t  -- | Warnings which lead to a diagnostic tag@@ -560,10 +747,15 @@     ]  -- | Add a unnecessary/deprecated tag to the required diagnostics.+#if MIN_VERSION_ghc(9,3,0)+tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)+tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))+#else tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)-tagDiag (Reason warning, (nfp, sh, fd))+tagDiag (w@(Reason warning), (nfp, sh, fd))+#endif   | Just tag <- requiresTag warning-  = (Reason warning, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))+  = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))   where     requiresTag :: WarningFlag -> Maybe DiagnosticTag     requiresTag Opt_WarnWarningsDeprecations@@ -582,12 +774,14 @@ addRelativeImport fp modu dflags = dflags     {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} -atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()-atomicFileWrite targetPath write = do+-- | Also resets the interface store+atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a+atomicFileWrite se targetPath write = do   let dir = takeDirectory targetPath   createDirectoryIfMissing True dir   (tempFilePath, cleanUp) <- newTempFileWithin dir-  (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp+  (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)+    `onException` cleanUp  generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) generateHieAsts hscEnv tcm =@@ -603,18 +797,25 @@         insts = tcg_insts ts :: [ClsInst]         tcs = tcg_tcs ts :: [TyCon]     run ts $-      Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs+#if MIN_VERSION_ghc(9,3,0)+      pure $ Just $ #else+      Just <$>+#endif+          GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs+#else     Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif   where     dflags = hsc_dflags hscEnv+#if MIN_VERSION_ghc(9,0,0)     run ts =-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)         fmap (join . snd) . liftIO . initDs hscEnv ts #else         id #endif+#endif  spliceExpresions :: Splices -> [LHsExpr GhcTc] spliceExpresions Splices{..} =@@ -765,7 +966,7 @@   handleGenerationErrors dflags "extended interface write/compression" $ do     hf <- runHsc hscEnv $       GHC.mkHieFile' mod_summary exports ast source-    atomicFileWrite targetPath $ flip GHC.writeHieFile hf+    atomicFileWrite se targetPath $ flip GHC.writeHieFile hf     hash <- Util.getFileHash targetPath     indexHieFile se mod_summary srcPath hash hf   where@@ -773,13 +974,13 @@     mod_location = ms_location mod_summary     targetPath   = Compat.ml_hie_file mod_location -writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]-writeHiFile hscEnv tc =+writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic]+writeHiFile se hscEnv tc =   handleGenerationErrors dflags "interface write" $ do-    atomicFileWrite targetPath $ \fp ->+    atomicFileWrite se targetPath $ \fp ->       writeIfaceFile hscEnv fp modIface   where-    modIface = hm_iface $ hirHomeMod tc+    modIface = hirModIface tc     targetPath = ml_hi_file $ ms_location $ hirModSummary tc     dflags = hsc_dflags hscEnv @@ -811,18 +1012,64 @@     -> HscEnv     -> HscEnv loadModulesHome mod_infos e =+#if MIN_VERSION_ghc(9,3,0)+  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars })+#else   let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos]   in e { hsc_HPT = new_modules-      , hsc_type_env_var = Nothing }+       , hsc_type_env_var = Nothing+       }     where       mod_name = moduleName . mi_module . hm_iface+#endif  -- Merge the HPTs, module graphs and FinderCaches-mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env extraModSummaries extraMods envs = do+-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules+-- Add the current ModSummary to the graph, along with the+-- HomeModInfo's of all direct dependencies (by induction hypothesis all+-- transitive dependencies will be contained in envs)+#if MIN_VERSION_ghc(9,3,0)+mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv+mergeEnvs env (ms, deps) extraMods envs = do+    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))+        ifr = InstalledFound (ms_location ms) im+        curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr+        -- Very important to force this as otherwise the hsc_mod_graph field is not+        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get+        -- this new one, which in turn leads to the EPS referencing the HPT.+        module_graph_nodes =+          nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)++    newFinderCache <- concatFC curFinderCache (map hsc_FC envs)+    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $+      let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in+      (hscUpdateHUG (const newHug) env){+          hsc_FC = newFinderCache,+          hsc_mod_graph = mkModuleGraph module_graph_nodes+      })++    where+        mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b+        mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) }+        mergeUDFM = plusUDFM_C combineModules++        combineModules a b+          | HsSrcFile <- mi_hsc_src (hm_iface a) = a+          | otherwise = b+        concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache+        concatFC cur xs = do+          fcModules <- mapM (readIORef . fcModuleCache) xs+          fcFiles <- mapM (readIORef . fcFileCache) xs+          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules+          fcFiles' <- newIORef $! Map.unions fcFiles+          pure $ FinderCache fcModules' fcFiles'++#else+mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv+mergeEnvs env ms extraMods envs = do     prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs-    let ims  = map (\ms -> Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms)  (moduleName (ms_mod ms))) extraModSummaries-        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims+    let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))+        ifr = InstalledFound (ms_location ms) im         -- Very important to force this as otherwise the hsc_mod_graph field is not         -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get         -- this new one, which in turn leads to the EPS referencing the HPT.@@ -833,17 +1080,16 @@         -- This may have to change in the future.           map extendModSummaryNoDeps $ #endif-          extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)+          nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs) -    newFinderCache <- newIORef $-            foldl'-                (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache-                $ zip ims ifrs-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ env{-        hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,-        hsc_FC = newFinderCache,-        hsc_mod_graph = mkModuleGraph module_graph_nodes-    })+    newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr+    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $+      env{+          hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,+          hsc_FC = newFinderCache,+          hsc_mod_graph = mkModuleGraph module_graph_nodes+      })+     where         mergeUDFM = plusUDFM_C combineModules         combineModules a b@@ -856,6 +1102,7 @@     -- To remove this, I plan to upstream the missing Monoid instance         concatFC :: [FinderCache] -> FinderCache         concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))+#endif  withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut@@ -884,26 +1131,45 @@         (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps          -- GHC.Prim doesn't exist physically, so don't go looking for it.-        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc-                                . ideclName . unLoc)-                               ord_idecls+        (ordinary_imps, ghc_prim_imports)+          = partition ((/= moduleName gHC_PRIM) . unLoc+                      . ideclName . unLoc)+                      ord_idecls          implicit_prelude = xopt LangExt.ImplicitPrelude dflags         implicit_imports = mkPrelImports mod main_loc                                          implicit_prelude imps -        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i)-                                         , reLoc $ ideclName i) +        convImport (L _ i) = (+#if !MIN_VERSION_ghc (9,3,0)+                               fmap sl_fs+#endif+                               (ideclPkgQual i)+                             , reLoc $ ideclName i)++        msrImports = implicit_imports ++ imps++#if MIN_VERSION_ghc (9,3,0)+        rn_pkg_qual = renameRawPkgQual (hsc_unit_env env)+        rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))+        srcImports = rn_imps $ map convImport src_idecls+        textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)+        ghc_prim_import = not (null ghc_prim_imports)+#else         srcImports = map convImport src_idecls         textualImports = map convImport (implicit_imports ++ ordinary_imps)+#endif -        msrImports = implicit_imports ++ imps      -- Force bits that might keep the string buffer and DynFlags alive unnecessarily     liftIO $ evaluate $ rnf srcImports     liftIO $ evaluate $ rnf textualImports +#if MIN_VERSION_ghc (9,3,0)+    !src_hash <- liftIO $ fingerprintFromStringBuffer contents+#endif+     modLoc <- liftIO $ if mod == mAIN_NAME         -- specially in tests it's common to have lots of nameless modules         -- mkHomeModLocation will map them to the same hi/hie locations@@ -918,7 +1184,14 @@ #if MIN_VERSION_ghc(8,8,0)                 , ms_hie_date     = Nothing #endif+#if MIN_VERSION_ghc(9,3,0)+                , ms_dyn_obj_date    = Nothing+                , ms_ghc_prim_import = ghc_prim_import+                , ms_hs_hash      = src_hash++#else                 , ms_hs_date      = modTime+#endif                 , ms_hsc_src      = sourceType                 -- The contents are used by the GetModSummary rule                 , ms_hspp_buf     = Just contents@@ -942,7 +1215,14 @@                   put $ Util.uniq $ moduleNameFS $ moduleName ms_mod                   forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do                     put $ Util.uniq $ moduleNameFS $ unLoc m+#if MIN_VERSION_ghc(9,3,0)+                    case mb_p of+                      G.NoPkgQual -> pure ()+                      G.ThisPkg uid  -> put $ getKey $ getUnique uid+                      G.OtherPkg uid -> put $ getKey $ getUnique uid+#else                     whenJust mb_p $ put . Util.uniq+#endif             return $! Util.fingerprintFingerprints $                     [ Util.fingerprintString fp                     , fingerPrintImports@@ -1036,7 +1316,12 @@                --   - filter out the .hs/.lhs source filename if we have one                --                let n_hspp  = normalise filename-                   srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))+#if MIN_VERSION_ghc(9,3,0)+                   TempDir tmp_dir = tmpDir dflags+#else+                   tmp_dir = tmpDir dflags+#endif+                   srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`))                                   $ filter (/= n_hspp)                                   $ map normalise                                   $ filter (not . isPrefixOf "<")@@ -1090,9 +1375,10 @@    `HiFileResult` for some reason  4. If the file in question used Template Haskell on the previous compile, then-  we need to recompile if any `Linkable` in its transitive closure changed. This-  sounds bad, but it is possible to make some improvements.-  In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change.+we need to recompile if any `Linkable` in its transitive closure changed. This+sounds bad, but it is possible to make some improvements. In particular, we only+need to recompile if any of the `Linkable`s actually used during the previous+compile change.  How can we tell if a `Linkable` was actually used while running some TH? @@ -1112,8 +1398,13 @@ way to serialise arbitrary information along with interface files.  Then when deciding whether to recompile, we need to check that the versions-of the linkables used during a previous compile match whatever is currently-in the HPT.+(i.e. hashes) of the linkables used during a previous compile match whatever is+currently in the HPT.++As we always generate Linkables from core files, we use the core file hash+as a (hopefully) deterministic measure of whether the Linkable has changed.+This is better than using the object file hash (if we have one) because object+file generation is not deterministic. -}  data RecompilationInfo m@@ -1121,9 +1412,21 @@   { source_version :: FileVersion   , old_value   :: Maybe (HiFileResult, FileVersion)   , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion)+  , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString]   , regenerate  :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface   } +-- | Either a regular GHC linkable or a core file that+-- can be later turned into a proper linkable+data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile++instance NFData IdeLinkable where+  rnf (GhcLinkable lb)      = rnf lb+  rnf (CoreLinkable time _) = rnf time++ml_core_file :: ModLocation -> FilePath+ml_core_file ml = ml_hi_file ml <.> "core"+ -- | Retuns an up-to-date module interface, regenerating if needed. --   Assumes file exists. --   Requires the 'HscEnv' to be set up with dependencies@@ -1137,20 +1440,20 @@   -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms linkableNeeded RecompilationInfo{..} = do     let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session-        mb_old_iface = hm_iface    . hirHomeMod . fst <$> old_value+        mb_old_iface = hirModIface . fst <$> old_value         mb_old_version = snd <$> old_value -        obj_file = ml_obj_file (ms_location ms)+        core_file = ml_core_file (ms_location ms)+        iface_file = ml_hi_file (ms_location ms)          !mod = ms_mod ms      mb_dest_version <- case mb_old_version of       Just ver -> pure $ Just ver-      Nothing ->  get_file_version $ toNormalizedFilePath' $ case linkableNeeded of-          Just ObjectLinkable -> ml_obj_file (ms_location ms)-          _                   -> ml_hi_file (ms_location ms)+      Nothing  -> get_file_version (toNormalizedFilePath' iface_file) -    -- The source is modified if it is newer than the destination+    -- The source is modified if it is newer than the destination (iface file)+    -- A more precise check for the core file is performed later     let sourceMod = case mb_dest_version of           Nothing -> SourceModified -- desitination file doesn't exist, assume modified source           Just dest_version@@ -1158,46 +1461,15 @@             | otherwise -> SourceModified      -- If mb_old_iface is nothing then checkOldIface will load it for us+    -- given that the source is unmodified     (recomp_iface_reqd, mb_checked_iface)+#if MIN_VERSION_ghc(9,3,0)+      <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case+        UpToDateItem x -> pure (UpToDate, Just x)+        OutOfDateItem reason x -> pure (NeedsRecompile reason, x)+#else       <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface---    let-      (recomp_obj_reqd, mb_linkable) = case linkableNeeded of-        Nothing -> (UpToDate, Nothing)-        Just linkableType -> case old_value of-          -- We don't have an old result-          Nothing -> recompMaybeBecause "missing"-          -- We have an old result-          Just (old_hir, old_file_version) ->-            case hm_linkable $ hirHomeMod old_hir of-              Nothing -> recompMaybeBecause "missing [not needed before]"-              Just old_lb-                | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used-                , old_file_version /= source_version -> recompMaybeBecause "out of date"--                -- Check if it is the correct type-                -- Ideally we could use object-code in case we already have-                -- it when we are generating bytecode, but this is difficult because something-                -- below us may be bytecode, and object code can't depend on bytecode-                | ObjectLinkable <- linkableType, isObjectLinkable old_lb-                -> (UpToDate, Just old_lb)--                | BCOLinkable    <- linkableType , not (isObjectLinkable old_lb)-                -> (UpToDate, Just old_lb)--                | otherwise -> recompMaybeBecause "missing [wrong type]"-          where-            recompMaybeBecause msg = case linkableType of-              BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing)-              ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code-                Nothing -> (RecompBecause ("object code "++ msg), Nothing)-                Just disk_obj_version@(ModificationTime t) ->-                  -- If we make it this far, assume that the object code on disk is up to date-                  -- This assertion works because of the sourceMod check-                  assert (disk_obj_version >= source_version)-                         (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file])-                Just (VFSVersion _) -> error "object code in vfs"+#endif      let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do           setTag "Module" $ moduleNameString $ moduleName mod@@ -1205,77 +1477,140 @@           liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason)           regenerate linkableNeeded -    case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of+    case (mb_checked_iface, recomp_iface_reqd) of       (Just iface, UpToDate) -> do-         -- Force it because we don't want to retain old modsummaries or linkables-         lb <- liftIO $ evaluate $ force mb_linkable-          -- If we have an old value, just return it          case old_value of            Just (old_hir, _)-             | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir)-             -> do_regenerate msg-             | otherwise -> return ([], Just old_hir)-           Nothing -> do-             hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb+             | isNothing linkableNeeded || isJust (hirCoreFp old_hir)+             -> do+             -- Peform the fine grained recompilation check for TH+             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir)+             case maybe_recomp of+               Just msg -> do_regenerate msg+               Nothing  -> return ([], Just old_hir)+           -- Otherwise use the value from disk, provided the core file is up to date if required+           _ -> do+             details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface              -- parse the runtime dependencies from the annotations              let runtime_deps                    | not (mi_used_th iface) = emptyModuleEnv-                   | otherwise = parseRuntimeDeps (md_anns (hm_details hmi))-             return ([], Just $ mkHiFileResult ms hmi runtime_deps)+                   | otherwise = parseRuntimeDeps (md_anns details)+             -- Peform the fine grained recompilation check for TH+             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps+             case maybe_recomp of+               Just msg -> do_regenerate msg+               Nothing+                 | isJust linkableNeeded -> handleErrs $ do+                   (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $+                     readBinCoreFile (mkUpdater $ hsc_NC session) core_file+                   if cf_iface_hash == getModuleHash iface+                   then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash)))+                   else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)")+                 | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing)+                 where handleErrs = flip catches+                         [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")+                         ,Handler $ \(e :: GhcException) -> case e of+                            Signal _ -> throw e+                            Panic _  -> throw e+                            _        -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")")+                         ]       (_, _reason) -> do_regenerate _reason --- | ModDepTime is stored as an annotation in the iface to--- keep track of runtime dependencies-newtype ModDepTime = ModDepTime UTCTime--deserializeModDepTime :: [Word8] -> ModDepTime-deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of-  (a,b) -> UTCTime (toEnum a) (toEnum b)--serializeModDepTime :: ModDepTime -> [Word8]-serializeModDepTime (ModDepTime l) = LBS.unpack $-  B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)- -- | Find the runtime dependencies by looking at the annotations -- serialized in the iface-parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime+-- The bytestrings are the hashes of the core files for modules we+-- required to run the TH splices in the given module.+-- See Note [Recompilation avoidance in the presence of TH]+parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns   where     go (Annotation (ModuleTarget mod) payload)-      | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload-      = Just (mod, t)+      | Just bs <- fromSerialized BS.pack payload+      = Just (mod, bs)     go _ = Nothing --- | checkLinkableDependencies compares the linkables in the home package to+-- | checkLinkableDependencies compares the core files in the build graph to -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH]-checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired-checkLinkableDependencies hpt runtime_deps-  | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile-  | otherwise = Just $-      RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date))-  where-    out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of-                                                  Nothing -> False-                                                  Just hm -> case hm_linkable hm of-                                                    Nothing -> False-                                                    Just lm -> linkableTime lm /= time)-                                  runtime_deps+checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)+checkLinkableDependencies get_linkable_hashes graph runtime_deps = do+  let hs_files = mapM go (moduleEnvToList runtime_deps)+      go (mod, hash) = do+        ms <- mgLookupModule graph mod+        let hs = fromJust $ ml_hs_file $ ms_location ms+        pure (toNormalizedFilePath' hs, hash)+  case hs_files of+    Nothing -> error "invalid module graph"+    Just fs -> do+      store_hashes <- get_linkable_hashes (map fst fs)+      let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash]+      case out_of_date of+        [] -> pure Nothing+        _ -> pure $ Just $ recompBecause+              $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) +recompBecause =+#if MIN_VERSION_ghc(9,3,0)+                NeedsRecompile .+#endif+                RecompBecause+#if MIN_VERSION_ghc(9,3,0)+              . CustomReason+#endif++#if MIN_VERSION_ghc(9,3,0)+data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show)+#endif+ showReason :: RecompileRequired -> String showReason UpToDate          = "UpToDate"+#if MIN_VERSION_ghc(9,3,0)+showReason (NeedsRecompile MustCompile)    = "MustCompile"+showReason (NeedsRecompile s) = printWithoutUniques s+#else showReason MustCompile       = "MustCompile" showReason (RecompBecause s) = s+#endif -mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo-mkDetailsFromIface session iface linkable = do-  details <- liftIO $ fixIO $ \details -> do-    let hsc' = session { hsc_HPT = addToHpt (hsc_HPT session) (moduleName $ mi_module iface) (HomeModInfo iface details linkable) }+mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails+mkDetailsFromIface session iface = do+  fixIO $ \details -> do+    let hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session     initIfaceLoad hsc' (typecheckIface iface)-  return (HomeModInfo iface details linkable) +coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts+coreFileToCgGuts session iface details core_file = do+  let act hpt = addToHpt hpt (moduleName this_mod)+                             (HomeModInfo iface details Nothing)+      this_mod = mi_module iface+  types_var <- newIORef (md_types details)+  let hsc_env' = hscUpdateHPT act (session {+#if MIN_VERSION_ghc(9,3,0)+        hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])+#else+        hsc_type_env_var = Just (this_mod, types_var)+#endif+        })+  core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file+      -- Implicit binds aren't saved, so we need to regenerate them ourselves.+  let implicit_binds = concatMap getImplicitBinds tyCons+      tyCons = typeEnvTyCons (md_types details)+#if MIN_VERSION_ghc(9,3,0)+  pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []+#else+  pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []+#endif++coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)+coreFileToLinkable linkableType session ms iface details core_file t = do+  cgi_guts <- coreFileToCgGuts session iface details core_file+  (warns, lb) <- case linkableType of+    BCOLinkable    -> generateByteCode (CoreFileTime t) session ms cgi_guts+    ObjectLinkable -> generateObjectCode session ms cgi_guts+  pure (warns, HomeModInfo iface details . Just <$> lb)+ -- | Non-interactive, batch version of 'InteractiveEval.getDocs'. --   The interactive paths create problems in ghc-lib builds --- and leads to fun errors like "Cannot continue after interface file error".@@ -1283,27 +1618,55 @@   :: HscEnv   -> Module  -- ^ a moudle where the names are in scope   -> [Name]+#if MIN_VERSION_ghc(9,3,0)+  -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+#else   -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]+#endif getDocsBatch hsc_env _mod _names = do     (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->         case nameModule_maybe name of             Nothing -> return (Left $ NameHasNoModule name)             Just mod -> do-             ModIface { mi_doc_hdr = mb_doc_hdr+             ModIface {+#if MIN_VERSION_ghc(9,3,0)+                        mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr+                                      , docs_decls = dmap+                                      , docs_args = amap+                                      }+#else+                        mi_doc_hdr = mb_doc_hdr                       , mi_decl_docs = DeclDocMap dmap                       , mi_arg_docs = ArgDocMap amap+#endif                       } <- loadModuleInterface "getModuleInterface" mod+#if MIN_VERSION_ghc(9,3,0)+             if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap+#else              if isNothing mb_doc_hdr && Map.null dmap && null amap+#endif                then pure (Left (NoDocsInIface mod $ compiled name))-               else pure (Right ( Map.lookup name dmap ,+               else pure (Right (+#if MIN_VERSION_ghc(9,3,0)+                                  lookupUniqMap dmap name,+#else+                                  Map.lookup name dmap ,+#endif #if !MIN_VERSION_ghc(9,2,0)                                   IntMap.fromAscList $ Map.toAscList $ #endif+#if MIN_VERSION_ghc(9,3,0)+                                  lookupWithDefaultUniqMap amap mempty name))+#else                                   Map.findWithDefault mempty name amap))+#endif     case res of-        Just x  -> return $ map (first $ T.unpack . printOutputable) x+        Just x  -> return $ map (first $ T.unpack . printOutputable)+                          $ x         Nothing -> throwErrors-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,3,0)+                     $ fmap GhcTcRnMessage msgs+#elif MIN_VERSION_ghc(9,2,0)                      $ Error.getErrorMessages msgs #else                      $ snd msgs
src/Development/IDE/Core/Debouncer.hs view
@@ -50,9 +50,8 @@         sleep delay         fire         atomically $ STM.delete k d-    do-        prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d-        traverse_ cancel prev+    prev <- atomicallyNamed "debouncer" $ STM.focus (Focus.lookup <* Focus.insert a) k d+    traverse_ cancel prev  -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k
src/Development/IDE/Core/FileStore.hs view
@@ -28,14 +28,13 @@ import           Control.Monad.Extra import           Control.Monad.IO.Class import qualified Data.ByteString                              as BS-import           Data.Either.Extra-import qualified Data.Rope.UTF16                              as Rope import qualified Data.Text                                    as T+import qualified Data.Text.Utf16.Rope                         as Rope import           Data.Time import           Data.Time.Clock.POSIX+import           Development.IDE.Core.FileUtils import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Shake                   hiding (Log)-import           Development.IDE.Core.FileUtils import           Development.IDE.GHC.Orphans                  () import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation@@ -90,7 +89,7 @@     LogCouldNotIdentifyReverseDeps path ->       "Could not identify reverse dependencies for" <+> viaShow path     (LogTypeCheckingReverseDeps path reverseDepPaths) ->-      "Typechecking reverse dependecies for"+      "Typechecking reverse dependencies for"       <+> viaShow path       <> ":"       <+> pretty (fmap (fmap show) reverseDepPaths)@@ -151,7 +150,7 @@ --   But interface files are private, in that only HLS writes them. --   So we implement watching ourselves, and bypass the need for alwaysRerun. isInterface :: NormalizedFilePath -> Bool-isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"]+isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"]  -- | Reset the GetModificationTime state of interface files resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()@@ -189,14 +188,8 @@     time <- use_ GetModificationTime file     res <- do         mbVirtual <- getVirtualFile file-        pure $ Rope.toText . _text <$> mbVirtual+        pure $ Rope.toText . _file_text <$> mbVirtual     pure ([], Just (time, res))--ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)-ideTryIOException fp act =-  mapLeft-      (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)-      <$> try act  -- | Returns the modification time and the contents. --   For VFS paths, the modification time is the current time.
src/Development/IDE/Core/FileUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP          #-}+{-# LANGUAGE CPP #-}  module Development.IDE.Core.FileUtils(     getModTime,@@ -7,10 +7,9 @@  import           Data.Time.Clock.POSIX #ifdef mingw32_HOST_OS-import qualified System.Directory                             as Dir+import qualified System.Directory      as Dir #else-import           System.Posix.Files                           (getFileStatus,-                                                               modificationTimeHiRes)+import           System.Posix.Files    (getFileStatus, modificationTimeHiRes) #endif  -- Dir.getModificationTime is surprisingly slow since it performs
src/Development/IDE/Core/IdeConfiguration.hs view
@@ -16,8 +16,8 @@ import           Control.Monad import           Control.Monad.IO.Class import           Data.Aeson.Types               (Value)-import           Data.HashSet                   (HashSet, singleton) import           Data.Hashable                  (Hashed, hashed, unhashed)+import           Data.HashSet                   (HashSet, singleton) import           Data.Text                      (Text, isPrefixOf) import           Development.IDE.Core.Shake import           Development.IDE.Graph@@ -56,8 +56,8 @@   clientSettings = hashed _initializationOptions  parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri-parseWorkspaceFolder =-  toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)+parseWorkspaceFolder WorkspaceFolder{_uri} =+  toNormalizedUri (Uri _uri)  modifyWorkspaceFolders   :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
src/Development/IDE/Core/OfInterest.hs view
@@ -107,10 +107,10 @@     (prev, files) <- modifyVar var $ \dict -> do         let (prev, new) = HashMap.alterF (, Just v) f dict         pure (new, (prev, new))-    when (prev /= Just v) $+    when (prev /= Just v) $ do         join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-    logDebug (ideLogger state) $-        "Set files of interest to: " <> T.pack (show files)+        logDebug (ideLogger state) $+            "Set files of interest to: " <> T.pack (show files)  deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () deleteFileOfInterest state f = do
src/Development/IDE/Core/Preprocessor.hs view
@@ -1,13 +1,14 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP        #-}  module Development.IDE.Core.Preprocessor   ( preprocessor   ) where -import           Development.IDE.GHC.CPP import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util   as Util+import           Development.IDE.GHC.CPP import           Development.IDE.GHC.Orphans       ()  import           Control.DeepSeq                   (NFData (rnf))@@ -28,6 +29,10 @@ import qualified GHC.LanguageExtensions            as LangExt import           System.FilePath import           System.IO.Extra+#if MIN_VERSION_ghc(9,3,0)+import GHC.Utils.Logger (LogFlags(..))+import GHC.Utils.Outputable (renderWithContext)+#endif  -- | Given a file and some contents, apply any necessary preprocessors, --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.@@ -76,10 +81,15 @@   where     logAction :: IORef [CPPLog] -> LogActionCompat     logAction cppLogs dflags _reason severity srcSpan _style msg = do+#if MIN_VERSION_ghc(9,3,0)+      let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg+#else       let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg+#endif       modifyIORef cppLogs (log :)  + data CPPLog = CPPLog Severity SrcSpan Text   deriving (Show) @@ -133,7 +143,11 @@     -> Util.StringBuffer     -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do+#if MIN_VERSION_ghc(9,3,0)+    let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp+#else     let opts = getOptions dflags0 contents fp+#endif      -- Force bits that might keep the dflags and stringBuffer alive unnecessarily     evaluate $ rnf opts
src/Development/IDE/Core/ProgressReporting.hs view
@@ -63,10 +63,10 @@ -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO () -> Transition -> State -> IO State+updateState :: IO (Async ()) -> Transition -> State -> IO State updateState _      _                    Stopped     = pure Stopped-updateState start (Event KickStarted)   NotStarted  = Running <$> async start-updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> async start+updateState start (Event KickStarted)   NotStarted  = Running <$> start+updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> start updateState _     (Event KickCompleted) (Running a) = cancel a $> NotStarted updateState _     (Event KickCompleted) st          = pure st updateState _     StopProgress          (Running a) = cancel a $> Stopped@@ -110,12 +110,13 @@   -> Maybe (LSP.LanguageContextEnv c)   -> ProgressReportingStyle   -> IO ProgressReporting-delayedProgressReporting before after lspEnv optProgressStyle = do+delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting+delayedProgressReporting before after (Just lspEnv) optProgressStyle = do     inProgressState <- newInProgress     progressState <- newVar NotStarted     let progressUpdate event = updateStateVar $ Event event         progressStop   =  updateStateVar StopProgress-        updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressState)+        updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState)          inProgress = updateStateForFile inProgressState     return ProgressReporting{..}@@ -127,11 +128,11 @@             u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique              b <- liftIO newBarrier-            void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate+            void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate                 LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b-            ready <- liftIO $ waitBarrier b--            for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)+            liftIO $ async $ do+                ready <- waitBarrier b+                LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)             where                 start id = LSP.sendNotification LSP.SProgress $                     LSP.ProgressParams
src/Development/IDE/Core/RuleTypes.hs view
@@ -17,6 +17,7 @@     ) where  import           Control.DeepSeq+import           Control.Exception                            (assert) import           Control.Lens import           Data.Aeson.Types                             (Value) import           Data.Hashable@@ -26,6 +27,7 @@ import           Development.IDE.GHC.Compat                   hiding                                                               (HieFileResult) import           Development.IDE.GHC.Compat.Util+import           Development.IDE.GHC.CoreFile import           Development.IDE.GHC.Util import           Development.IDE.Graph import           Development.IDE.Import.DependencyInformation@@ -33,11 +35,8 @@ import           Development.IDE.Types.KnownTargets import           GHC.Generics                                 (Generic) -import qualified Data.Binary                                  as B import           Data.ByteString                              (ByteString)-import qualified Data.ByteString.Lazy                         as LBS import           Data.Text                                    (Text)-import           Data.Time import           Development.IDE.Import.FindImports           (ArtifactsLocation) import           Development.IDE.Spans.Common import           Development.IDE.Spans.LocalBindings@@ -91,6 +90,26 @@ instance Hashable GenerateCore instance NFData   GenerateCore +type instance RuleResult GetLinkable = LinkableResult++data LinkableResult+  = LinkableResult+  { linkableHomeMod :: !HomeModInfo+  , linkableHash    :: !ByteString+  -- ^ The hash of the core file+  }++instance Show LinkableResult where+    show = show . mi_module . hm_iface . linkableHomeMod++instance NFData LinkableResult where+    rnf = rwhnf++data GetLinkable = GetLinkable+    deriving (Eq, Show, Typeable, Generic)+instance Hashable GetLinkable+instance NFData   GetLinkable+ data GetImportMap = GetImportMap     deriving (Eq, Show, Typeable, Generic) instance Hashable GetImportMap@@ -138,9 +157,10 @@     -- ^ Typechecked splice information     , tmrDeferedError    :: !Bool     -- ^ Did we defer any type errors for this module?-    , tmrRuntimeModules  :: !(ModuleEnv UTCTime)+    , tmrRuntimeModules  :: !(ModuleEnv ByteString)         -- ^ Which modules did we need at runtime while compiling this file?         -- Used for recompilation checking in the presence of TH+        -- Stores the hash of their core file     } instance Show TcModuleResult where     show = show . pm_mod_summary . tmrParsed@@ -152,33 +172,32 @@ tmrModSummary = pm_mod_summary . tmrParsed  data HiFileResult = HiFileResult-    { hirModSummary :: !ModSummary+    { hirModSummary     :: !ModSummary     -- Bang patterns here are important to stop the result retaining     -- a reference to a typechecked module-    , hirHomeMod    :: !HomeModInfo-    -- ^ Includes the Linkable iff we need object files-    , hirIfaceFp    :: ByteString+    , hirModIface       :: !ModIface+    , hirModDetails     :: ModDetails+    -- ^ Populated lazily+    , hirIfaceFp        :: !ByteString     -- ^ Fingerprint for the ModIface-    , hirLinkableFp :: ByteString-    -- ^ Fingerprint for the Linkable-    , hirRuntimeModules :: !(ModuleEnv UTCTime)+    , hirRuntimeModules :: !(ModuleEnv ByteString)     -- ^ same as tmrRuntimeModules+    , hirCoreFp         :: !(Maybe (CoreFile, ByteString))+    -- ^ If we wrote a core file for this module, then its contents (lazily deserialised)+    -- along with its hash     }  hiFileFingerPrint :: HiFileResult -> ByteString-hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp+hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp -mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult-mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..}+mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult+mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp =+    assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _)+                                -> getModuleHash hirModIface == cf_iface_hash+                              _ -> True)+    HiFileResult{..}   where-    hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes-    hirLinkableFp = case hm_linkable hirHomeMod of-      Nothing -> ""-      Just (linkableTime -> l)  -> LBS.toStrict $-        B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l)--hirModIface :: HiFileResult -> ModIface-hirModIface = hm_iface . hirHomeMod+    hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes  instance NFData HiFileResult where     rnf = rwhnf@@ -188,7 +207,7 @@  -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult-  = forall a. HAR+  = forall a . (Typeable a) =>  HAR   { hieModule :: Module   , hieAst    :: !(HieASTs a)   , refMap    :: RefMap a@@ -425,7 +444,7 @@  instance Show GhcSessionDeps where     show (GhcSessionDeps_ False) = "GhcSessionDeps"-    show (GhcSessionDeps_ True) = "GhcSessionDepsFull"+    show (GhcSessionDeps_ True)  = "GhcSessionDepsFull"  pattern GhcSessionDeps :: GhcSessionDeps pattern GhcSessionDeps = GhcSessionDeps_ False
src/Development/IDE/Core/Rules.hs view
@@ -28,6 +28,7 @@     getParsedModuleWithComments,     getClientConfigAction,     usePropertyAction,+    getHieFile,     -- * Rules     CompiledLinkables(..),     getParsedModuleRule,@@ -55,6 +56,7 @@     getParsedModuleDefinition,     typeCheckRuleDefinition,     getRebuildCount,+    getSourceFileSource,     GhcSessionDepsConfig(..),     Log(..),     DisplayTHWarning(..),@@ -65,6 +67,7 @@ #endif import           Control.Concurrent.Async                     (concurrently) import           Control.Concurrent.Strict+import           Control.DeepSeq import           Control.Exception.Safe import           Control.Monad.Extra import           Control.Monad.Reader@@ -90,16 +93,17 @@ import           Data.List import qualified Data.Map                                     as M import           Data.Maybe-import qualified Data.Rope.UTF16                              as Rope+import qualified Data.Text.Utf16.Rope                         as Rope import qualified Data.Set                                     as Set import qualified Data.Text                                    as T import qualified Data.Text.Encoding                           as T import           Data.Time                                    (UTCTime (..)) import           Data.Tuple.Extra+import           Data.Typeable                                (cast) import           Development.IDE.Core.Compile import           Development.IDE.Core.FileExists hiding (LogShake, Log) import           Development.IDE.Core.FileStore               (getFileContents,-                                                               resetInterfaceStore)+                                                               getModTime) import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.OfInterest hiding (LogShake, Log) import           Development.IDE.Core.PositionMapping@@ -116,7 +120,6 @@ import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util              as Util import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import           Development.IDE.GHC.Util                     hiding                                                               (modifyDynFlags) import           Development.IDE.Graph@@ -135,7 +138,7 @@ import qualified Language.LSP.Server                          as LSP import           Language.LSP.Types                           (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) import           Language.LSP.VFS-import           System.Directory                             (makeAbsolute)+import           System.Directory                             (makeAbsolute, doesFileExist) import           Data.Default                                 (def, Default) import           Ide.Plugin.Properties                        (HasProperty,                                                                KeyNameProxy,@@ -151,9 +154,15 @@ import HIE.Bios.Ghc.Gap (hostIsDynamic) import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake-import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Shake as Shake+import           Development.IDE.GHC.CoreFile+import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)+import Control.Monad.IO.Unlift+#if MIN_VERSION_ghc(9,3,0)+import GHC.Unit.Module.Graph+import GHC.Unit.Env+#endif  data Log   = LogShake Shake.Log@@ -161,7 +170,7 @@   | LogLoadingHieFile !NormalizedFilePath   | LogLoadingHieFileFail !FilePath !SomeException   | LogLoadingHieFileSuccess !FilePath-  | LogExactPrint ExactPrint.Log+  | LogTypecheckedFOI !NormalizedFilePath   deriving Show  instance Pretty Log where@@ -178,7 +187,14 @@           , pretty (displayException e) ]     LogLoadingHieFileSuccess path ->       "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path-    LogExactPrint log -> pretty log+    LogTypecheckedFOI path -> vcat+      [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path)+      , "This can indicate a bug which results in excessive memory usage."+      , "This may be a spurious warning if you have recently closed the file."+      , "If you haven't opened this file recently, please file a report on the issue tracker mentioning"+        <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which"+        <+> "triggered this warning."+      ]  templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries"@@ -559,10 +575,10 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do   res <- readHieFileForSrcFromDisk recorder file   vfsRef <- asks vfsVar-  vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef+  vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef   (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)-    Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)+    Just vf -> pure (Rope.toText $ _file_text vf, Just $ _lsp_version vf)   let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res       del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource   pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver)@@ -647,6 +663,12 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do     pm <- use_ GetParsedModule file     hsc  <- hscEnv <$> use_ GhcSessionDeps file+    foi <- use_ IsFileOfInterest file+    -- We should only call the typecheck rule for files of interest.+    -- Keeping typechecked modules in memory for other files is+    -- very expensive.+    when (foi == NotFOI) $+      logWith recorder Logger.Warning $ LogTypecheckedFOI file     typeCheckRuleDefinition hsc pm  knownFilesRule :: Recorder (WithPriority Log) -> Rules ()@@ -673,9 +695,13 @@   setPriority priorityTypeCheck   IdeOptions { optDefer = defer } <- getIdeOptions -  linkables_to_keep <- currentLinkables+  unlift <- askUnliftIO+  let dets = TypecheckHelpers+           { getLinkablesToKeep = unliftIO unlift $ currentLinkables+           , getLinkables = unliftIO unlift . uses_ GetLinkable+           }   addUsageDependencies $ liftIO $-    typecheckModule defer hsc linkables_to_keep pm+    typecheckModule defer hsc dets pm   where     addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)     addUsageDependencies a = do@@ -733,6 +759,11 @@     { checkForImportCycles = True     } +-- | Note [GhcSessionDeps]+-- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes+-- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself.+-- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself.+-- 3. ModLocation's (in the FinderCache) all modules in the transitive closure of "Foo", including "Foo" itself. ghcSessionDepsDefinition     :: -- | full mod summary         Bool ->@@ -745,15 +776,26 @@         Nothing -> return Nothing         Just deps -> do             when checkForImportCycles $ void $ uses_ ReportImportCycles deps-            mss <- map msrModSummary <$> if fullModSummary-                then uses_ GetModSummary deps-                else uses_ GetModSummaryWithoutTimestamps deps+            ms <- msrModSummary <$> if fullModSummary+                then use_ GetModSummary file+                else use_ GetModSummaryWithoutTimestamps file              depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps             ifaces <- uses_ GetModIface deps--            let inLoadOrder = map hirHomeMod ifaces-            session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions+            let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces+#if MIN_VERSION_ghc(9,3,0)+            -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph+            -- also points to all the direct descendents of the current module. To get the keys for the descendents+            -- we must get their `ModSummary`s+            !final_deps <- do+              dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps+             -- Don't want to retain references to the entire ModSummary when just the key will do+              return $!! map (NodeKey_Module . msKey) dep_mss+            let moduleNode = (ms, final_deps)+#else+            let moduleNode = ms+#endif+            session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions              Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' []) @@ -768,6 +810,7 @@     Just session -> do       linkableType <- getLinkableType f       ver <- use_ GetModificationTime f+      ShakeExtras{ideNc} <- getShakeExtras       let m_old = case old of             Shake.Succeeded (Just old_version) v -> Just (v, old_version)             Shake.Stale _   (Just old_version) v -> Just (v, old_version)@@ -776,6 +819,7 @@             { source_version = ver             , old_value = m_old             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}+            , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs             , regenerate = regenerateHiFile session f ms             }       r <- loadInterface (hscEnv session) ms linkableType recompInfo@@ -835,9 +879,13 @@ getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules () getModSummaryRule displayTHWarning recorder = do     menv <- lspEnv <$> getShakeExtrasRules-    forM_ menv $ \env -> do+    case menv of+      Just env -> do         displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning         addIdeGlobal (DisplayTHWarning displayItOnce)+      Nothing -> do+        logItOnce <- liftIO $ once $ putStrLn ""+        addIdeGlobal (DisplayTHWarning logItOnce)      defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do         session' <- hscEnv <$> use_ GhcSession f@@ -853,8 +901,12 @@                 when (uses_th_qq $ msrModSummary res) $ do                     DisplayTHWarning act <- getIdeGlobalAction                     liftIO act+#if MIN_VERSION_ghc(9,3,0)+                let bufFingerPrint = ms_hs_hash (msrModSummary res)+#else                 bufFingerPrint <- liftIO $                     fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res+#endif                 let fingerPrint = Util.fingerprintFingerprints                         [ msrFingerprint res, bufFingerPrint ]                 return ( Just (fingerprintToBS fingerPrint) , ([], Just res))@@ -865,7 +917,9 @@         case ms of             Just res@ModSummaryResult{..} -> do                 let ms = msrModSummary {+#if !MIN_VERSION_ghc(9,3,0)                     ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",+#endif                     ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"                     }                     fp = fingerprintToBS msrFingerprint@@ -893,12 +947,13 @@       linkableType <- getLinkableType f       hsc <- hscEnv <$> use_ GhcSessionDeps f       let compile = fmap ([],) $ use GenerateCore f-      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr+      se <- getShakeExtras+      (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr       let fp = hiFileFingerPrint <$> hiFile       hiDiags <- case hiFile of         Just hiFile           | OnDisk <- status-          , not (tmrDeferedError tmr) -> writeHiFileAction hsc hiFile+          , not (tmrDeferedError tmr) -> liftIO $ writeHiFile se hsc hiFile         _ -> pure []       return (fp, (diags++hiDiags, hiFile))     NotFOI -> do@@ -906,10 +961,6 @@       let fp = hiFileFingerPrint <$> hiFile       return (fp, ([], hiFile)) -  -- Record the linkable so we know not to unload it-  whenJust (hm_linkable . hirHomeMod =<< mhmi) $ \(LM time mod _) -> do-      compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction-      liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time   pure res  -- | Count of total times we asked GHC to recompile@@ -954,11 +1005,12 @@               Nothing -> pure (diags', Nothing)               Just tmr -> do -                -- compile writes .o file                 let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr +                se <- getShakeExtras+                 -- Bang pattern is important to avoid leaking 'tmr'-                (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr                  -- Write hi file                 hiDiags <- case res of@@ -976,7 +1028,7 @@                     -- We don't write the `.hi` file if there are defered errors, since we won't get                     -- accurate diagnostics next time if we do                     hiDiags <- if not $ tmrDeferedError tmr-                               then writeHiFileAction hsc hiFile+                               then liftIO $ writeHiFile se hsc hiFile                                else pure []                      pure (hiDiags <> gDiags <> concat wDiags)@@ -986,18 +1038,20 @@   -- | HscEnv should have deps included already-compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)-compileToObjCodeIfNeeded hsc Nothing _ tmr = do+-- This writes the core file if a linkable is required+-- The actual linkable will be generated on demand when required by `GetLinkable`+writeCoreFileIfNeeded :: ShakeExtras -> HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult)+writeCoreFileIfNeeded _ hsc Nothing _ tmr = do   incrementRebuildCount   res <- liftIO $ mkHiFileResultNoCompile hsc tmr   pure ([], Just $! res)-compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do+writeCoreFileIfNeeded se hsc (Just _) getGuts tmr = do   incrementRebuildCount   (diags, mguts) <- getGuts   case mguts of     Nothing -> pure (diags, Nothing)     Just guts -> do-      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType+      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts       pure (diags++diags', res)  getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()@@ -1029,12 +1083,57 @@  -- --------------------------------------------------------------------- +getLinkableRule :: Recorder (WithPriority Log) -> Rules ()+getLinkableRule recorder =+  defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do+    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f+    HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f+    let obj_file  = ml_obj_file (ms_location ms)+        core_file = ml_core_file (ms_location ms)+    -- Can't use `GetModificationTime` rule because the core file was possibly written in this+    -- very session, so the results aren't reliable+    core_t <- liftIO $ getModTime core_file+    case hirCoreFp of+      Nothing -> error "called GetLinkable for a file without a linkable"+      Just (bin_core, hash) -> do+        session <- use_ GhcSessionDeps f+        ShakeExtras{ideNc} <- getShakeExtras+        let namecache_updater = mkUpdater ideNc+        linkableType <- getLinkableType f >>= \case+          Nothing -> error "called GetLinkable for a file which doesn't need compilation"+          Just t -> pure t+        (warns, hmi) <- case linkableType of+          -- Bytecode needs to be regenerated from the core file+          BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t)+          -- Object code can be read from the disk+          ObjectLinkable -> do+            -- object file is up to date if it is newer than the core file+            -- Can't use a rule like 'GetModificationTime' or 'GetFileExists' because 'coreFileToLinkable' will write the object file, and+            -- thus bump its modification time, forcing this rule to be rerun every time.+            exists <- liftIO $ doesFileExist obj_file+            mobj_time <- liftIO $+              if exists+              then Just <$> getModTime obj_file+              else pure Nothing+            case mobj_time of+              Just obj_t+                | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file]))+              _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time")+        -- Record the linkable so we know not to unload it+        whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do+            compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction+            liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time+        return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash))+ -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f  -- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath  -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))+needsCompilationRule file+  | "boot" `isSuffixOf` (fromNormalizedFilePath file) =+    pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do   graph <- useNoFile GetModuleGraph   res <- case graph of@@ -1058,7 +1157,6 @@             (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps)                 (uses NeedsCompilation revdeps)         pure $ computeLinkableType ms modsums (map join needsComps)-   pure (Just $ encodeLinkableType res, Just res)   where     computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType@@ -1079,7 +1177,7 @@ -- Depends on whether it uses unboxed tuples or sums computeLinkableTypeForDynFlags :: DynFlags -> LinkableType computeLinkableTypeForDynFlags d-#if defined(GHC_PATCHED_UNBOXED_BYTECODE)+#if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0)           = BCOLinkable #else           | unboxed_tuples_or_sums = ObjectLinkable@@ -1093,15 +1191,6 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables --writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic]-writeHiFileAction hsc hiFile = do-    extras <- getShakeExtras-    let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile-    liftIO $ do-        atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath-        writeHiFile hsc hiFile- data RulesConfig = RulesConfig     { -- | Disable import cycle checking for improved performance in large codebases       checkForImportCycles :: Bool@@ -1118,13 +1207,16 @@         displayTHWarning             | not isWindows && not hostIsDynamic = do                 LSP.sendNotification SWindowShowMessage $-                    ShowMessageParams MtInfo $ T.unwords-                    [ "This HLS binary does not support Template Haskell."-                    , "Follow the [instructions](" <> templateHaskellInstructions <> ")"-                    , "to build an HLS binary with support for Template Haskell."-                    ]+                    ShowMessageParams MtInfo thWarningMessage             | otherwise = return () +thWarningMessage :: T.Text+thWarningMessage = T.unwords+  [ "This HLS binary does not support Template Haskell."+  , "Follow the [instructions](" <> templateHaskellInstructions <> ")"+  , "to build an HLS binary with support for Template Haskell."+  ]+ -- | A rule that wires per-file rules together mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules () mainRule recorder RulesConfig{..} = do@@ -1161,7 +1253,19 @@       else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing     generateCoreRule recorder     getImportMapRule recorder-    getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder)     persistentHieFileRule recorder     persistentDocMapRule     persistentImportMapRule+    getLinkableRule recorder++-- | Get HieFile for haskell file on NormalizedFilePath+getHieFile :: NormalizedFilePath -> Action (Maybe HieFile)+getHieFile nfp = runMaybeT $ do+  HAR {hieAst} <- MaybeT $ use GetHieAst nfp+  tmr <- MaybeT $ use TypeCheck nfp+  ghc <- MaybeT $ use GhcSession nfp+  msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp+  source <- lift $ getSourceFileSource nfp+  let exports = tcg_exports $ tmrTypechecked tmr+  typedAst <- MaybeT $ pure $ cast hieAst+  liftIO $ runHsc (hscEnv ghc) $ mkHieFile' (msrModSummary msr) exports typedAst source
src/Development/IDE/Core/Service.hs view
@@ -18,30 +18,31 @@     Log(..),     ) where -import           Control.Applicative             ((<|>))+import           Control.Applicative              ((<|>)) import           Development.IDE.Core.Debouncer-import           Development.IDE.Core.FileExists (fileExistsRules)-import           Development.IDE.Core.OfInterest hiding (Log, LogShake)+import           Development.IDE.Core.FileExists  (fileExistsRules)+import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph-import           Development.IDE.Types.Logger    as Logger (Logger,-                                                            Pretty (pretty),-                                                            Priority (Debug),-                                                            Recorder,-                                                            WithPriority,-                                                            cmapWithPrio)-import           Development.IDE.Types.Options   (IdeOptions (..))+import           Development.IDE.Types.Logger     as Logger (Logger,+                                                             Pretty (pretty),+                                                             Priority (Debug),+                                                             Recorder,+                                                             WithPriority,+                                                             cmapWithPrio)+import           Development.IDE.Types.Options    (IdeOptions (..)) import           Ide.Plugin.Config-import qualified Language.LSP.Server             as LSP-import qualified Language.LSP.Types              as LSP+import qualified Language.LSP.Server              as LSP+import qualified Language.LSP.Types               as LSP  import           Control.Monad-import qualified Development.IDE.Core.FileExists as FileExists-import qualified Development.IDE.Core.OfInterest as OfInterest-import           Development.IDE.Core.Shake      hiding (Log)-import qualified Development.IDE.Core.Shake      as Shake-import           Development.IDE.Types.Shake     (WithHieDb)-import           System.Environment              (lookupEnv)-+import qualified Development.IDE.Core.FileExists  as FileExists+import qualified Development.IDE.Core.OfInterest  as OfInterest+import           Development.IDE.Core.Shake       hiding (Log)+import qualified Development.IDE.Core.Shake       as Shake+import           Development.IDE.Types.Monitoring (Monitoring)+import           Development.IDE.Types.Shake      (WithHieDb)+import           Ide.Types                        (IdePlugins)+import           System.Environment               (lookupEnv)  data Log   = LogShake Shake.Log@@ -61,6 +62,7 @@ -- | Initialise the Compiler Service. initialise :: Recorder (WithPriority Log)            -> Config+           -> IdePlugins IdeState            -> Rules ()            -> Maybe (LSP.LanguageContextEnv Config)            -> Logger@@ -68,8 +70,9 @@            -> IdeOptions            -> WithHieDb            -> IndexQueue+           -> Monitoring            -> IO IdeState-initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do+initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do     shakeProfiling <- do         let fromConf = optShakeProfiling options         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"@@ -78,6 +81,7 @@         (cmapWithPrio LogShake recorder)         lspEnv         defaultConfig+        plugins         logger         debouncer         shakeProfiling@@ -86,6 +90,7 @@         withHieDb         hiedbChan         (optShakeOptions options)+        metrics           $ do             addIdeGlobal $ GlobalIdeOptions options             ofInterestRules (cmapWithPrio LogOfInterest recorder)
src/Development/IDE/Core/Shake.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE RecursiveDo               #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE CPP                       #-}  -- | A Shake implementation of the compiler service. --@@ -99,10 +100,11 @@ import qualified Data.EnumMap.Strict                    as EM import           Data.Foldable                          (for_, toList) import           Data.Functor                           ((<&>))+import           Data.Functor.Identity+import           Data.Hashable import qualified Data.HashMap.Strict                    as HMap import           Data.HashSet                           (HashSet) import qualified Data.HashSet                           as HSet-import           Data.Hashable import           Data.IORef import           Data.List.Extra                        (foldl', partition,                                                          takeEnd)@@ -118,7 +120,6 @@ import           Data.Unique import           Data.Vector                            (Vector) import qualified Data.Vector                            as Vector-import           Debug.Trace.Flags                      (userTracingEnabled) import           Development.IDE.Core.Debouncer import           Development.IDE.Core.FileUtils         (getModTime) import           Development.IDE.Core.PositionMapping@@ -129,13 +130,17 @@                                                          NameCacheUpdater (..),                                                          initNameCache,                                                          knownKeyNames,-                                                         mkSplitUniqSupply,-                                                         upNameCache)+#if !MIN_VERSION_ghc(9,3,0)+                                                         upNameCache,+#endif+                                                         mkSplitUniqSupply+                                                         ) import           Development.IDE.GHC.Orphans            () import           Development.IDE.Graph                  hiding (ShakeValue) import qualified Development.IDE.Graph                  as Shake import           Development.IDE.Graph.Database         (ShakeDatabase,                                                          shakeGetBuildStep,+                                                         shakeGetDatabaseKeys,                                                          shakeNewDatabase,                                                          shakeProfileDatabase,                                                          shakeRunDatabaseForKeys)@@ -148,25 +153,27 @@ import           Development.IDE.Types.Location import           Development.IDE.Types.Logger           hiding (Priority) import qualified Development.IDE.Types.Logger           as Logger+import           Development.IDE.Types.Monitoring       (Monitoring (..)) import           Development.IDE.Types.Options import           Development.IDE.Types.Shake import qualified Focus import           GHC.Fingerprint+import           GHC.Stack                              (HasCallStack) import           HieDb.Types import           Ide.Plugin.Config import qualified Ide.PluginUtils                        as HLS-import           Ide.Types                              (PluginId)+import           Ide.Types                              (PluginId, IdePlugins) import           Language.LSP.Diagnostics import qualified Language.LSP.Server                    as LSP import           Language.LSP.Types import qualified Language.LSP.Types                     as LSP import           Language.LSP.Types.Capabilities-import           Language.LSP.VFS+import           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT import           OpenTelemetry.Eventlog import qualified StmContainers.Map                      as STM import           System.FilePath                        hiding (makeRelative)-import           System.IO.Unsafe (unsafePerformIO)+import           System.IO.Unsafe                       (unsafePerformIO) import           System.Time.Extra  data Log@@ -236,6 +243,7 @@      lspEnv :: Maybe (LSP.LanguageContextEnv Config)     ,debouncer :: Debouncer NormalizedUri     ,logger :: Logger+    ,idePlugins :: IdePlugins IdeState     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)       -- ^ Registry of global state used by rules.       -- Small and immutable after startup, so not worth using an STM.Map.@@ -258,7 +266,11 @@         -> String         -> [DelayedAction ()]         -> IO ()+#if MIN_VERSION_ghc(9,3,0)+    ,ideNc :: NameCache+#else     ,ideNc :: IORef NameCache+#endif     -- | A mapping of module name to known target (or candidate targets, if missing)     ,knownTargetsVar :: TVar (Hashed KnownTargets)     -- | A mapping of exported identifiers for local modules. Updated on kick@@ -320,7 +332,7 @@ -- | Read a virtual file from the current snapshot getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do-  vfs <- fmap vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras+  vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras   pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map  -- Take a snapshot of the current LSP VFS@@ -340,7 +352,7 @@         Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty         Nothing -> HMap.insert ty (toDyn x) mp -getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a+getIdeGlobalExtras :: forall a . (HasCallStack, IsIdeGlobal a) => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do     let typ = typeRep (Proxy :: Proxy a)     x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals@@ -350,13 +362,12 @@             | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"         Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ -getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a+getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras  getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a getIdeGlobalState = getIdeGlobalExtras . shakeExtras - newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions instance IsIdeGlobal GlobalIdeOptions @@ -388,7 +399,7 @@           | otherwise = do           pmap <- readTVarIO persistentKeys           mv <- runMaybeT $ do-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k+            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k             f <- MaybeT $ pure $ HMap.lookup (Key k) pmap             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv@@ -462,6 +473,7 @@     ,shakeSession         :: MVar ShakeSession     ,shakeExtras          :: ShakeExtras     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)+    ,stopMonitoring       :: IO ()     }  @@ -549,6 +561,7 @@ shakeOpen :: Recorder (WithPriority Log)           -> Maybe (LSP.LanguageContextEnv Config)           -> Config+          -> IdePlugins IdeState           -> Logger           -> Debouncer NormalizedUri           -> Maybe FilePath@@ -557,15 +570,22 @@           -> WithHieDb           -> IndexQueue           -> ShakeOptions+          -> Monitoring           -> Rules ()           -> IO IdeState-shakeOpen recorder lspEnv defaultConfig logger debouncer-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo+shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer+  shakeProfileDir (IdeReportProgress reportProgress)+  ideTesting@(IdeTesting testing)+  withHieDb indexQueue opts monitoring rules = mdo     let log :: Logger.Priority -> Log -> IO ()         log = logWith recorder +#if MIN_VERSION_ghc(9,3,0)+    ideNc <- initNameCache 'r' knownKeyNames+#else     us <- mkSplitUniqSupply 'r'     ideNc <- newIORef (initNameCache us knownKeyNames)+#endif     shakeExtras <- do         globals <- newTVarIO HMap.empty         state <- STM.newIO@@ -608,37 +628,41 @@             rules     shakeSession <- newEmptyMVar     shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir-    let ideState = IdeState{..}      IdeOptions         { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled         , optProgressStyle+        , optCheckParents         } <- getIdeOptionsIO shakeExtras -    void $ startTelemetry shakeDb shakeExtras     startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras -    return ideState--startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ())-startTelemetry db extras@ShakeExtras{..}-  | userTracingEnabled = do-    countKeys <- mkValueObserver "cached keys count"-    countDirty <- mkValueObserver "dirty keys count"-    countBuilds <- mkValueObserver "builds count"-    IdeOptions{optCheckParents} <- getIdeOptionsIO extras     checkParents <- optCheckParents-    regularly 1 $ do-        observe countKeys . countRelevantKeys checkParents . map fst =<< (atomically . ListT.toList . STM.listT) state-        readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList-        shakeGetBuildStep db >>= observe countBuilds -  | otherwise = async (pure ())-    where-        regularly :: Seconds -> IO () -> IO (Async ())-        regularly delay act = async $ forever (act >> sleep delay)+    -- monitoring+    let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras)+        readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)+        readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras)+        readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb+        readDatabaseStep =  fromIntegral <$> shakeGetBuildStep shakeDb +    registerGauge monitoring "ghcide.values_count" readValuesCounter+    registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys+    registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending+    registerGauge monitoring "ghcide.exports_map_count" readExportsMap+    registerGauge monitoring "ghcide.database_count" readDatabaseCount+    registerCounter monitoring "ghcide.num_builds" readDatabaseStep +    stopMonitoring <- start monitoring++    let ideState = IdeState{..}+    return ideState+++getStateKeys :: ShakeExtras -> IO [Key]+getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state+ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do@@ -657,6 +681,7 @@     for_ runner cancelShakeSession     void $ shakeDatabaseProfile shakeDb     progressStop $ progress shakeExtras+    stopMonitoring   -- | This is a variant of withMVar where the first argument is run unmasked and if it throws@@ -695,18 +720,8 @@               backlog <- readTVarIO $ dirtyKeys shakeExtras               queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras +              -- this log is required by tests               log Debug $ LogBuildSessionRestart reason queue backlog stopTime res--              let profile = case res of-                      Just fp -> ", profile saved at " <> fp-                      _       -> ""-              -- TODO: should replace with logging using a logger that sends lsp message-              let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg-                  reason' = "due to " ++ reason-                  queueMsg = " with queue " ++ show (map actionName queue)-                  keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " "-                  abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")"-              notifyTestingLogMessage shakeExtras msg         )         -- It is crucial to be masked here, otherwise we can get killed         -- between spawning the new thread and updating shakeSession.@@ -719,13 +734,6 @@             sleep seconds             logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) -notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()-notifyTestingLogMessage extras msg = do-    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras-    let notif = LSP.LogMessageParams LSP.MtLog msg-    when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif-- -- | Enqueue an action in the existing 'ShakeSession'. --   Returns a computation to block until the action is run, propagating exceptions. --   Assumes a 'ShakeSession' is available.@@ -764,7 +772,7 @@      -- Take a new VFS snapshot     case vfsMod of-      VFSUnmodified -> pure ()+      VFSUnmodified   -> pure ()       VFSModified vfs -> atomically $ writeTVar vfsVar vfs      IdeOptions{optRunSubset} <- getIdeOptionsIO extras@@ -797,17 +805,12 @@           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)           res <- try @SomeException $             restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs-          let res' = case res of-                      Left e  -> "exception: " <> displayException e-                      Right _ -> "completed"-          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"           return $ do               let exception =                     case res of                       Left e -> Just e                       _      -> Nothing               logWith recorder Debug $ LogBuildSessionFinish exception-              notifyTestingLogMessage extras msg      -- Do the work in a background thread     workThread <- asyncWithUnmask workRun@@ -933,21 +936,21 @@ -- | Request a Rule result if available use :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe v)-use key file = head <$> uses key [file]+use key file = runIdentity <$> uses key (Identity file)  -- | Request a Rule result, it not available return the last computed result, if any, which may be stale useWithStale :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))-useWithStale key file = head <$> usesWithStale key [file]+useWithStale key file = runIdentity <$> usesWithStale key (Identity file)  -- | Request a Rule result, it not available return the last computed result which may be stale. --   Errors out if none available. useWithStale_ :: IdeRule k v     => k -> NormalizedFilePath -> Action (v, PositionMapping)-useWithStale_ key file = head <$> usesWithStale_ key [file]+useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)  -- | Plural version of 'useWithStale_'-usesWithStale_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [(v, PositionMapping)]+usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do     res <- usesWithStale key files     case sequence res of@@ -968,8 +971,14 @@ askShake :: IdeAction ShakeExtras askShake = ask ++#if MIN_VERSION_ghc(9,3,0)+mkUpdater :: NameCache -> NameCacheUpdater+mkUpdater = id+#else mkUpdater :: IORef NameCache -> NameCacheUpdater mkUpdater ref = NCU (upNameCache ref)+#endif  -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }@@ -1012,12 +1021,12 @@ useNoFile key = use key emptyFilePath  use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v-use_ key file = head <$> uses_ key [file]+use_ key file = runIdentity <$> uses_ key (Identity file)  useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath -uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]+uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do     res <- uses key files     case sequence res of@@ -1025,24 +1034,24 @@         Just v  -> return v  -- | Plural version of 'use'-uses :: IdeRule k v-    => k -> [NormalizedFilePath] -> Action [Maybe v]-uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)+uses :: (Traversable f, IdeRule k v)+    => k -> f NormalizedFilePath -> Action (f (Maybe v))+uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files)  -- | Return the last computed result which might be stale.-usesWithStale :: IdeRule k v-    => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]+usesWithStale :: (Traversable f, IdeRule k v)+    => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping))) usesWithStale key files = do-    _ <- apply (map (Q . (key,)) files)+    _ <- apply (fmap (Q . (key,)) files)     -- We don't look at the result of the 'apply' since 'lastValue' will     -- return the most recent successfully computed value regardless of     -- whether the rule succeeded or not.-    mapM (lastValue key) files+    traverse (lastValue key) files  useWithoutDependency :: IdeRule k v     => k -> NormalizedFilePath -> Action (Maybe v) useWithoutDependency key file =-    (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)]+    (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file)))  data RuleBody k v   = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
src/Development/IDE/GHC/CPP.hs view
@@ -34,6 +34,9 @@ import           DynFlags #endif #endif+#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Pipeline.Execute as Pipeline+#endif  addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0)
src/Development/IDE/GHC/Compat.hs view
@@ -9,12 +9,19 @@  -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(-    NameCacheUpdater(..),+    mkHomeModLocation,     hPutStringBuffer,     addIncludePathsQuote,     getModuleHash,     setUpTypedHoles,+    NameCacheUpdater(..),+#if MIN_VERSION_ghc(9,3,0)+    getMessages,+    renderDiagnosticMessageWithHints,+    nameEnvElts,+#else     upNameCache,+#endif     disableWarningsAsErrors,     reLoc,     reLocA,@@ -27,15 +34,21 @@ #endif  #if MIN_VERSION_ghc(9,2,0)+#if !MIN_VERSION_ghc(9,3,0)     extendModSummaryNoDeps,     emsModSummary,+#endif     myCoreToStgExpr, #endif +    FastStringCompat,     nodeInfo',     getNodeIds,-    nodeInfoFromSource,+    sourceNodeInfo,+    generatedNodeInfo,+    simpleNodeInfoCompat,     isAnnotationInNodeInfo,+    nodeAnnotations,     mkAstNode,     combineRealSrcSpans, @@ -59,7 +72,6 @@     -- * Compat modules     module Development.IDE.GHC.Compat.Core,     module Development.IDE.GHC.Compat.Env,-    module Development.IDE.GHC.Compat.ExactPrint,     module Development.IDE.GHC.Compat.Iface,     module Development.IDE.GHC.Compat.Logger,     module Development.IDE.GHC.Compat.Outputable,@@ -79,11 +91,16 @@     tidyExpr,     emptyTidyEnv,     corePrepExpr,+    corePrepPgm,     lintInteractiveExpr,     icInteractiveModule,     HomePackageTable,     lookupHpt,+#if MIN_VERSION_ghc(9,3,0)+    Dependencies(dep_direct_mods),+#else     Dependencies(dep_mods),+#endif     bcoFreeNames,     ModIfaceAnnotation,     pattern Annotation,@@ -93,6 +110,11 @@     module UniqSet,     module UniqDFM,     getDependentMods,+    flattenBinds,+    mkRnEnv2,+    emptyInScopeSet,+    Unfolding(..),+    noUnfolding, #if MIN_VERSION_ghc(9,2,0)     loadExpr,     byteCodeGen,@@ -106,9 +128,9 @@ #endif     ) where -import           Development.IDE.GHC.Compat.Core+import           Data.Bifunctor+import           Development.IDE.GHC.Compat.Core hiding (moduleUnitId) import           Development.IDE.GHC.Compat.Env-import           Development.IDE.GHC.Compat.ExactPrint import           Development.IDE.GHC.Compat.Iface import           Development.IDE.GHC.Compat.Logger import           Development.IDE.GHC.Compat.Outputable@@ -118,57 +140,78 @@ import           Development.IDE.GHC.Compat.Util import           GHC                                   hiding (HasSrcSpan,                                                         ModLocation,-                                                        RealSrcSpan, getLoc,-                                                        lookupName, exprType)+                                                        RealSrcSpan, exprType,+                                                        getLoc, lookupName)++import           Data.Coerce                           (coerce)+import           Data.String                           (IsString (fromString))++ #if MIN_VERSION_ghc(9,0,0)-import GHC.Driver.Hooks (hscCompileCoreExprHook)-import GHC.Core (CoreExpr, CoreProgram)-import qualified GHC.Core.Opt.Pipeline as GHC-import GHC.Core.Tidy (tidyExpr)-import GHC.Types.Var.Env (emptyTidyEnv)-import qualified GHC.CoreToStg.Prep as GHC-import GHC.Core.Lint (lintInteractiveExpr)+import           GHC.Core.Lint                         (lintInteractiveExpr)+import qualified GHC.Core.Opt.Pipeline                 as GHC+import           GHC.Core.Tidy                         (tidyExpr)+import           GHC.CoreToStg.Prep                    (corePrepPgm)+import qualified GHC.CoreToStg.Prep                    as GHC+import           GHC.Driver.Hooks                      (hscCompileCoreExprHook) #if MIN_VERSION_ghc(9,2,0)-import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable)-import GHC.Runtime.Context (icInteractiveModule)+import           GHC.Linker.Loader                     (loadExpr)+import           GHC.Linker.Types                      (isObjectLinkable)+import           GHC.Runtime.Context                   (icInteractiveModule)+import           GHC.Unit.Home.ModInfo                 (HomePackageTable,+                                                        lookupHpt)+#if MIN_VERSION_ghc(9,3,0)+import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods))+#else import GHC.Unit.Module.Deps (Dependencies(dep_mods))-import GHC.Linker.Types (isObjectLinkable)-import GHC.Linker.Loader (loadExpr)+#endif #else-import GHC.CoreToByteCode (coreExprToBCOs)-import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable)-import GHC.Runtime.Linker (linkExpr)+import           GHC.CoreToByteCode                    (coreExprToBCOs)+import           GHC.Driver.Types                      (Dependencies (dep_mods),+                                                        HomePackageTable,+                                                        icInteractiveModule,+                                                        lookupHpt)+import           GHC.Runtime.Linker                    (linkExpr) #endif-import GHC.ByteCode.Asm (bcoFreeNames)-import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)-import GHC.Types.Unique.DSet as UniqDSet-import GHC.Types.Unique.Set as UniqSet-import GHC.Types.Unique.DFM  as UniqDFM+import           GHC.ByteCode.Asm                      (bcoFreeNames)+import           GHC.Types.Annotations                 (AnnTarget (ModuleTarget),+                                                        Annotation (..),+                                                        extendAnnEnvList)+import           GHC.Types.Unique.DFM                  as UniqDFM+import           GHC.Types.Unique.DSet                 as UniqDSet+import           GHC.Types.Unique.Set                  as UniqSet #else-import Hooks (hscCompileCoreExprHook)-import CoreSyn (CoreExpr)-import qualified SimplCore as GHC-import CoreTidy (tidyExpr)-import VarEnv (emptyTidyEnv)-import CorePrep (corePrepExpr)-import CoreLint (lintInteractiveExpr)-import ByteCodeGen (coreExprToBCOs)-import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods))-import Linker (linkExpr)-import ByteCodeAsm (bcoFreeNames)-import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)-import UniqDSet-import UniqSet-import UniqDFM+import           Annotations                           (AnnTarget (ModuleTarget),+                                                        Annotation (..),+                                                        extendAnnEnvList)+import           ByteCodeAsm                           (bcoFreeNames)+import           ByteCodeGen                           (coreExprToBCOs)+import           CoreLint                              (lintInteractiveExpr)+import           CorePrep                              (corePrepExpr,+                                                        corePrepPgm)+import           CoreSyn                               (CoreExpr,+                                                        Unfolding (..),+                                                        flattenBinds,+                                                        noUnfolding)+import           CoreTidy                              (tidyExpr)+import           Hooks                                 (hscCompileCoreExprHook)+import           Linker                                (linkExpr)+import qualified SimplCore                             as GHC+import           UniqDFM+import           UniqDSet+import           UniqSet+import           VarEnv                                (emptyInScopeSet,+                                                        emptyTidyEnv, mkRnEnv2) #endif  #if MIN_VERSION_ghc(9,0,0)+import           GHC.Core import           GHC.Data.StringBuffer import           GHC.Driver.Session                    hiding (ExposePackage) import qualified GHC.Types.SrcLoc                      as SrcLoc+import           GHC.Types.Var.Env import           GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0)-import           Data.Bifunctor import           GHC.Driver.Env                        as Env import           GHC.Unit.Module.ModIface import           GHC.Unit.Module.ModSummary@@ -201,51 +244,65 @@  import           Compat.HieAst                         (enrichHie) import           Compat.HieBin-import           Compat.HieTypes+import           Compat.HieTypes                       hiding (nodeAnnotations)+import qualified Compat.HieTypes                       as GHC (nodeAnnotations) import           Compat.HieUtils import qualified Data.ByteString                       as BS import           Data.IORef  import           Data.List                             (foldl') import qualified Data.Map                              as Map-import qualified Data.Set                              as Set--#if MIN_VERSION_ghc(9,0,0) import qualified Data.Set                              as S-#endif  #if !MIN_VERSION_ghc(8,10,0) import           Bag                                   (unitBag) #endif  #if MIN_VERSION_ghc(9,2,0)-import GHC.Types.CostCentre-import GHC.Stg.Syntax-import GHC.Types.IPE-import GHC.Stg.Syntax-import GHC.Types.IPE-import GHC.Types.CostCentre-import GHC.Core-import GHC.Builtin.Uniques-import GHC.Runtime.Interpreter-import GHC.StgToByteCode-import GHC.Stg.Pipeline-import GHC.ByteCode.Types-import GHC.Linker.Loader (loadDecls)-import GHC.Data.Maybe-import GHC.CoreToStg+import           GHC.Builtin.Uniques+import           GHC.ByteCode.Types+import           GHC.CoreToStg+import           GHC.Data.Maybe+import           GHC.Linker.Loader                     (loadDecls)+import           GHC.Runtime.Interpreter+import           GHC.Stg.Pipeline+import           GHC.Stg.Syntax+import           GHC.StgToByteCode+import           GHC.Types.CostCentre+import           GHC.Types.IPE #endif +#if MIN_VERSION_ghc(9,3,0)+import GHC.Types.Error+import GHC.Driver.Config.Stg.Pipeline+#endif+ type ModIfaceAnnotation = Annotation +#if MIN_VERSION_ghc(9,3,0)+nameEnvElts :: NameEnv a -> [a]+nameEnvElts = nonDetNameEnvElts+#endif+ #if MIN_VERSION_ghc(9,2,0) myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+#if MIN_VERSION_ghc(9,3,0)+            -> Bool+#endif                 -> Module -> ModLocation -> CoreExpr                 -> IO ( Id-                      , [StgTopBinding]+#if MIN_VERSION_ghc(9,3,0)+                      ,[CgStgTopBinding] -- output program+#else+                      ,[StgTopBinding] -- output program+#endif                       , InfoTableProvMap                       , CollectedCCs )-myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do+myCoreToStgExpr logger dflags ictxt+#if MIN_VERSION_ghc(9,3,0)+                for_bytecode+#endif+                this_mod ml prepd_expr = do     {- Create a temporary binding (just because myCoreToStg needs a        binding for the stg2stg step) -}     let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")@@ -256,24 +313,46 @@        myCoreToStg logger                    dflags                    ictxt+#if MIN_VERSION_ghc(9,3,0)+                   for_bytecode+#endif                    this_mod                    ml                    [NonRec bco_tmp_id prepd_expr]     return (bco_tmp_id, stg_binds, prov_map, collected_ccs)  myCoreToStg :: Logger -> DynFlags -> InteractiveContext+#if MIN_VERSION_ghc(9,3,0)+            -> Bool+#endif             -> Module -> ModLocation -> CoreProgram+#if MIN_VERSION_ghc(9,3,0)+            -> IO ( [CgStgTopBinding] -- output program+#else             -> IO ( [StgTopBinding] -- output program+#endif                   , InfoTableProvMap                   , CollectedCCs )  -- CAF cost centre info (declared and used)-myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do+myCoreToStg logger dflags ictxt+#if MIN_VERSION_ghc(9,3,0)+            for_bytecode+#endif+            this_mod ml prepd_binds = do     let (stg_binds, denv, cost_centre_info)          = {-# SCC "Core2Stg" #-}            coreToStg dflags this_mod ml prepd_binds +#if MIN_VERSION_ghc(9,4,2)+    (stg_binds2,_)+#else     stg_binds2+#endif         <- {-# SCC "Stg2Stg" #-}+#if MIN_VERSION_ghc(9,3,0)+           stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds+#else            stg2stg logger dflags ictxt this_mod stg_binds+#endif      return (stg_binds2, denv, cost_centre_info) #endif@@ -288,7 +367,9 @@ #endif  getDependentMods :: ModIface -> [ModuleName]-#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,3,0)+getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps+#elif MIN_VERSION_ghc(9,0,0) getDependentMods = map gwib_mod . dep_mods . mi_deps #else getDependentMods = map fst . dep_mods . mi_deps@@ -314,9 +395,15 @@ #if MIN_VERSION_ghc(9,2,0) type ErrMsg  = MsgEnvelope DecoratedSDoc #endif+#if MIN_VERSION_ghc(9,3,0)+type WarnMsg  = MsgEnvelope DecoratedSDoc+#endif  getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg) getMessages' pst dflags =+#if MIN_VERSION_ghc(9,3,0)+  bimap (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) $ getPsMessages pst+#else #if MIN_VERSION_ghc(9,2,0)                  bimap (fmap pprWarning) (fmap pprError) $ #endif@@ -324,11 +411,16 @@ #if !MIN_VERSION_ghc(9,2,0)                    dflags #endif+#endif  #if MIN_VERSION_ghc(9,2,0) pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a pattern PFailedWithErrorMessages msgs+#if MIN_VERSION_ghc(9,3,0)+     <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs)+#else      <- PFailed (const . fmap pprError . getErrorMessages -> msgs)+#endif #elif MIN_VERSION_ghc(8,10,0) pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a pattern PFailedWithErrorMessages msgs@@ -341,7 +433,7 @@ mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err) mkPlainErrMsgIfPFailed _ = Nothing #endif-{-# COMPLETE PFailedWithErrorMessages #-}+{-# COMPLETE POk, PFailedWithErrorMessages #-}  supportsHieFiles :: Bool supportsHieFiles = True@@ -349,7 +441,9 @@ hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -+#if MIN_VERSION_ghc(9,3,0)+type NameCacheUpdater = NameCache+#else upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c #if MIN_VERSION_ghc(8,8,0) upNameCache = updNameCache@@ -357,6 +451,7 @@ upNameCache ref upd_fn   = atomicModifyIORef' ref upd_fn #endif+#endif  #if !MIN_VERSION_ghc(9,0,1) type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)]@@ -496,26 +591,36 @@ -- unhelpfulSpanFS = id #endif -nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a)+sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a) #if MIN_VERSION_ghc(9,0,0)-nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo+sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo #else-nodeInfoFromSource = Just . nodeInfo+sourceNodeInfo = Just . nodeInfo #endif +generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a)+#if MIN_VERSION_ghc(9,0,0)+generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo+#else+generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the source+#endif+ data GhcVersion   = GHC86   | GHC88   | GHC810   | GHC90   | GHC92+  | GHC94   deriving (Eq, Ord, Show)  ghcVersionStr :: String ghcVersionStr = VERSION_ghc  ghcVersion :: GhcVersion-#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)+ghcVersion = GHC94+#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) ghcVersion = GHC92 #elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90@@ -543,11 +648,31 @@     const SysTools.runPp #endif -isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool+simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a+simpleNodeInfoCompat ctor typ = simpleNodeInfo (coerce ctor) (coerce typ)++isAnnotationInNodeInfo :: (FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool+isAnnotationInNodeInfo p = S.member p . nodeAnnotations++nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat) #if MIN_VERSION_ghc(9,2,0)-isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations+nodeAnnotations = S.map (\(NodeAnnotation ctor typ) -> (coerce ctor, coerce typ)) . GHC.nodeAnnotations #else-isAnnotationInNodeInfo p = Set.member p . nodeAnnotations+nodeAnnotations = S.map (bimap coerce coerce) . GHC.nodeAnnotations+#endif++#if MIN_VERSION_ghc(9,2,0)+newtype FastStringCompat = FastStringCompat LexicalFastString+#else+newtype FastStringCompat = FastStringCompat FastString+#endif+    deriving (Show, Eq, Ord)++instance IsString FastStringCompat where+#if MIN_VERSION_ghc(9,2,0)+    fromString = FastStringCompat . LexicalFastString . fromString+#else+    fromString = FastStringCompat . fromString #endif  mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a
src/Development/IDE/GHC/Compat/Core.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds   #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE ViewPatterns   #-} -- TODO: remove {-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} @@ -61,7 +62,9 @@     pattern ExposePackage,     parseDynamicFlagsCmdLine,     parseDynamicFilePragma,+#if !MIN_VERSION_ghc(9,3,0)     WarnReason(..),+#endif     wWarningFlags,     updOptLevel,     -- slightly unsafe@@ -84,7 +87,9 @@     HscSource(..),     WhereFrom(..),     loadInterface,+#if !MIN_VERSION_ghc(9,3,0)     SourceModified(..),+#endif     loadModuleInterface,     RecompileRequired(..), #if MIN_VERSION_ghc(8,10,0)@@ -102,6 +107,10 @@ #endif     -- * Fixity     LexicalFixity(..),+    Fixity (..),+    mi_fix,+    defaultFixity,+    lookupFixityRn,     -- * ModSummary     ModSummary(..),     -- * HomeModInfo@@ -184,12 +193,17 @@     hscInteractive,     hscSimplify,     hscTypecheckRename,-    makeSimpleDetails,+    Development.IDE.GHC.Compat.Core.makeSimpleDetails,     -- * Typecheck utils     Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars,     Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe,     typecheckIface,-    mkIfaceTc,+    Development.IDE.GHC.Compat.Core.mkIfaceTc,+    Development.IDE.GHC.Compat.Core.mkBootModDetailsTc,+    Development.IDE.GHC.Compat.Core.initTidyOpts,+    hscUpdateHPT,+    driverNoStop,+    tidyProgram,     ImportedModsVal(..),     importedByUser,     GHC.TypecheckedSource,@@ -201,6 +215,7 @@     getLocA,     locA,     noLocA,+    unLocA,     LocatedAn, #if MIN_VERSION_ghc(9,2,0)     GHC.AnnListItem(..),@@ -293,7 +308,6 @@     Warn(..),     -- * ModLocation     GHC.ModLocation,-    pattern ModLocation,     Module.ml_hs_file,     Module.ml_obj_file,     Module.ml_hi_file,@@ -305,6 +319,7 @@     -- * Panic     PlainGhcException,     panic,+    panicDoc,     -- * Other     GHC.CoreModule(..),     GHC.SafeHaskellMode(..),@@ -344,7 +359,6 @@     module GHC.HsToCore.Expr,     module GHC.HsToCore.Monad, -    module GHC.Iface.Tidy,     module GHC.Iface.Syntax,  #if MIN_VERSION_ghc(9,2,0)@@ -377,6 +391,7 @@     module GHC.Types.Name.Cache,     module GHC.Types.Name.Env,     module GHC.Types.Name.Reader,+    module GHC.Utils.Error, #if MIN_VERSION_ghc(9,2,0)     module GHC.Types.Avail,     module GHC.Types.SourceFile,@@ -387,7 +402,6 @@     module GHC.Types.Unique.Supply,     module GHC.Types.Var,     module GHC.Unit.Module,-    module GHC.Utils.Error, #else     module BasicTypes,     module Class,@@ -425,7 +439,6 @@     module TcRnTypes,     module TcRnDriver,     module TcRnMonad,-    module TidyPgm,     module TyCon,     module TysPrim,     module TysWiredIn,@@ -462,10 +475,45 @@     module Parser,     module Lexer, #endif+#if MIN_VERSION_ghc(9,3,0)+    CompileReason(..),+    hsc_type_env_vars,+    hscUpdateHUG, hscUpdateHPT, hsc_HUG,+    GhcMessage(..),+    getKey,+    module GHC.Driver.Env.KnotVars,+    module GHC.Iface.Recomp,+    module GHC.Linker.Types,+    module GHC.Unit.Module.Graph,+    module GHC.Types.Unique.Map,+    module GHC.Utils.TmpFs,+    module GHC.Utils.Panic,+    module GHC.Unit.Finder.Types,+    module GHC.Unit.Env,+    module GHC.Driver.Phases,+#endif     ) where  import qualified GHC +#if MIN_VERSION_ghc(9,3,0)+import GHC.Iface.Recomp (CompileReason(..))+import GHC.Driver.Env.Types (hsc_type_env_vars)+import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG)+import GHC.Driver.Env.KnotVars+import GHC.Iface.Recomp+import GHC.Linker.Types+import GHC.Unit.Module.Graph+import GHC.Driver.Errors.Types+import GHC.Types.Unique.Map+import GHC.Types.Unique+import GHC.Utils.TmpFs+import GHC.Utils.Panic+import GHC.Unit.Finder.Types+import GHC.Unit.Env+import GHC.Driver.Phases+#endif+ #if MIN_VERSION_ghc(9,0,0) import           GHC.Builtin.Names            hiding (Unique, printName) import           GHC.Builtin.Types@@ -479,6 +527,10 @@ import           GHC.Core.FamInstEnv          hiding (pprFamInst) import           GHC.Core.InstEnv import           GHC.Types.Unique.FM+#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Config.Tidy       as GHC+import qualified GHC.Data.Strict              as Strict+#endif #if MIN_VERSION_ghc(9,2,0) import           GHC.Data.Bag import           GHC.Core.Multiplicity        (scaledThing)@@ -500,13 +552,13 @@ #if MIN_VERSION_ghc(9,2,0) import           GHC.Driver.Env #else-import           GHC.Driver.Finder+import           GHC.Driver.Finder hiding     (mkHomeModLocation) import           GHC.Driver.Types import           GHC.Driver.Ways #endif import           GHC.Driver.CmdLine           (Warn (..)) import           GHC.Driver.Hooks-import           GHC.Driver.Main+import           GHC.Driver.Main              as GHC import           GHC.Driver.Monad import           GHC.Driver.Phases import           GHC.Driver.Pipeline@@ -532,11 +584,11 @@ import           GHC.HsToCore.Expr import           GHC.HsToCore.Monad import           GHC.Iface.Load-import           GHC.Iface.Make               (mkFullIface, mkIfaceTc,-                                               mkPartialIface)+import           GHC.Iface.Make               (mkFullIface, mkPartialIface)+import           GHC.Iface.Make               as GHC import           GHC.Iface.Recomp import           GHC.Iface.Syntax-import           GHC.Iface.Tidy+import           GHC.Iface.Tidy               as GHC import           GHC.IfaceToCore import           GHC.Parser import           GHC.Parser.Header            hiding (getImports)@@ -551,6 +603,7 @@ import           GHC.Parser.Lexer import qualified GHC.Runtime.Linker           as Linker #endif+import           GHC.Rename.Fixity            (lookupFixityRn) import           GHC.Rename.Names import           GHC.Rename.Splice import qualified GHC.Runtime.Interpreter      as GHCi@@ -567,7 +620,7 @@ import qualified GHC.Types.Avail              as Avail #if MIN_VERSION_ghc(9,2,0) import           GHC.Types.Avail              (greNamePrintableName)-import           GHC.Types.Fixity             (LexicalFixity (..))+import           GHC.Types.Fixity             (LexicalFixity (..), Fixity (..), defaultFixity) #endif #if MIN_VERSION_ghc(9,2,0) import           GHC.Types.Meta@@ -582,7 +635,10 @@ #if MIN_VERSION_ghc(9,2,0) import           GHC.Types.Name.Set import           GHC.Types.SourceFile         (HscSource (..),-                                               SourceModified (..))+#if !MIN_VERSION_ghc(9,3,0)+                                               SourceModified(..)+#endif+                                               ) import           GHC.Types.SourceText import           GHC.Types.Target             (Target (..), TargetId (..)) import           GHC.Types.TyThing@@ -598,7 +654,7 @@ import           GHC.Types.Var                (Var (varName), setTyVarUnique,                                                setVarUnique) #if MIN_VERSION_ghc(9,2,0)-import           GHC.Unit.Finder+import           GHC.Unit.Finder              hiding (mkHomeModLocation) import           GHC.Unit.Home.ModInfo #endif import           GHC.Unit.Info                (PackageName (..))@@ -612,11 +668,11 @@ import           GHC.Unit.Module.ModDetails import           GHC.Unit.Module.ModGuts import           GHC.Unit.Module.ModIface     (IfaceExport, ModIface (..),-                                               ModIface_ (..))+                                               ModIface_ (..), mi_fix) import           GHC.Unit.Module.ModSummary   (ModSummary (..)) #endif import           GHC.Unit.State               (ModuleOrigin (..))-import           GHC.Utils.Error              (Severity (..))+import           GHC.Utils.Error              (Severity (..), emptyMessages) import           GHC.Utils.Panic              hiding (try) import qualified GHC.Utils.Panic.Plain        as Plain #else@@ -638,7 +694,7 @@ import           ExtractDocs import           FamInst import           FamInstEnv-import           Finder+import           Finder                       hiding (mkHomeModLocation) #if MIN_VERSION_ghc(8,10,0) import           GHC.Hs                       hiding (HsLet, LetStmt) #endif@@ -646,7 +702,7 @@ import           GhcMonad import           HeaderInfo                   hiding (getImports) import           Hooks-import           HscMain+import           HscMain                      as GHC import           HscTypes #if !MIN_VERSION_ghc(8,10,0) -- Syntax imports@@ -668,7 +724,7 @@ import           Lexer                        hiding (getSrcLoc) import qualified Linker import           LoadIface-import           MkIface+import           MkIface                      as GHC import           Module                       hiding (ModLocation (..), UnitId,                                                addBootSuffixLocnOut,                                                moduleUnitId)@@ -687,6 +743,7 @@ #endif import           Parser import           PatSyn+import           RnFixity #if MIN_VERSION_ghc(8,8,0) import           Plugins #endif@@ -709,7 +766,7 @@ import           TcRnTypes import           TcType                       hiding (mkVisFunTys) import qualified TcType-import           TidyPgm+import           TidyPgm                     as GHC import qualified TyCoRep import           TyCon import           Type                         hiding (mkVisFunTys)@@ -743,14 +800,48 @@ #if MIN_VERSION_ghc(9,2,0) import           Language.Haskell.Syntax hiding (FunDep) #endif+#if MIN_VERSION_ghc(9,3,0)+import GHC.Driver.Env as GHCi+#endif +import Data.Foldable (toList)++#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Unit.Finder as GHC+import qualified GHC.Driver.Config.Finder as GHC+#elif MIN_VERSION_ghc(9,2,0)+import qualified GHC.Unit.Finder as GHC+#elif MIN_VERSION_ghc(9,0,0)+import qualified GHC.Driver.Finder as GHC+#else+import qualified Finder as GHC+#endif+++mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation+#if MIN_VERSION_ghc(9,3,0)+mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f+#else+mkHomeModLocation = GHC.mkHomeModLocation+#endif++ #if !MIN_VERSION_ghc(9,0,0) type BufSpan = () type BufPos = () #endif +#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan-#if MIN_VERSION_ghc(9,0,0)+#else+pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan+#endif++#if MIN_VERSION_ghc(9,3,0)+pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where+  RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a)++#elif MIN_VERSION_ghc(9,0,0) pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y #else pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where@@ -758,7 +849,11 @@ #endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} +#if MIN_VERSION_ghc(9,3,0)+pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc+#else pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc+#endif #if MIN_VERSION_ghc(9,0,0) pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y #else@@ -929,14 +1024,6 @@   tcSplitForAllTy_maybe #endif -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation-#if MIN_VERSION_ghc(8,8,0)-pattern ModLocation a b c <--    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""-#else-pattern ModLocation a b c <--    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c-#endif  #if !MIN_VERSION_ghc(8,10,0) noExtField :: GHC.NoExt@@ -1008,6 +1095,7 @@ #endif     hsc_env linkables +#if !MIN_VERSION_ghc(9,3,0) setOutputFile :: FilePath -> DynFlags -> DynFlags setOutputFile f d = d { #if MIN_VERSION_ghc(9,2,0)@@ -1016,6 +1104,7 @@   outputFile     = Just f #endif   }+#endif  isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool #if MIN_VERSION_ghc(9,2,0)@@ -1038,6 +1127,13 @@ #endif  #if MIN_VERSION_ghc(9,2,0)+unLocA :: forall pass a. XRec (GhcPass pass) a -> a+unLocA = unXRec @(GhcPass pass)+#else+unLocA = id+#endif++#if MIN_VERSION_ghc(9,2,0) getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan getLocA = GHC.getLocA #else@@ -1065,7 +1161,7 @@ #if MIN_VERSION_ghc(9,2,0) pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE     {gre_name = (greNamePrintableName -> gre_name)-    ,gre_par, gre_lcl, gre_imp}+    ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} #else pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..} #endif@@ -1083,4 +1179,56 @@ #if !MIN_VERSION_ghc(9,2,0) rationalFromFractionalLit :: FractionalLit -> Rational rationalFromFractionalLit = fl_value+#endif++makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails+makeSimpleDetails hsc_env =+  GHC.makeSimpleDetails+#if MIN_VERSION_ghc(9,3,0)+              (hsc_logger hsc_env)+#else+              hsc_env+#endif++mkIfaceTc hsc_env sf details ms tcGblEnv =+#if MIN_VERSION_ghc(8,10,0)+  GHC.mkIfaceTc hsc_env sf details+#if MIN_VERSION_ghc(9,3,0)+              ms+#endif+              tcGblEnv+#else+  fst <$> GHC.mkIfaceTc hsc_env Nothing sf details tcGblEnv+#endif++mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc session = GHC.mkBootModDetailsTc+#if MIN_VERSION_ghc(9,3,0)+          (hsc_logger session)+#else+          session+#endif++#if !MIN_VERSION_ghc(9,3,0)+type TidyOpts = HscEnv+#endif++initTidyOpts :: HscEnv -> IO TidyOpts+initTidyOpts =+#if MIN_VERSION_ghc(9,3,0)+  GHC.initTidyOpts+#else+  pure+#endif++driverNoStop =+#if MIN_VERSION_ghc(9,3,0)+                                         NoStop+#else+                                         StopLn+#endif++#if !MIN_VERSION_ghc(9,3,0)+hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv+hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } #endif
src/Development/IDE/GHC/Compat/Env.hs view
@@ -3,7 +3,14 @@ -- | Compat module for the main Driver types, such as 'HscEnv', -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env (-    Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var),+    Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph+#if MIN_VERSION_ghc(9,3,0)+              , hsc_type_env_vars+#else+              , hsc_type_env_var+#endif+              ),+    Env.hsc_HPT,     InteractiveContext(..),     setInteractivePrintName,     setInteractiveDynFlags,@@ -51,7 +58,11 @@ #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import           GHC.Driver.Backend   as Backend+#if MIN_VERSION_ghc(9,3,0)+import           GHC.Driver.Env       (HscEnv)+#else import           GHC.Driver.Env       (HscEnv, hsc_EPS)+#endif import qualified GHC.Driver.Env       as Env import qualified GHC.Driver.Session   as Session import           GHC.Platform.Ways    hiding (hostFullWays)@@ -78,6 +89,11 @@ import           Hooks import           HscTypes             as Env import           Module+#endif++#if MIN_VERSION_ghc(9,3,0)+hsc_EPS :: HscEnv -> UnitEnv+hsc_EPS = hsc_unit_env #endif  #if MIN_VERSION_ghc(9,0,0)
− src/Development/IDE/GHC/Compat/ExactPrint.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms   #-}---- | This module contains compatibility constructs to write type signatures across---   multiple ghc-exactprint versions, accepting that anything more ambitious is---   pretty much impossible with the GHC 9.2 redesign of ghc-exactprint-module Development.IDE.GHC.Compat.ExactPrint-    ( ExactPrint-    , exactPrint-    , makeDeltaAst-    , Retrie.Annotated, pattern Annotated, astA, annsA-    ) where--#if !MIN_VERSION_ghc(9,2,0)-import           Control.Arrow                     ((&&&))-#else-import           Development.IDE.GHC.Compat.Parser-#endif-import           Language.Haskell.GHC.ExactPrint   as Retrie-import qualified Retrie.ExactPrint                 as Retrie--#if !MIN_VERSION_ghc(9,2,0)-class ExactPrint ast where-    makeDeltaAst :: ast -> ast-    makeDeltaAst = id--instance ExactPrint ast-#endif--#if !MIN_VERSION_ghc(9,2,0)-pattern Annotated :: ast -> Anns -> Retrie.Annotated ast-pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA))-#else-pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast-pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))-#endif
src/Development/IDE/GHC/Compat/Iface.hs view
@@ -7,6 +7,9 @@     ) where  import           GHC+#if MIN_VERSION_ghc(9,3,0)+import           GHC.Driver.Session (targetProfile)+#endif #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Iface.Load                        as Iface import           GHC.Unit.Finder.Types                 (FindResult)@@ -24,7 +27,9 @@ import           Development.IDE.GHC.Compat.Outputable  writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,3,0)+writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface+#elif MIN_VERSION_ghc(9,2,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface #elif MIN_VERSION_ghc(9,0,0) writeIfaceFile env = Iface.writeIface (hsc_dflags env)
src/Development/IDE/GHC/Compat/Logger.hs view
@@ -24,6 +24,9 @@ import           DynFlags import           Outputable                            (queryQual) #endif+#if MIN_VERSION_ghc(9,3,0)+import GHC.Types.Error+#endif  putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env =@@ -41,6 +44,15 @@   logger { Env.log_action = f (Env.log_action logger) } #endif +#if MIN_VERSION_ghc(9,3,0)+type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()++-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.+logActionCompat :: LogActionCompat -> LogAction+logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify+logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify++#else #if MIN_VERSION_ghc(9,0,0) type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () @@ -53,4 +65,5 @@  logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style)+#endif #endif
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -6,7 +6,7 @@     showSDoc,     showSDocUnsafe,     showSDocForUser,-    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest,+    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,     printSDocQualifiedUnsafe,     printWithoutUniques,     mkPrintUnqualified,@@ -17,8 +17,13 @@     -- * Parser errors     PsWarning,     PsError,+#if MIN_VERSION_ghc(9,3,0)+    DiagnosticReason(..),+    renderDiagnosticMessageWithHints,+#else     pprWarning,     pprError,+#endif     -- * Error infrastructure     DecoratedSDoc,     MsgEnvelope,@@ -35,7 +40,11 @@ import           GHC.Driver.Env import           GHC.Driver.Ppr import           GHC.Driver.Session+#if !MIN_VERSION_ghc(9,3,0) import           GHC.Parser.Errors+#else+import           GHC.Parser.Errors.Types+#endif import qualified GHC.Parser.Errors.Ppr           as Ppr import qualified GHC.Types.Error                 as Error import           GHC.Types.Name.Ppr@@ -44,7 +53,8 @@ import           GHC.Types.SrcLoc import           GHC.Unit.State import           GHC.Utils.Error                 hiding (mkWarnMsg)-import           GHC.Utils.Outputable            as Out hiding (defaultUserStyle)+import           GHC.Utils.Outputable            as Out hiding+                                                        (defaultUserStyle) import qualified GHC.Utils.Outputable            as Out import           GHC.Utils.Panic #elif MIN_VERSION_ghc(9,0,0)@@ -54,7 +64,8 @@ import           GHC.Types.SrcLoc import           GHC.Utils.Error                 as Err hiding (mkWarnMsg) import qualified GHC.Utils.Error                 as Err-import           GHC.Utils.Outputable            as Out hiding (defaultUserStyle)+import           GHC.Utils.Outputable            as Out hiding+                                                        (defaultUserStyle) import qualified GHC.Utils.Outputable            as Out #else import           Development.IDE.GHC.Compat.Core (GlobalRdrEnv)@@ -62,10 +73,16 @@ import           ErrUtils                        hiding (mkWarnMsg) import qualified ErrUtils                        as Err import           HscTypes-import           Outputable                      as Out hiding (defaultUserStyle)+import           Outputable                      as Out hiding+                                                        (defaultUserStyle) import qualified Outputable                      as Out import           SrcLoc #endif+#if MIN_VERSION_ghc(9,3,0)+import GHC.Utils.Logger+import GHC.Driver.Config.Diagnostic+import Data.Maybe+#endif  -- | A compatible function to print `Outputable` instances -- without unique symbols.@@ -122,6 +139,7 @@ oldFormatErrDoc = Err.formatErrDoc #endif +#if !MIN_VERSION_ghc(9,3,0) pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = #if MIN_VERSION_ghc(9,2,0)@@ -137,18 +155,27 @@ #else   id #endif+#endif  formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = #if MIN_VERSION_ghc(9,2,0)   showSDoc dflags (pprNoLocMsgEnvelope e) +#if MIN_VERSION_ghc(9,3,0)+pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc+#else pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc+#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e                                  , errMsgContext   = unqual })   = sdocWithContext $ \ctx ->     withErrStyle unqual $+#if MIN_VERSION_ghc(9,3,0)+      (formatBulleted ctx $ e)+#else       (formatBulleted ctx $ Error.renderDiagnostic e)+#endif  #else   Out.showSDoc dflags@@ -175,12 +202,22 @@   HscTypes.mkPrintUnqualified (hsc_dflags env) #endif -mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc-mkWarnMsg =+#if MIN_VERSION_ghc(9,3,0)+renderDiagnosticMessageWithHints :: Diagnostic a => a -> DecoratedSDoc+renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage a) (mkDecorated $ map ppr $ diagnosticHints a)+#endif++#if MIN_VERSION_ghc(9,3,0)+mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc+mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc)+#else+mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc+mkWarnMsg _ _ = #if MIN_VERSION_ghc(9,2,0)   const Error.mkWarnMsg #else   Err.mkWarnMsg+#endif #endif  defaultUserStyle :: PprStyle
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -62,7 +62,11 @@                                                   pm_mod_summary,                                                   pm_parsed_source) import qualified GHC+#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Config.Parser        as Config+#else import qualified GHC.Driver.Config               as Config+#endif import           GHC.Hs                          (LEpaComment, hpm_module,                                                   hpm_src_files) import           GHC.Parser.Lexer                hiding (initParserState)
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -24,6 +24,11 @@ import           GHC.Driver.Plugins                (Plugin (..),                                                     PluginWithArgs (..),                                                     StaticPlugin (..),+#if MIN_VERSION_ghc(9,3,0)+                                                    staticPlugins,+                                                    ParsedResult(..),+                                                    PsMessages(..),+#endif                                                     defaultPlugin, withPlugins) import qualified GHC.Runtime.Loader                as Loader #elif MIN_VERSION_ghc(8,8,0)@@ -42,15 +47,25 @@ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do   -- Apply parsedResultAction of plugins   let applyPluginAction p opts = parsedResultAction p opts ms+#if MIN_VERSION_ghc(9,3,0)+  fmap (hpm_module . parsedResultModule) $+#else   fmap hpm_module $+#endif     runHsc env $ withPlugins-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,3,0)+      (Env.hsc_plugins env)+#elif MIN_VERSION_ghc(9,2,0)       env #else       dflags #endif       applyPluginAction+#if MIN_VERSION_ghc(9,3,0)+      (ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty))+#else       (HsParsedModule parsed [] hpm_annotations)+#endif  initializePlugins :: HscEnv -> IO HscEnv initializePlugins env = do@@ -64,7 +79,9 @@  #if MIN_VERSION_ghc(8,8,0) hsc_static_plugins :: HscEnv -> [StaticPlugin]-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,3,0)+hsc_static_plugins = staticPlugins . Env.hsc_plugins+#elif MIN_VERSION_ghc(9,2,0) hsc_static_plugins = Env.hsc_static_plugins #else hsc_static_plugins = staticPlugins . hsc_dflags
src/Development/IDE/GHC/Compat/Units.hs view
@@ -5,7 +5,10 @@ module Development.IDE.GHC.Compat.Units (     -- * UnitState     UnitState,+#if MIN_VERSION_ghc(9,3,0)     initUnits,+#endif+    oldInitUnits,     unitState,     getUnitName,     explicitUnits,@@ -39,7 +42,7 @@     installedModule,     -- * Module     toUnitId,-    moduleUnitId,+    Development.IDE.GHC.Compat.Units.moduleUnitId,     moduleUnit,     -- * ExternalPackageState     ExternalPackageState(..),@@ -49,10 +52,18 @@     showSDocForUser',     ) where +import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import Control.Monad+#if MIN_VERSION_ghc(9,3,0)+import GHC.Unit.Home.ModInfo+#endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Data.ShortText              as ST+#if !MIN_VERSION_ghc(9,3,0) import           GHC.Driver.Env                  (hsc_unit_dbs)+#endif import           GHC.Driver.Ppr import           GHC.Unit.Env import           GHC.Unit.External@@ -128,37 +139,69 @@ unitState = DynFlags.pkgState . hsc_dflags #endif -initUnits :: HscEnv -> IO HscEnv-initUnits env = do-#if MIN_VERSION_ghc(9,2,0)-  let dflags1         = hsc_dflags env-  -- Copied from GHC.setSessionDynFlags-  let cached_unit_dbs = hsc_unit_dbs env-  (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs+#if MIN_VERSION_ghc(9,3,0)+createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph+createUnitEnvFromFlags unitDflags =+  let+    newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing+    unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags+  in+    unitEnv_new (Map.fromList (NE.toList (unitEnvList))) -  dflags <- DynFlags.updatePlatformConstants dflags1 mconstants+initUnits :: [DynFlags] -> HscEnv -> IO HscEnv+initUnits unitDflags env = do+  let dflags0         = hsc_dflags env+  -- additionally, set checked dflags so we don't lose fixes+  let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags)+      home_units = unitEnv_keys initial_home_graph+  home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+    let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+        dflags = homeUnitEnv_dflags homeUnitEnv+        old_hpt = homeUnitEnv_hpt homeUnitEnv +    (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags cached_unit_dbs home_units +    updated_dflags <- DynFlags.updatePlatformConstants dflags mconstants+    pure HomeUnitEnv+      { homeUnitEnv_units = unit_state+      , homeUnitEnv_unit_dbs = Just dbs+      , homeUnitEnv_dflags = updated_dflags+      , homeUnitEnv_hpt = old_hpt+      , homeUnitEnv_home_unit = Just home_unit+      }++  let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (homeUnitId_ dflags0) home_unit_graph   let unit_env = UnitEnv-        { ue_platform  = targetPlatform dflags-        , ue_namever   = DynFlags.ghcNameVersion dflags-        , ue_home_unit = home_unit-        , ue_units     = unit_state+        { ue_platform        = targetPlatform dflags1+        , ue_namever         = GHC.ghcNameVersion dflags1+        , ue_home_unit_graph = home_unit_graph+        , ue_current_unit    = homeUnitId_ dflags0+        , ue_eps             = ue_eps (hsc_unit_env env)         }-  pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env-    { hsc_unit_dbs = Just dbs-    }+  pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env+#endif++-- | oldInitUnits only needs to modify DynFlags for GHC <9.2+-- For GHC >= 9.2, we need to set the hsc_unit_env also, that is+-- done later by initUnits+oldInitUnits :: DynFlags -> IO DynFlags+#if MIN_VERSION_ghc(9,2,0)+oldInitUnits = pure #elif MIN_VERSION_ghc(9,0,0)-  newFlags <- State.initUnits $ hsc_dflags env-  pure $ hscSetFlags newFlags env+oldInitUnits dflags = do+  newFlags <- State.initUnits dflags+  pure newFlags #else-  newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env-  pure $ hscSetFlags newFlags env+oldInitUnits dflags = do+  newFlags <- fmap fst $ Packages.initPackages dflags+  pure newFlags #endif  explicitUnits :: UnitState -> [Unit] explicitUnits ue =-#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,3,0)+  map fst $ State.explicitUnits ue+#elif MIN_VERSION_ghc(9,0,0)   State.explicitUnits ue #else   Packages.explicitPackages ue@@ -180,7 +223,15 @@   packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) #endif -lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult+lookupModuleWithSuggestions+  :: HscEnv+  -> ModuleName+#if MIN_VERSION_ghc(9,3,0)+  -> GHC.PkgQual+#else+  -> Maybe FastString+#endif+  -> LookupResult lookupModuleWithSuggestions env modname mpkg = #if MIN_VERSION_ghc(9,0,0)   State.lookupModuleWithSuggestions (unitState env) modname mpkg
src/Development/IDE/GHC/Compat/Util.hs view
@@ -24,7 +24,9 @@     LBooleanFormula,     BooleanFormula(..),     -- * OverridingBool+#if !MIN_VERSION_ghc(9,3,0)     OverridingBool(..),+#endif     -- * Maybes     MaybeErr(..),     orElse,@@ -69,8 +71,6 @@     stringToStringBuffer,     nextChar,     atEnd,-    -- * Char-    is_ident     ) where  #if MIN_VERSION_ghc(9,0,0)@@ -83,7 +83,6 @@ import           GHC.Data.Maybe import           GHC.Data.Pair import           GHC.Data.StringBuffer-import           GHC.Parser.CharClass    (is_ident) import           GHC.Types.Unique import           GHC.Types.Unique.DFM import           GHC.Utils.Fingerprint@@ -93,7 +92,6 @@ #else import           Bag import           BooleanFormula-import           Ctype                   (is_ident) import           EnumSet import qualified Exception import           FastString
+ src/Development/IDE/GHC/CoreFile.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-}++-- | CoreFiles let us serialize Core to a file in order to later recover it+-- without reparsing or retypechecking+module Development.IDE.GHC.CoreFile+  ( CoreFile(..)+  , codeGutsToCoreFile+  , typecheckCoreFile+  , readBinCoreFile+  , writeBinCoreFile+  , getImplicitBinds) where++import           Control.Monad+import           Control.Monad.IO.Class+import           Data.Foldable+import           Data.IORef+import           Data.List                       (isPrefixOf)+import           Data.Maybe+import           GHC.Fingerprint++import           Development.IDE.GHC.Compat++#if MIN_VERSION_ghc(9,0,0)+import           GHC.Core+import           GHC.CoreToIface+import           GHC.Iface.Binary+import           GHC.Iface.Env+import           GHC.Iface.Recomp.Binary         (fingerprintBinMem)+import           GHC.IfaceToCore+import           GHC.Types.Id.Make+import           GHC.Utils.Binary++#if MIN_VERSION_ghc(9,2,0)+import           GHC.Types.TypeEnv+#else+import           GHC.Driver.Types+#endif++#elif MIN_VERSION_ghc(8,6,0)+import           Binary+import           BinFingerprint                  (fingerprintBinMem)+import           BinIface+import           CoreSyn+import           HscTypes+import           IdInfo+import           IfaceEnv+import           MkId+import           TcIface+import           ToIface+import           Unique+import           Var+#endif++import qualified Development.IDE.GHC.Compat.Util as Util++-- | Initial ram buffer to allocate for writing interface files+initBinMemSize :: Int+initBinMemSize = 1024 * 1024++data CoreFile+  = CoreFile+  { cf_bindings   :: [TopIfaceBinding IfaceId]+  -- ^ The actual core file bindings, deserialized lazily+  , cf_iface_hash :: !Fingerprint+  }++-- | Like IfaceBinding, but lets us serialize internal names as well+data TopIfaceBinding v+  = TopIfaceNonRec v IfaceExpr+  | TopIfaceRec    [(v, IfaceExpr)]+  deriving (Functor, Foldable, Traversable)++-- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType',+-- but it does export 'tcIfaceDecl'+-- so we use `IfaceDecl` as a container for all of these+-- invariant: 'IfaceId' is always a 'IfaceId' constructor+type IfaceId = IfaceDecl++instance Binary (TopIfaceBinding IfaceId) where+  put_ bh (TopIfaceNonRec d e) = do+    putByte bh 0+    put_ bh d+    put_ bh e+  put_ bh (TopIfaceRec vs) = do+    putByte bh 1+    put_ bh vs+  get bh = do+    t <- getByte bh+    case t of+      0 -> TopIfaceNonRec <$> get bh <*> get bh+      1 -> TopIfaceRec <$> get bh+      _ -> error "Binary TopIfaceBinding"++instance Binary CoreFile where+  put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp+  get bh = CoreFile <$> lazyGet bh <*> get bh++readBinCoreFile+  :: NameCacheUpdater+  -> FilePath+  -> IO (CoreFile, Fingerprint)+readBinCoreFile name_cache fat_hi_path = do+    bh <- readBinMem fat_hi_path+    file <- getWithUserData name_cache bh+    !fp <- Util.getFileHash fat_hi_path+    return (file, fp)++-- | Write a core file+writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint+writeBinCoreFile core_path fat_iface = do+    bh <- openBinMem initBinMemSize++    let quietTrace =+#if MIN_VERSION_ghc(9,2,0)+          QuietBinIFace+#else+          (const $ pure ())+#endif++    putWithUserData quietTrace bh fat_iface++    -- And send the result to the file+    writeBinMem bh core_path++    !fp <- fingerprintBinMem bh+    pure fp++-- Implicit binds aren't tidied, so we can't serialise them.+-- This isn't a problem however since we can regenerate them from the+-- original ModIface+codeGutsToCoreFile+  :: Fingerprint -- ^ Hash of the interface this was generated from+  -> CgGuts+  -> CoreFile+codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash++-- | Implicit binds can be generated from the interface and are not tidied,+-- so we must filter them out+isNotImplictBind :: CoreBind -> Bool+isNotImplictBind bind = any (not . isImplicitId) $ bindBindings bind++bindBindings :: CoreBind -> [Var]+bindBindings (NonRec b _) = [b]+bindBindings (Rec bnds)   = map fst bnds++getImplicitBinds :: TyCon -> [CoreBind]+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc+  where+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)++getTyConImplicitBinds :: TyCon -> [CoreBind]+getTyConImplicitBinds tc+  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId+  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))++getClassImplicitBinds :: Class -> [CoreBind]+getClassImplicitBinds cls+  = [ NonRec op (mkDictSelRhs cls val_index)+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]++get_defn :: Id -> CoreBind+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))++toIfaceTopBndr :: Module -> Id -> IfaceId+toIfaceTopBndr mod id+  = IfaceId (mangleDeclName mod $ getName id)+            (toIfaceType (idType id))+            (toIfaceIdDetails (idDetails id))+            (toIfaceIdInfo (idInfo id))++toIfaceTopBind :: Module -> Bind Id -> TopIfaceBinding IfaceId+toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIfaceExpr r)+toIfaceTopBind mod (Rec prs)    = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs]++typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram+typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) =+  initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do+    tcTopIfaceBindings type_var prepd_binding++-- | Internal names can't be serialized, so we mange them+-- to an external name and restore at deserialization time+-- This is necessary because we rely on stuffing TopIfaceBindings into+-- a IfaceId because we don't have access to 'tcIfaceType' etc..+mangleDeclName :: Module -> Name -> Name+mangleDeclName mod name+  | isExternalName name = name+  | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name)++-- | Mangle the module name too to avoid conflicts+mangleModule :: Module -> Module+mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod))++isGhcideModule :: Module -> Bool+isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod)++-- Is this a fake external name that we need to make into an internal name?+isGhcideName :: Name -> Bool+isGhcideName = isGhcideModule . nameModule++tcTopIfaceBindings :: IORef TypeEnv -> [TopIfaceBinding IfaceId]+          -> IfL [CoreBind]+tcTopIfaceBindings ty_var ver_decls+   = do+     int <- mapM (traverse $ tcIfaceId) ver_decls+     let all_ids = concatMap toList int+     liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids)+     extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int++tcIfaceId :: IfaceId -> IfL Id+tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name+  where+    unmangle_decl_name ifid@IfaceId{ ifName = name }+    -- Check if the name is mangled+      | isGhcideName name = do+        name' <- newIfaceName (mkVarOcc $ getOccString name)+        pure $ ifid{ ifName = name' }+      | otherwise = pure ifid+    -- invariant: 'IfaceId' is always a 'IfaceId' constructor+    getIfaceId (AnId id) = id+    getIfaceId _         = error "tcIfaceId: got non Id"++tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind+tc_iface_bindings (TopIfaceNonRec v e) = do+  e' <- tcIfaceExpr e+  pure $ NonRec v e'+tc_iface_bindings (TopIfaceRec vs) = do+  vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs+  pure $ Rec vs'
− src/Development/IDE/GHC/Dump.hs 
@@ -1,337 +0,0 @@-{-# LANGUAGE CPP #-}-module Development.IDE.GHC.Dump(showAstDataHtml) where-import           Data.Data                       hiding (Fixity)-import           Development.IDE.GHC.Compat      hiding (NameAnn)-#if MIN_VERSION_ghc(8,10,1)-import           GHC.Hs.Dump-#else-import           HsDumpAst-#endif-#if MIN_VERSION_ghc(9,2,1)-import qualified Data.ByteString                 as B-import           Development.IDE.GHC.Compat.Util-import           GHC.Hs-import           Generics.SYB                    (ext1Q, ext2Q, extQ)-#endif-#if MIN_VERSION_ghc(9,0,1)-import           GHC.Plugins-#else-import           GhcPlugins-#endif-import           Prelude                         hiding ((<>))---- | Show a GHC syntax tree in HTML.-#if MIN_VERSION_ghc(9,2,1)-showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc-#else-showAstDataHtml :: (Data a, Outputable a) => a -> SDoc-#endif-showAstDataHtml a0 = html $-    header $$-    body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat-        [-#if MIN_VERSION_ghc(9,2,1)-            li (pre $ text (exactPrint a0)),-            li (showAstDataHtml' a0),-            li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)-#else-            li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan a0)-#endif-        ])-  where-    tag = tag' []-    tag' attrs t cont =-        angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs])-        <> cont-        <> angleBrackets (char '/' <> text t)-    ul = tag' [("class", text (show @String "nested"))] "ul"-    li = tag "li"-    caret x = tag' [("class", text "caret")] "span" "" <+> x-    nested foo cts-#if MIN_VERSION_ghc(9,2,1)-      | cts == empty = foo-#endif-      | otherwise = foo $$ (caret $ ul cts)-    body cts = tag "body" $ cts $$ tag "script" (text js)-    header = tag "head" $ tag "style" $ text css-    html = tag "html"-    pre = tag "pre"-#if MIN_VERSION_ghc(9,2,1)-    showAstDataHtml' :: Data a => a -> SDoc-    showAstDataHtml' =-      (generic-              `ext1Q` list-              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan-              `extQ` annotation-              `extQ` annotationModule-              `extQ` annotationAddEpAnn-              `extQ` annotationGrhsAnn-              `extQ` annotationEpAnnHsCase-              `extQ` annotationEpAnnHsLet-              `extQ` annotationAnnList-              `extQ` annotationEpAnnImportDecl-              `extQ` annotationAnnParen-              `extQ` annotationTrailingAnn-              `extQ` annotationEpaLocation-              `extQ` addEpAnn-              `extQ` lit `extQ` litr `extQ` litt-              `extQ` sourceText-              `extQ` deltaPos-              `extQ` epaAnchor-              `extQ` anchorOp-              `extQ` bytestring-              `extQ` name `extQ` occName `extQ` moduleName `extQ` var-              `extQ` dataCon-              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity-              `ext2Q` located-              `extQ` srcSpanAnnA-              `extQ` srcSpanAnnL-              `extQ` srcSpanAnnP-              `extQ` srcSpanAnnC-              `extQ` srcSpanAnnN-              )--      where generic :: Data a => a -> SDoc-            generic t = nested (text $ showConstr (toConstr t))-                     (vcat (gmapQ (li . showAstDataHtml') t))--            string :: String -> SDoc-            string = text . normalize_newlines . show--            fastString :: FastString -> SDoc-            fastString s = braces $-                            text "FastString:"-                        <+> text (normalize_newlines . show $ s)--            bytestring :: B.ByteString -> SDoc-            bytestring = text . normalize_newlines . show--            list []  = brackets empty-            list [x] = "[]" $$ showAstDataHtml' x-            list xs  = nested "[]" (vcat $ map (li . showAstDataHtml') xs)--            -- Eliminate word-size dependence-            lit :: HsLit GhcPs -> SDoc-            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            lit l                  = generic l--            litr :: HsLit GhcRn -> SDoc-            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litr l                  = generic l--            litt :: HsLit GhcTc -> SDoc-            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litt l                  = generic l--            numericLit :: String -> Integer -> SourceText -> SDoc-            numericLit tag x s = braces $ hsep [ text tag-                                               , generic x-                                               , generic s ]--            sourceText :: SourceText -> SDoc-            sourceText NoSourceText     = text "NoSourceText"-            sourceText (SourceText src) = text "SourceText" <+> text src--            epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r)  = text "EpaSpan" <+> realSrcSpan r-            epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs--            anchorOp :: AnchorOperation -> SDoc-            anchorOp UnchangedAnchor  = "UnchangedAnchor"-            anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp--            deltaPos :: DeltaPos -> SDoc-            deltaPos (SameLine c) = text "SameLine" <+> ppr c-            deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c--            name :: Name -> SDoc-            name nm    = braces $ text "Name:" <+> ppr nm--            occName n  =  braces $-                          text "OccName:"-                      <+> text (occNameString n)--            moduleName :: ModuleName -> SDoc-            moduleName m = braces $ text "ModuleName:" <+> ppr m--            srcSpan :: SrcSpan -> SDoc-            srcSpan ss = char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))--            realSrcSpan :: RealSrcSpan -> SDoc-            realSrcSpan ss = braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))--            addEpAnn :: AddEpAnn -> SDoc-            addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s--            var  :: Var -> SDoc-            var v      = braces $ text "Var:" <+> ppr v--            dataCon :: DataCon -> SDoc-            dataCon c  = braces $ text "DataCon:" <+> ppr c--            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc-            bagRdrName bg =  braces $-                             text "Bag(LocatedA (HsBind GhcPs)):"-                          $$ (list . bagToList $ bg)--            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc-            bagName bg  =  braces $-                           text "Bag(LocatedA (HsBind Name)):"-                        $$ (list . bagToList $ bg)--            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc-            bagVar bg  =  braces $-                          text "Bag(LocatedA (HsBind Var)):"-                       $$ (list . bagToList $ bg)--            nameSet ns =  braces $-                          text "NameSet:"-                       $$ (list . nameSetElemsStable $ ns)--            fixity :: Fixity -> SDoc-            fixity fx =  braces $-                         text "Fixity:"-                     <+> ppr fx--            located :: (Data a, Data b) => GenLocated a b -> SDoc-            located (L ss a)-              = nested "L" $ (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a))--            -- ---------------------------            annotation :: EpAnn [AddEpAnn] -> SDoc-            annotation = annotation' (text "EpAnn [AddEpAnn]")--            annotationModule :: EpAnn AnnsModule -> SDoc-            annotationModule = annotation' (text "EpAnn AnnsModule")--            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc-            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")--            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc-            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")--            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc-            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")--            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc-            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")--            annotationAnnList :: EpAnn AnnList -> SDoc-            annotationAnnList = annotation' (text "EpAnn AnnList")--            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc-            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")--            annotationAnnParen :: EpAnn AnnParen -> SDoc-            annotationAnnParen = annotation' (text "EpAnn AnnParen")--            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc-            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")--            annotationEpaLocation :: EpAnn EpaLocation -> SDoc-            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")--            annotation' :: forall a .(Data a, Typeable a)-                       => SDoc -> EpAnn a -> SDoc-            annotation' tag anns = nested (text $ showConstr (toConstr anns))-              (vcat (map li $ gmapQ showAstDataHtml' anns))--            -- ---------------------------            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc-            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")--            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc-            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")--            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc-            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")--            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc-            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")--            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc-            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")--            locatedAnn'' :: forall a. (Typeable a, Data a)-              => SDoc -> SrcSpanAnn' a -> SDoc-            locatedAnn'' tag ss =-              case cast ss of-                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->-                      nested "SrcSpanAnn" $ (-                                 li(showAstDataHtml' ann)-                              $$ li(srcSpan s))-                Nothing -> text "locatedAnn:unmatched" <+> tag-                           <+> (text (showConstr (toConstr ss)))-#endif---normalize_newlines :: String -> String-normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs-normalize_newlines (x:xs)                 = x:normalize_newlines xs-normalize_newlines []                     = []--css :: String-css = unlines-  [ "body {background-color: black; color: white ;}"-  , "/* Remove default bullets */"-  , "ul, #myUL {"-  , "  list-style-type: none;"-  , "}"-  , "/* Remove margins and padding from the parent ul */"-  , "#myUL {"-  , "  margin: 0;                       "-  , "  padding: 0;                      "-  , "}                                  "-  , "/* Style the caret/arrow */        "-  , ".caret {                           "-  , "  cursor: pointer;                 "-  , "  user-select: none; /* Prevent text selection */"-  , "}                                  "-  , "/* Create the caret/arrow with a unicode, and style it */"-  , ".caret::before {                   "-  , "  content: \"\\25B6 \";                "-  , "  color: white;                    "-  , "  display: inline-block;           "-  , "  margin-right: 6px;               "-  , "}                                  "-  , "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */"-  , ".caret-down::before {              "-  , "  transform: rotate(90deg);        "-  , "}                                  "-  , "/* Hide the nested list */         "-  , ".nested {                          "-  , "  display: none;                   "-  , "}                                  "-  , "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */"-  , ".active {                          "-  , "  display: block;}"-  ]--js :: String-js = unlines-  [ "var toggler = document.getElementsByClassName(\"caret\");"-  , "var i;"-  , "for (i = 0; i < toggler.length; i++) {"-  , "  toggler[i].addEventListener(\"click\", function() {"-  , "    this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");"-  , "    this.classList.toggle(\"caret-down\");"-  , "  }); }"-  ]
src/Development/IDE/GHC/Error.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error@@ -121,13 +122,17 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity+#if !MIN_VERSION_ghc(9,3,0) toDSeverity SevOutput      = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump        = Nothing toDSeverity SevInfo        = Just DsInfo+toDSeverity SevFatal       = Just DsError+#else+toDSeverity SevIgnore      = Nothing+#endif toDSeverity SevWarning     = Just DsWarning toDSeverity SevError       = Just DsError-toDSeverity SevFatal       = Just DsError   -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given@@ -167,7 +172,11 @@       Right <$> ghcM     where         ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags-        sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages+        sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags+#if MIN_VERSION_ghc(9,3,0)+                                        . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages+#endif+                                        . srcErrorMessages   diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
− src/Development/IDE/GHC/ExactPrint.hs 
@@ -1,664 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DerivingVia            #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE TypeFamilies           #-}---- | This module hosts various abstractions and utility functions to work with ghc-exactprint.-module Development.IDE.GHC.ExactPrint-    ( Graft(..),-      graftDecls,-      graftDeclsWithM,-      annotate,-      annotateDecl,-      hoistGraft,-      graftWithM,-      graftExprWithM,-      genericGraftWithSmallestM,-      genericGraftWithLargestM,-      graftSmallestDeclsWithM,-      transform,-      transformM,-      ExactPrint(..),-#if !MIN_VERSION_ghc(9,2,0)-      Anns,-      Annotate,-      setPrecedingLinesT,-#else-      addParens,-      addParensToCtxt,-      modifyAnns,-      removeComma,-      -- * Helper function-      eqSrcSpan,-      epl,-      epAnn,-      removeTrailingComma,-#endif-      annotateParsedSource,-      getAnnotatedParsedSourceRule,-      GetAnnotatedParsedSource(..),-      ASTElement (..),-      ExceptStringT (..),-      TransformT,-      Log(..),-    )-where--import           Control.Applicative                     (Alternative)-import           Control.Arrow                           (right, (***))-import           Control.Monad-import qualified Control.Monad.Fail                      as Fail-import           Control.Monad.IO.Class                  (MonadIO)-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Zip-import           Data.Bifunctor-import           Data.Bool                               (bool)-import qualified Data.DList                              as DL-import           Data.Either.Extra                       (mapLeft)-import           Data.Foldable                           (Foldable (fold))-import           Data.Functor.Classes-import           Data.Functor.Contravariant-import           Data.Monoid                             (All (All), getAll)-import qualified Data.Text                               as T-import           Data.Traversable                        (for)-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service            (runAction)-import           Development.IDE.Core.Shake              hiding (Log)-import qualified Development.IDE.Core.Shake              as Shake-import           Development.IDE.GHC.Compat              hiding (parseImport,-                                                          parsePattern,-                                                          parseType)-import           Development.IDE.Graph                   (RuleResult, Rules)-import           Development.IDE.Graph.Classes-import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger            (Pretty (pretty),-                                                          Recorder,-                                                          WithPriority,-                                                          cmapWithPrio)-import qualified GHC.Generics                            as GHC-import           Generics.SYB-import           Generics.SYB.GHC-import           Ide.PluginUtils-import           Language.Haskell.GHC.ExactPrint.Parsers-import           Language.LSP.Types-import           Language.LSP.Types.Capabilities         (ClientCapabilities)-import           Retrie.ExactPrint                       hiding (Annotated (..),-                                                          parseDecl, parseExpr,-                                                          parsePattern,-                                                          parseType)-#if MIN_VERSION_ghc(9,2,0)-import           GHC                                     (EpAnn (..),-                                                          NameAdornment (NameParens),-                                                          NameAnn (..),-                                                          SrcSpanAnn' (SrcSpanAnn),-                                                          SrcSpanAnnA,-                                                          TrailingAnn (AddCommaAnn),-                                                          emptyComments,-                                                          spanAsAnchor)-import           GHC.Parser.Annotation                   (AnnContext (..),-                                                          DeltaPos (SameLine),-                                                          EpaLocation (EpaDelta))-#endif----------------------------------------------------------------------------------data Log = LogShake Shake.Log deriving Show--instance Pretty Log where-  pretty = \case-    LogShake shakeLog -> pretty shakeLog--data GetAnnotatedParsedSource = GetAnnotatedParsedSource-  deriving (Eq, Show, Typeable, GHC.Generic)--instance Hashable GetAnnotatedParsedSource-instance NFData GetAnnotatedParsedSource-type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource---- | Get the latest version of the annotated parse source with comments.-getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules ()-getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do-  pm <- use GetParsedModuleWithComments nfp-  return ([], fmap annotateParsedSource pm)--#if MIN_VERSION_ghc(9,2,0)-annotateParsedSource :: ParsedModule -> Annotated ParsedSource-annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0-#else-annotateParsedSource :: ParsedModule -> Annotated ParsedSource-annotateParsedSource = fixAnns-#endif----------------------------------------------------------------------------------{- | A transformation for grafting source trees together. Use the semigroup- instance to combine 'Graft's, and run them via 'transform'.--}-newtype Graft m a = Graft-    { runGraft :: DynFlags -> a -> TransformT m a-    }--hoistGraft :: (forall x. m x -> n x) -> Graft m a -> Graft n a-hoistGraft h (Graft f) = Graft (fmap (hoistTransform h) . f)--newtype ExceptStringT m a = ExceptStringT {runExceptString :: ExceptT String m a}-    deriving newtype-        ( MonadTrans-        , Monad-        , Functor-        , Applicative-        , Alternative-        , Foldable-        , Contravariant-        , MonadIO-        , Eq1-        , Ord1-        , Show1-        , Read1-        , MonadZip-        , MonadPlus-        , Eq-        , Ord-        , Show-        , Read-        )--instance Monad m => Fail.MonadFail (ExceptStringT m) where-    fail = ExceptStringT . ExceptT . pure . Left--instance Monad m => Semigroup (Graft m a) where-    Graft a <> Graft b = Graft $ \dflags -> a dflags >=> b dflags--instance Monad m => Monoid (Graft m a) where-    mempty = Graft $ const pure------------------------------------------------------------------------------------ | Convert a 'Graft' into a 'WorkspaceEdit'.-transform ::-    DynFlags ->-    ClientCapabilities ->-    Uri ->-    Graft (Either String) ParsedSource ->-    Annotated ParsedSource ->-    Either String WorkspaceEdit-transform dflags ccs uri f a = do-    let src = printA a-    a' <- transformA a $ runGraft f dflags-    let res = printA a'-    pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions------------------------------------------------------------------------------------ | Convert a 'Graft' into a 'WorkspaceEdit'.-transformM ::-    Monad m =>-    DynFlags ->-    ClientCapabilities ->-    Uri ->-    Graft (ExceptStringT m) ParsedSource ->-    Annotated ParsedSource ->-    m (Either String WorkspaceEdit)-transformM dflags ccs uri f a = runExceptT $-    runExceptString $ do-        let src = printA a-        a' <- transformA a $ runGraft f dflags-        let res = printA a'-        pure $ diffText ccs (uri, T.pack src) (T.pack res) IncludeDeletions----- | Returns whether or not this node requires its immediate children to have--- be parenthesized and have a leading space.------ A more natural type for this function would be to return @(Bool, Bool)@, but--- we use 'All' instead for its monoid instance.-needsParensSpace ::-    HsExpr GhcPs ->-    -- | (Needs parens, needs space)-    (All, All)-needsParensSpace HsLam{}         = (All False, All False)-needsParensSpace HsLamCase{}     = (All False, All True)-needsParensSpace HsApp{}         = mempty-needsParensSpace HsAppType{}     = mempty-needsParensSpace OpApp{}         = mempty-needsParensSpace HsPar{}         = (All False, All False)-needsParensSpace SectionL{}      = (All False, All False)-needsParensSpace SectionR{}      = (All False, All False)-needsParensSpace ExplicitTuple{} = (All False, All False)-needsParensSpace ExplicitSum{}   = (All False, All False)-needsParensSpace HsCase{}        = (All False, All True)-needsParensSpace HsIf{}          = (All False, All False)-needsParensSpace HsMultiIf{}     = (All False, All False)-needsParensSpace HsLet{}         = (All False, All True)-needsParensSpace HsDo{}          = (All False, All False)-needsParensSpace ExplicitList{}  = (All False, All False)-needsParensSpace RecordCon{}     = (All False, All True)-needsParensSpace RecordUpd{}     = mempty-needsParensSpace _               = mempty-----------------------------------------------------------------------------------{- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with the- given @Located ast@. The node at that position must already be a @Located- ast@, or this is a no-op.--}-graft' ::-    forall ast a l.-    (Data a, Typeable l, ASTElement l ast) =>-    -- | Do we need to insert a space before this grafting? In do blocks, the-    -- answer is no, or we will break layout. But in function applications,-    -- the answer is yes, or the function call won't get its argument. Yikes!-    ---    -- More often the answer is yes, so when in doubt, use that.-    Bool ->-    SrcSpan ->-    LocatedAn l ast ->-    Graft (Either String) a-graft' needs_space dst val = Graft $ \dflags a -> do-#if MIN_VERSION_ghc(9,2,0)-    val' <- annotate dflags needs_space val-#else-    (anns, val') <- annotate dflags needs_space val-    modifyAnnsT $ mappend anns-#endif-    pure $-        everywhere'-            ( mkT $-                \case-                    (L src _ :: LocatedAn l ast)-                        | locA src `eqSrcSpan` dst -> val'-                    l                         -> l-            )-            a----- | Like 'graft', but specialized to 'LHsExpr', and intelligently inserts--- parentheses if they're necessary.-graftExpr ::-    forall a.-    (Data a) =>-    SrcSpan ->-    LHsExpr GhcPs ->-    Graft (Either String) a-graftExpr dst val = Graft $ \dflags a -> do-    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a--    runGraft-      (graft' needs_space dst $ mk_parens val)-      dflags-      a--getNeedsSpaceAndParenthesize ::-    (ASTElement l ast, Data a) =>-    SrcSpan ->-    a ->-    (Bool, LocatedAn l ast -> LocatedAn l ast)-getNeedsSpaceAndParenthesize dst a =-  -- Traverse the tree, looking for our replacement node. But keep track of-  -- the context (parent HsExpr constructor) we're in while we do it. This-  -- lets us determine wehther or not we need parentheses.-  let (needs_parens, needs_space) =-          everythingWithContext (Nothing, Nothing) (<>)-            ( mkQ (mempty, ) $ \x s -> case x of-                (L src _ :: LHsExpr GhcPs) | locA src `eqSrcSpan` dst ->-                  (s, s)-                L _ x' -> (mempty, Just *** Just $ needsParensSpace x')-            ) a-   in ( maybe True getAll needs_space-      , bool id maybeParensAST $ maybe False getAll needs_parens-      )-----------------------------------------------------------------------------------graftExprWithM ::-    forall m a.-    (Fail.MonadFail m, Data a) =>-    SrcSpan ->-    (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) ->-    Graft m a-graftExprWithM dst trans = Graft $ \dflags a -> do-    let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a--    everywhereM'-        ( mkM $-            \case-                val@(L src _ :: LHsExpr GhcPs)-                    | locA src `eqSrcSpan` dst -> do-                        mval <- trans val-                        case mval of-                            Just val' -> do-#if MIN_VERSION_ghc(9,2,0)-                                val'' <--                                    hoistTransform (either Fail.fail pure)-                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))-                                pure val''-#else-                                (anns, val'') <--                                    hoistTransform (either Fail.fail pure)-                                        (annotate @AnnListItem @(HsExpr GhcPs) dflags needs_space (mk_parens val'))-                                modifyAnnsT $ mappend anns-                                pure val''-#endif-                            Nothing -> pure val-                l -> pure l-        )-        a--graftWithM ::-    forall ast m a l.-    (Fail.MonadFail m, Data a, Typeable l, ASTElement l ast) =>-    SrcSpan ->-    (LocatedAn l ast -> TransformT m (Maybe (LocatedAn l ast))) ->-    Graft m a-graftWithM dst trans = Graft $ \dflags a -> do-    everywhereM'-        ( mkM $-            \case-                val@(L src _ :: LocatedAn l ast)-                    | locA src `eqSrcSpan` dst -> do-                        mval <- trans val-                        case mval of-                            Just val' -> do-#if MIN_VERSION_ghc(9,2,0)-                                val'' <--                                    hoistTransform (either Fail.fail pure) $-                                        annotate dflags True $ maybeParensAST val'-                                pure val''-#else-                                (anns, val'') <--                                    hoistTransform (either Fail.fail pure) $-                                        annotate dflags True $ maybeParensAST val'-                                modifyAnnsT $ mappend anns-                                pure val''-#endif-                            Nothing -> pure val-                l -> pure l-        )-        a---- | Run the given transformation only on the smallest node in the tree that--- contains the 'SrcSpan'.-genericGraftWithSmallestM ::-    forall m a ast.-    (Monad m, Data a, Typeable ast) =>-    -- | The type of nodes we'd like to consider when finding the smallest.-    Proxy (Located ast) ->-    SrcSpan ->-    (DynFlags -> ast -> GenericM (TransformT m)) ->-    Graft m a-genericGraftWithSmallestM proxy dst trans = Graft $ \dflags ->-    smallestM (genericIsSubspan proxy dst) (trans dflags)---- | Run the given transformation only on the largest node in the tree that--- contains the 'SrcSpan'.-genericGraftWithLargestM ::-    forall m a ast.-    (Monad m, Data a, Typeable ast) =>-    -- | The type of nodes we'd like to consider when finding the largest.-    Proxy (Located ast) ->-    SrcSpan ->-    (DynFlags -> ast -> GenericM (TransformT m)) ->-    Graft m a-genericGraftWithLargestM proxy dst trans = Graft $ \dflags ->-    largestM (genericIsSubspan proxy dst) (trans dflags)---graftDecls ::-    forall a.-    (HasDecls a) =>-    SrcSpan ->-    [LHsDecl GhcPs] ->-    Graft (Either String) a-graftDecls dst decs0 = Graft $ \dflags a -> do-    decs <- forM decs0 $ \decl -> do-        annotateDecl dflags decl-    let go [] = DL.empty-        go (L src e : rest)-            | locA src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest-            | otherwise = DL.singleton (L src e) <> go rest-    modifyDeclsT (pure . DL.toList . go) a--graftSmallestDeclsWithM ::-    forall a.-    (HasDecls a) =>-    SrcSpan ->-    (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) ->-    Graft (Either String) a-graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do-    let go [] = pure DL.empty-        go (e@(L src _) : rest)-            | dst `isSubspanOf` locA src = toDecls e >>= \case-                Just decs0 -> do-                    decs <- forM decs0 $ \decl ->-                        annotateDecl dflags decl-                    pure $ DL.fromList decs <> DL.fromList rest-                Nothing -> (DL.singleton e <>) <$> go rest-            | otherwise = (DL.singleton e <>) <$> go rest-    modifyDeclsT (fmap DL.toList . go) a--graftDeclsWithM ::-    forall a m.-    (HasDecls a, Fail.MonadFail m) =>-    SrcSpan ->-    (LHsDecl GhcPs -> TransformT m (Maybe [LHsDecl GhcPs])) ->-    Graft m a-graftDeclsWithM dst toDecls = Graft $ \dflags a -> do-    let go [] = pure DL.empty-        go (e@(L src _) : rest)-            | locA src `eqSrcSpan` dst = toDecls e >>= \case-                Just decs0 -> do-                    decs <- forM decs0 $ \decl ->-                        hoistTransform (either Fail.fail pure) $-                          annotateDecl dflags decl-                    pure $ DL.fromList decs <> DL.fromList rest-                Nothing -> (DL.singleton e <>) <$> go rest-            | otherwise = (DL.singleton e <>) <$> go rest-    modifyDeclsT (fmap DL.toList . go) a---class (Data ast, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where-    parseAST :: Parser (LocatedAn l ast)-    maybeParensAST :: LocatedAn l ast -> LocatedAn l ast-    {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with-        the given @Located ast@. The node at that position must already be-        a @Located ast@, or this is a no-op.-    -}-    graft ::-        forall a.-        (Data a) =>-        SrcSpan ->-        LocatedAn l ast ->-        Graft (Either String) a-    graft dst = graft' True dst . maybeParensAST--instance p ~ GhcPs => ASTElement AnnListItem (HsExpr p) where-    parseAST = parseExpr-    maybeParensAST = parenthesize-    graft = graftExpr--instance p ~ GhcPs => ASTElement AnnListItem (Pat p) where-#if __GLASGOW_HASKELL__ == 808-    parseAST = fmap (fmap $ right $ second dL) . parsePattern-    maybeParensAST = dL . parenthesizePat appPrec . unLoc-#else-    parseAST = parsePattern-    maybeParensAST = parenthesizePat appPrec-#endif--instance p ~ GhcPs => ASTElement AnnListItem (HsType p) where-    parseAST = parseType-    maybeParensAST = parenthesizeHsType appPrec--instance p ~ GhcPs => ASTElement AnnListItem (HsDecl p) where-    parseAST = parseDecl-    maybeParensAST = id--instance p ~ GhcPs => ASTElement AnnListItem (ImportDecl p) where-    parseAST = parseImport-    maybeParensAST = id--instance ASTElement NameAnn RdrName where-    parseAST df fp = parseWith df fp parseIdentifier-    maybeParensAST = id----------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,2,0)--- | Dark magic I stole from retrie. No idea what it does.-fixAnns :: ParsedModule -> Annotated ParsedSource-fixAnns ParsedModule {..} =-    let ranns = relativiseApiAnns pm_parsed_source pm_annotations-     in unsafeMkA pm_parsed_source ranns 0-#endif------------------------------------------------------------------------------------ | Given an 'LHSExpr', compute its exactprint annotations.---   Note that this function will throw away any existing annotations (and format)-annotate :: (ASTElement l ast, Outputable l)-#if MIN_VERSION_ghc(9,2,0)-    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (LocatedAn l ast)-#else-    => DynFlags -> Bool -> LocatedAn l ast -> TransformT (Either String) (Anns, LocatedAn l ast)-#endif-annotate dflags needs_space ast = do-    uniq <- show <$> uniqueSrcSpanT-    let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)-    expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered-    pure expr'-#else-    (anns, expr') <- lift $ mapLeft show $ parseAST dflags uniq rendered-    let anns' = setPrecedingLines expr' 0 (bool 0 1 needs_space) anns-    pure (anns',expr')-#endif---- | Given an 'LHsDecl', compute its exactprint annotations.-annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (LHsDecl GhcPs)--- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain--- multiple matches. To work around this, we split the single--- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match',--- and then merge them all back together.-annotateDecl dflags-            (L src (-                ValD ext fb@FunBind-                  { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)}-                  })) = do-    let set_matches matches =-          ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }}--#if MIN_VERSION_ghc(9,2,0)-    alts' <- for alts $ \alt -> do-      uniq <- show <$> uniqueSrcSpanT-      let rendered = render dflags $ set_matches [alt]-      lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case-        (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))-           -> pure alt'-        _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"--    pure $ L src $ set_matches alts'-#else-    (anns', alts') <- fmap unzip $ for alts $ \alt -> do-      uniq <- show <$> uniqueSrcSpanT-      let rendered = render dflags $ set_matches [alt]-      lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case-        (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))-           -> pure (setPrecedingLines alt' 1 0 ann, alt')-        _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"--    modifyAnnsT $ mappend $ fold anns'-    pure $ L src $ set_matches alts'-#endif-annotateDecl dflags ast = do-    uniq <- show <$> uniqueSrcSpanT-    let rendered = render dflags ast-#if MIN_VERSION_ghc(9,2,0)-    lift $ mapLeft show $ parseDecl dflags uniq rendered-#else-    (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered-    let anns' = setPrecedingLines expr' 1 0 anns-    modifyAnnsT $ mappend anns'-    pure expr'-#endif------------------------------------------------------------------------------------ | Print out something 'Outputable'.-render :: Outputable a => DynFlags -> a -> String-render dflags = showSDoc dflags . ppr------------------------------------------------------------------------------------ | Put parentheses around an expression if required.-parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs-parenthesize = parenthesizeHsExpr appPrec------------------------------------------------------------------------------------ | Equality on SrcSpan's.--- Ignores the (Maybe BufSpan) field of SrcSpan's.-eqSrcSpan :: SrcSpan -> SrcSpan -> Bool-eqSrcSpan l r = leftmost_smallest l r == EQ---- | Equality on SrcSpan's.--- Ignores the (Maybe BufSpan) field of SrcSpan's.-#if MIN_VERSION_ghc(9,2,0)-eqSrcSpanA :: SrcAnn la -> SrcAnn b -> Bool-eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ-#else-eqSrcSpanA :: SrcSpan -> SrcSpan -> Bool-eqSrcSpanA l r = leftmost_smallest l r == EQ-#endif--#if MIN_VERSION_ghc(9,2,0)-addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext-addParensToCtxt close_dp = addOpen . addClose-  where-      addOpen it@AnnContext{ac_open = []} = it{ac_open = [epl 0]}-      addOpen other                       = other-      addClose it-        | Just c <- close_dp = it{ac_close = [c]}-        | AnnContext{ac_close = []} <- it = it{ac_close = [epl 0]}-        | otherwise = it--epl :: Int -> EpaLocation-epl n = EpaDelta (SameLine n) []--epAnn :: SrcSpan -> ann -> EpAnn ann-epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments--modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast-modifyAnns x f = first ((fmap.fmap) f) x--removeComma :: SrcSpanAnnA -> SrcSpanAnnA-removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it-removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l)-  = (SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l)-  where-      isCommaAnn AddCommaAnn{} = True-      isCommaAnn _             = False--addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn-addParens True it@NameAnn{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True it@NameAnnCommas{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True it@NameAnnOnly{} =-        it{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0 }-addParens True NameAnnTrailing{..} =-        NameAnn{nann_adornment = NameParens, nann_open = epl 0, nann_close = epl 0, nann_name = epl 0, ..}-addParens _ it = it--removeTrailingComma :: GenLocated SrcSpanAnnA ast -> GenLocated SrcSpanAnnA ast-removeTrailingComma = flip modifyAnns $ \(AnnListItem l) -> AnnListItem $ filter (not . isCommaAnn) l--isCommaAnn :: TrailingAnn -> Bool-isCommaAnn AddCommaAnn{} = True-isCommaAnn _             = False-#endif
src/Development/IDE/GHC/Orphans.hs view
@@ -29,8 +29,6 @@ #endif  -import           Retrie.ExactPrint          (Annotated)- import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Util @@ -41,10 +39,13 @@ import           Data.String                (IsString (fromString)) import           Data.Text                  (unpack) #if MIN_VERSION_ghc(9,0,0)-import          GHC.ByteCode.Types+import           GHC.ByteCode.Types #else-import          ByteCodeTypes+import           ByteCodeTypes #endif+#if MIN_VERSION_ghc(9,3,0)+import GHC.Types.PkgQual+#endif  -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable@@ -57,8 +58,8 @@ instance Show Linkable where show = unpack . printOutputable instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where-  rnf (DotO f) = rnf f-  rnf (DotA f) = rnf f+  rnf (DotO f)   = rnf f+  rnf (DotA f)   = rnf f   rnf (DotDLL f) = rnf f   rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b instance Show PackageFlag where show = unpack . printOutputable@@ -87,7 +88,9 @@ instance Show Module where     show = moduleNameString . moduleName +#if !MIN_VERSION_ghc(9,3,0) instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable+#endif  instance (NFData l, NFData e) => NFData (GenLocated l e) where     rnf (L l e) = rnf l `seq` rnf e@@ -128,10 +131,12 @@ instance NFData HieFile where     rnf = rwhnf +#if !MIN_VERSION_ghc(9,3,0) deriving instance Eq SourceModified deriving instance Show SourceModified instance NFData SourceModified where     rnf = rwhnf+#endif  #if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where@@ -195,12 +200,6 @@ instance NFData (ImportDecl GhcPs) where     rnf = rwhnf -instance Show (Annotated ParsedSource) where-  show _ = "<Annotated ParsedSource>"--instance NFData (Annotated ParsedSource) where-  rnf = rwhnf- #if MIN_VERSION_ghc(9,0,1) instance (NFData HsModule) where #else@@ -210,3 +209,21 @@  instance Show OccName where show = unpack . printOutputable instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)++instance Show HomeModInfo where show = show . mi_module . hm_iface++instance NFData HomeModInfo where+  rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link++#if MIN_VERSION_ghc(9,3,0)+instance NFData PkgQual where+  rnf NoPkgQual = ()+  rnf (ThisPkg uid) = rnf uid+  rnf (OtherPkg uid) = rnf uid++instance NFData UnitId where+  rnf = rwhnf++instance NFData NodeKey where+  rnf = rwhnf+#endif
src/Development/IDE/GHC/Util.hs view
@@ -26,14 +26,13 @@     setHieDir,     dontWriteHieFiles,     disableWarningsAsErrors,-    traceAst,     printOutputable     ) where  #if MIN_VERSION_ghc(9,2,0) import           GHC.Data.FastString import           GHC.Data.StringBuffer-import           GHC.Driver.Env+import           GHC.Driver.Env                    hiding (hscSetFlags) import           GHC.Driver.Monad import           GHC.Driver.Session                hiding (ExposePackage) import           GHC.Parser.Lexer@@ -70,7 +69,6 @@ import           Development.IDE.GHC.Compat        as GHC import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units  as Compat-import           Development.IDE.GHC.Dump          (showAstDataHtml) import           Development.IDE.Types.Location import           Foreign.ForeignPtr import           Foreign.Ptr@@ -280,36 +278,6 @@  -------------------------------------------------------------------------------- -- Tracing exactprint terms--{-# NOINLINE timestamp #-}-timestamp :: POSIXTime-timestamp = utcTimeToPOSIXSeconds $ unsafePerformIO getCurrentTime--debugAST :: Bool-debugAST = unsafePerformIO (getEnvDefault "GHCIDE_DEBUG_AST" "0") == "1"---- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection-traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a-traceAst lbl x-  | debugAST = trace doTrace x-  | otherwise = x-  where-#if MIN_VERSION_ghc(9,2,0)-    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}-#else-    renderDump = showSDocUnsafe . ppr-#endif-    htmlDump = showAstDataHtml x-    doTrace = unsafePerformIO $ do-        u <- U.newUnique-        let htmlDumpFileName = printf "/tmp/hls/%s-%s-%d.html" (show timestamp) lbl (U.hashUnique u)-        writeFile htmlDumpFileName $ renderDump htmlDump-        return $ unlines-            [prettyCallStack callStack ++ ":"-#if MIN_VERSION_ghc(9,2,0)-            , exactPrint x-#endif-            , "file://" ++ htmlDumpFileName]  -- Should in `Development.IDE.GHC.Orphans`, -- leave it here to prevent cyclic module dependency
src/Development/IDE/GHC/Warnings.hs view
@@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE CPP #-}  module Development.IDE.GHC.Warnings(withWarnings) where @@ -23,14 +24,18 @@ --   https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 --   which basically says that log_action is taken from the ModSummary when GHC feels like it. --   The given argument lets you refresh a ModSummary log_action+#if MIN_VERSION_ghc(9,3,0)+withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)+#else withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)+#endif withWarnings diagSource action = do   warnings <- newVar []-  let newAction :: LogActionCompat-      newAction dynFlags wr _ loc prUnqual msg = do-        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg+  let newAction :: DynFlags -> LogActionCompat+      newAction dynFlags logFlags wr _ loc prUnqual msg = do+        let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg         modifyVar_ warnings $ return . (wr_d:)-      newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env)+      newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env)   res <- action $ \env -> putLogHook (newLogger env) env   warns <- readVar warnings   return (reverse $ concat warns, res)@@ -38,6 +43,15 @@     third3 :: (c -> d) -> (a, b, c) -> (a, b, d)     third3 f (a, b, c) = (a, b, f c) +#if MIN_VERSION_ghc(9,3,0)+attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic+attachReason Nothing d = d+attachReason (Just wr) d = d{_code = InR <$> showReason wr}+ where+  showReason = \case+    WarningWithFlag flag    -> showFlag flag+    _ -> Nothing+#else attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr}  where@@ -45,6 +59,7 @@     NoReason       -> Nothing     Reason flag    -> showFlag flag     ErrReason flag -> showFlag =<< flag+#endif  showFlag :: WarningFlag -> Maybe T.Text showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags
src/Development/IDE/Import/FindImports.hs view
@@ -27,6 +27,9 @@ import           Data.List                         (isSuffixOf) import           Data.Maybe import           System.FilePath+#if MIN_VERSION_ghc(9,3,0)+import GHC.Types.PkgQual+#endif  data Import   = FileImport !ArtifactsLocation@@ -37,11 +40,11 @@   { artifactFilePath    :: !NormalizedFilePath   , artifactModLocation :: !(Maybe ModLocation)   , artifactIsSource    :: !Bool          -- ^ True if a module is a source input-  }-    deriving (Show)+  , artifactModule      :: !(Maybe Module)+  } deriving Show  instance NFData ArtifactsLocation where-  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource+  rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource `seq` rnf artifactModule  isBootLocation :: ArtifactsLocation -> Bool isBootLocation = not . artifactIsSource@@ -51,28 +54,30 @@   rnf PackageImport  = ()  modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation-modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod   where     isSource HsSrcFile = True     isSource _         = False     source = case ms of       Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp       Just ms -> isSource (ms_hsc_src ms)+    mod = ms_mod <$> ms  -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m-             => [[FilePath]]+             => [(UnitId, [FilePath])]              -> [String]              -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))              -> Bool              -> ModuleName-             -> m (Maybe NormalizedFilePath)+             -> m (Maybe (UnitId, NormalizedFilePath)) locateModuleFile import_dirss exts targetFor isSource modName = do   let candidates import_dirs =         [ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext)            | prefix <- import_dirs , ext <- exts]-  firstJustM (targetFor modName) (concatMap candidates import_dirss)+  firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss])   where+    go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate     maybeBoot ext       | isSource = ext ++ "-boot"       | otherwise = ext@@ -81,8 +86,13 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package.-mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath])-mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i+#if MIN_VERSION_ghc(9,3,0)+mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath])+mkImportDirs env (i, flags) = Just (i, importPaths flags)+#else+mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath]))+mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i+#endif  -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell@@ -93,43 +103,72 @@     -> [String]                        -- ^ File extensions     -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath))  -- ^ does file exist predicate     -> Located ModuleName              -- ^ Module name+#if MIN_VERSION_ghc(9,3,0)+    -> PkgQual                -- ^ Package name+#else     -> Maybe FastString                -- ^ Package name+#endif     -> Bool                            -- ^ Is boot module     -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do   case mbPkgName of     -- "this" means that we should only look in the current package+#if MIN_VERSION_ghc(9,3,0)+    ThisPkg _ -> do+#else     Just "this" -> do-      lookupLocal [importPaths dflags]+#endif+      lookupLocal (homeUnitId_ dflags) (importPaths dflags)     -- if a package name is given we only go look for a package+#if MIN_VERSION_ghc(9,3,0)+    OtherPkg uid+      | Just dirs <- lookup uid import_paths+#else     Just pkgName-      | Just dirs <- lookup (PackageName pkgName) import_paths-          -> lookupLocal [dirs]+      | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths+#endif+          -> lookupLocal uid dirs       | otherwise -> lookupInPackageDB env+#if MIN_VERSION_ghc(9,3,0)+    NoPkgQual -> do+#else     Nothing -> do+#endif       -- first try to find the module as a file. If we can't find it try to find it in the package       -- database.       -- Here the importPaths for the current modules are added to the front of the import paths from the other components.       -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in       -- each component will end up being found in the wrong place and cause a multi-cradle match failure.-      mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName+      let import_paths' =+#if MIN_VERSION_ghc(9,3,0)+            import_paths+#else+            map snd import_paths+#endif++      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName       case mbFile of         Nothing   -> lookupInPackageDB env-        Just file -> toModLocation file+        Just (uid, file) -> toModLocation uid file   where     dflags = hsc_dflags env     import_paths = mapMaybe (mkImportDirs env) comp_info-    toModLocation file = liftIO $ do+    toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)-        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)+#if MIN_VERSION_ghc(9,0,0)+        let mod = mkModule (RealUnit $ Definite uid) (unLoc modName)  -- TODO support backpack holes+#else+        let mod = mkModule uid (unLoc modName)+#endif+        return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod) -    lookupLocal dirs = do-      mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName+    lookupLocal uid dirs = do+      mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName       case mbFile of         Nothing   -> return $ Left $ notFoundErr env modName $ LookupNotFound []-        Just file -> toModLocation file+        Just (uid, file) -> toModLocation uid file -    lookupInPackageDB env =+    lookupInPackageDB env = do       case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of         LookupFound _m _pkgConfig -> return $ Right PackageImport         reason -> return $ Left $ notFoundErr env modName reason
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -5,18 +5,20 @@  -- | Display information on hover. module Development.IDE.LSP.HoverDefinition-    ( setIdeHandlers+    (     -- * For haskell-language-server-    , hover+    hover     , gotoDefinition     , gotoTypeDefinition+    , documentHighlight+    , references+    , wsSymbols     ) where  import           Control.Monad.IO.Class import           Development.IDE.Core.Actions import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake-import           Development.IDE.LSP.Server import           Development.IDE.Types.Location import           Development.IDE.Types.Logger import qualified Language.LSP.Server            as LSP@@ -52,18 +54,6 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) =   Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange--setIdeHandlers :: LSP.Handlers (ServerM c)-setIdeHandlers = mconcat-  [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} ->-      gotoDefinition ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} ->-      gotoTypeDefinition ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} ->-      documentHighlight ide TextDocumentPositionParams{..}-  , requestHandler STextDocumentReferences references-  , requestHandler SWorkspaceSymbol wsSymbols-  ]  -- | Respond to and log a hover or go-to-definition request request
src/Development/IDE/LSP/LanguageServer.hs view
@@ -5,11 +5,13 @@ {-# LANGUAGE GADTs                     #-} {-# LANGUAGE PolyKinds                 #-} {-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE StarIsType                #-}  -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer     ( runLanguageServer+    , setupLSP     , Log(..)     ) where @@ -32,16 +34,18 @@ import           UnliftIO.Directory import           UnliftIO.Exception +import qualified Colog.Core                            as Colog+import           Control.Monad.IO.Unlift               (MonadUnliftIO) import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.Shake            hiding (Log)+import           Development.IDE.Core.Shake            hiding (Log, Priority) import           Development.IDE.Core.Tracing-import           Development.IDE.LSP.HoverDefinition-import           Development.IDE.Types.Logger--import           Control.Monad.IO.Unlift               (MonadUnliftIO) import qualified Development.IDE.Session               as Session+import           Development.IDE.Types.Logger import qualified Development.IDE.Types.Logger          as Logger import           Development.IDE.Types.Shake           (WithHieDb)+import           Language.LSP.Server                   (LanguageContextEnv,+                                                        LspServerLog,+                                                        type (<~>)) import           System.IO.Unsafe                      (unsafeInterleaveIO)  data Log@@ -51,6 +55,7 @@   | LogReactorThreadStopped   | LogCancelledRequest !SomeLspId   | LogSession Session.Log+  | LogLspServer LspServerLog   deriving Show  instance Pretty Log where@@ -70,151 +75,182 @@     LogCancelledRequest requestId ->       "Cancelled request" <+> viaShow requestId     LogSession log -> pretty log+    LogLspServer log -> pretty log  -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb  runLanguageServer-    :: forall config. (Show config)+    :: forall config a m. (Show config)     => Recorder (WithPriority Log)     -> LSP.Options     -> Handle -- input     -> Handle -- output-    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project     -> config     -> (config -> Value -> Either T.Text config)-    -> LSP.Handlers (ServerM config)-    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+    -> (MVar ()+        -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),+               LSP.Handlers (m config),+               (LanguageContextEnv config, a) -> m config <~> IO))     -> IO ()-runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do-+runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do     -- This MVar becomes full when the server thread exits or we receive exit message from client.     -- LSP server will be canceled when it's full.     clientMsgVar <- newEmptyMVar-    -- Forcefully exit-    let exit = void $ tryPutMVar clientMsgVar () -    -- An MVar to control the lifetime of the reactor loop.-    -- The loop will be stopped and resources freed when it's full-    reactorLifetime <- newEmptyMVar-    let stopReactorLoop = void $ tryPutMVar reactorLifetime ()--    -- The set of requests ids that we have received but not finished processing-    pendingRequests <- newTVarIO Set.empty-    -- The set of requests that have been cancelled and are also in pendingRequests-    cancelledRequests <- newTVarIO Set.empty--    let cancelRequest reqId = atomically $ do-            queued <- readTVar pendingRequests-            -- We want to avoid that the list of cancelled requests-            -- keeps growing if we receive cancellations for requests-            -- that do not exist or have already been processed.-            when (reqId `elem` queued) $-                modifyTVar cancelledRequests (Set.insert reqId)-    let clearReqId reqId = atomically $ do-            modifyTVar pendingRequests (Set.delete reqId)-            modifyTVar cancelledRequests (Set.delete reqId)-        -- We implement request cancellation by racing waitForCancel against-        -- the actual request handler.-    let waitForCancel reqId = atomically $ do-            cancelled <- readTVar cancelledRequests-            unless (reqId `Set.member` cancelled) retry--    let ideHandlers = mconcat-          [ setIdeHandlers-          , userHandlers-          ]--    -- Send everything over a channel, since you need to wait until after initialise before-    -- LspFuncs is available-    clientMsgChan :: Chan ReactorMessage <- newChan--    let asyncHandlers = mconcat-          [ ideHandlers-          , cancelHandler cancelRequest-          , exitHandler exit-          , shutdownHandler stopReactorLoop-          ]-          -- Cancel requests are special since they need to be handled-          -- out of order to be useful. Existing handlers are run afterwards.-+    (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar      let serverDefinition = LSP.ServerDefinition             { LSP.onConfigurationChange = onConfigurationChange             , LSP.defaultConfig = defaultConfig-            , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan-            , LSP.staticHandlers = asyncHandlers-            , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO+            , LSP.doInitialize = doInitialize+            , LSP.staticHandlers = staticHandlers+            , LSP.interpretHandler = interpretHandler             , LSP.options = modifyOptions options             } +    let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)+        lspCologAction = toCologActionWithPrio $ cfilter+            -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447+            (\msg -> priority msg >= Info)+            (cmapWithPrio LogLspServer recorder)+     void $ untilMVar clientMsgVar $           void $ LSP.runServerWithHandles+            lspCologAction+            lspCologAction             inH             outH             serverDefinition -    where-        log :: Logger.Priority -> Log -> IO ()-        log = logWith recorder+setupLSP ::+     forall config err.+     Recorder (WithPriority Log)+  -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project+  -> LSP.Handlers (ServerM config)+  -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+  -> MVar ()+  -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),+         LSP.Handlers (ServerM config),+         (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)+setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do+  -- Send everything over a channel, since you need to wait until after initialise before+  -- LspFuncs is available+  clientMsgChan :: Chan ReactorMessage <- newChan -        handleInit-          :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage-          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))-        handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do-            traceWithSpan sp params-            let root = LSP.resRootPath env-            dir <- maybe getCurrentDirectory return root-            dbLoc <- getHieDbLoc dir+  -- An MVar to control the lifetime of the reactor loop.+  -- The loop will be stopped and resources freed when it's full+  reactorLifetime <- newEmptyMVar+  let stopReactorLoop = void $ tryPutMVar reactorLifetime () -            -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference-            -- to 'getIdeState', so we use this dirty trick-            dbMVar <- newEmptyMVar-            ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar+  -- Forcefully exit+  let exit = void $ tryPutMVar clientMsgVar () -            ide <- getIdeState env root withHieDb hieChan+  -- The set of requests ids that we have received but not finished processing+  pendingRequests <- newTVarIO Set.empty+  -- The set of requests that have been cancelled and are also in pendingRequests+  cancelledRequests <- newTVarIO Set.empty -            let initConfig = parseConfiguration params+  let cancelRequest reqId = atomically $ do+          queued <- readTVar pendingRequests+          -- We want to avoid that the list of cancelled requests+          -- keeps growing if we receive cancellations for requests+          -- that do not exist or have already been processed.+          when (reqId `elem` queued) $+              modifyTVar cancelledRequests (Set.insert reqId)+  let clearReqId reqId = atomically $ do+          modifyTVar pendingRequests (Set.delete reqId)+          modifyTVar cancelledRequests (Set.delete reqId)+      -- We implement request cancellation by racing waitForCancel against+      -- the actual request handler.+  let waitForCancel reqId = atomically $ do+          cancelled <- readTVar cancelledRequests+          unless (reqId `Set.member` cancelled) retry -            log Info $ LogRegisteringIdeConfig initConfig-            registerIdeConfiguration (shakeExtras ide) initConfig+  let asyncHandlers = mconcat+        [ userHandlers+        , cancelHandler cancelRequest+        , exitHandler exit+        , shutdownHandler stopReactorLoop+        ]+        -- Cancel requests are special since they need to be handled+        -- out of order to be useful. Existing handlers are run afterwards. -            let handleServerException (Left e) = do-                    log Error $ LogReactorThreadException e-                    exitClientMsg-                handleServerException (Right _) = pure ()+  let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan -                exceptionInHandler e = do-                    log Error $ LogReactorMessageActionException e+  let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO -                checkCancelled _id act k =-                    flip finally (clearReqId _id) $-                        catch (do-                            -- We could optimize this by first checking if the id-                            -- is in the cancelled set. However, this is unlikely to be a-                            -- bottleneck and the additional check might hide-                            -- issues with async exceptions that need to be fixed.-                            cancelOrRes <- race (waitForCancel _id) act-                            case cancelOrRes of-                                Left () -> do-                                    log Debug $ LogCancelledRequest _id-                                    k $ ResponseError RequestCancelled "" Nothing-                                Right res -> pure res-                        ) $ \(e :: SomeException) -> do-                            exceptionInHandler e-                            k $ ResponseError InternalError (T.pack $ show e) Nothing-            _ <- flip forkFinally handleServerException $ do-                untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do-                    putMVar dbMVar (WithHieDbShield withHieDb,hieChan)-                    forever $ do-                        msg <- readChan clientMsgChan-                        -- We dispatch notifications synchronously and requests asynchronously-                        -- This is to ensure that all file edits and config changes are applied before a request is handled-                        case msg of-                            ReactorNotification act -> handle exceptionInHandler act-                            ReactorRequest _id act k -> void $ async $ checkCancelled _id act k-                log Info LogReactorThreadStopped-            pure $ Right (env,ide)+  pure (doInitialize, asyncHandlers, interpretHandler)+++handleInit+    :: Recorder (WithPriority Log)+    -> (FilePath -> IO FilePath)+    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)+    -> MVar ()+    -> IO ()+    -> (SomeLspId -> IO ())+    -> (SomeLspId -> IO ())+    -> Chan ReactorMessage+    -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))+handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+    traceWithSpan sp params+    let root = LSP.resRootPath env+    dir <- maybe getCurrentDirectory return root+    dbLoc <- getHieDbLoc dir++    -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference+    -- to 'getIdeState', so we use this dirty trick+    dbMVar <- newEmptyMVar+    ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar++    ide <- getIdeState env root withHieDb hieChan++    let initConfig = parseConfiguration params++    log Info $ LogRegisteringIdeConfig initConfig+    registerIdeConfiguration (shakeExtras ide) initConfig++    let handleServerException (Left e) = do+            log Error $ LogReactorThreadException e+            exitClientMsg+        handleServerException (Right _) = pure ()++        exceptionInHandler e = do+            log Error $ LogReactorMessageActionException e++        checkCancelled _id act k =+            flip finally (clearReqId _id) $+                catch (do+                    -- We could optimize this by first checking if the id+                    -- is in the cancelled set. However, this is unlikely to be a+                    -- bottleneck and the additional check might hide+                    -- issues with async exceptions that need to be fixed.+                    cancelOrRes <- race (waitForCancel _id) act+                    case cancelOrRes of+                        Left () -> do+                            log Debug $ LogCancelledRequest _id+                            k $ ResponseError RequestCancelled "" Nothing+                        Right res -> pure res+                ) $ \(e :: SomeException) -> do+                    exceptionInHandler e+                    k $ ResponseError InternalError (T.pack $ show e) Nothing+    _ <- flip forkFinally handleServerException $ do+        untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do+            putMVar dbMVar (WithHieDbShield withHieDb,hieChan)+            forever $ do+                msg <- readChan clientMsgChan+                -- We dispatch notifications synchronously and requests asynchronously+                -- This is to ensure that all file edits and config changes are applied before a request is handled+                case msg of+                    ReactorNotification act -> handle exceptionInHandler act+                    ReactorRequest _id act k -> void $ async $ checkCancelled _id act k+        log Info LogReactorThreadStopped+    pure $ Right (env,ide)++    where+      log :: Logger.Priority -> Log -> IO ()+      log = logWith recorder   -- | Runs the action until it ends or until the given MVar is put.
src/Development/IDE/LSP/Notifications.hs view
@@ -10,6 +10,7 @@     ( whenUriFile     , descriptor     , Log(..)+    , ghcideNotificationsPluginPriority     ) where  import           Language.LSP.Types@@ -38,6 +39,7 @@ import           Development.IDE.Types.Logger import           Development.IDE.Types.Shake           (toKey) import           Ide.Types+import           Numeric.Natural  data Log   = LogShake Shake.Log@@ -138,5 +140,12 @@       success <- registerFileWatches globs       unless success $         liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"-  ]+  ],++    -- The ghcide descriptors should come last'ish so that the notification handlers+    -- (which restart the Shake build) run after everything else+        pluginPriority = ghcideNotificationsPluginPriority     }++ghcideNotificationsPluginPriority :: Natural+ghcideNotificationsPluginPriority = defaultPluginPriority - 900
src/Development/IDE/LSP/Outline.hs view
@@ -11,7 +11,7 @@  import           Control.Monad.IO.Class import           Data.Functor-import           Data.Generics+import           Data.Generics                  hiding (Prefix) import           Data.Maybe import qualified Data.Text                      as T import           Development.IDE.Core.Rules@@ -122,8 +122,16 @@     }   where     cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol+#if MIN_VERSION_ghc(9,3,0)+    cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)+#else     cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)+#endif+#if MIN_VERSION_ghc(9,3,0)+                { _name = printOutputable (unLoc (foLabel n))+#else                 { _name = printOutputable (unLoc (rdrNameFieldOcc n))+#endif                 , _kind = SkField                 }     cvtFld _  = Nothing@@ -161,8 +169,13 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords+    { _name =+#if MIN_VERSION_ghc(9,3,0)+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)+#else+        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords                 (map printOutputable feqn_pats)+#endif     , _kind = SkInterface     } #if MIN_VERSION_ghc(9,2,0)@@ -171,8 +184,13 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif   = Just (defDocumentSymbol l :: DocumentSymbol)-    { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords+    { _name =+#if MIN_VERSION_ghc(9,3,0)+        printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats)+#else+        printOutputable (unLoc feqn_tycon) <> " " <> T.unwords                 (map printOutputable feqn_pats)+#endif     , _kind = SkInterface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =@@ -217,7 +235,7 @@     let       -- safe because if we have no ranges then we don't take this branch       mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)-      importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols+      importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols     in       Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange))           { _name = "imports"@@ -293,7 +311,11 @@      get_flds_gadt :: HsConDeclGADTDetails GhcPs                   -> ([LFieldOcc GhcPs])+#if MIN_VERSION_ghc(9,3,0)+    get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds)+#else     get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds)+#endif     get_flds_gadt _ = []      get_flds :: Located [LConDeclField GhcPs]
src/Development/IDE/LSP/Server.hs view
@@ -10,11 +10,12 @@ module Development.IDE.LSP.Server   ( ReactorMessage(..)   , ReactorChan-  , ServerM+  , ServerM(..)   , requestHandler   , notificationHandler   ) where +import           Control.Monad.IO.Unlift      (MonadUnliftIO) import           Control.Monad.Reader import           Development.IDE.Core.Shake import           Development.IDE.Core.Tracing@@ -30,7 +31,8 @@   | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ())  type ReactorChan = Chan ReactorMessage-type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c)+newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a }+  deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c)  requestHandler   :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>@@ -40,7 +42,7 @@ requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do   st@(chan,ide) <- ask   env <- LSP.getLspEnv-  let resp' = flip runReaderT st . resp+  let resp' = flip (runReaderT . unServerM) st . resp       trace x = otTracedHandler "Request" (show _method) $ \sp -> do         traceWithSpan sp _params         x
src/Development/IDE/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE RankNTypes     #-} module Development.IDE.Main (Arguments(..) ,defaultArguments@@ -11,131 +12,146 @@ ,testing ,Log(..) ) where-import           Control.Concurrent.Extra              (withNumCapabilities)-import           Control.Concurrent.STM.Stats          (atomically,-                                                        dumpSTMStats)-import           Control.Exception.Safe                (SomeException, catchAny,-                                                        displayException)-import           Control.Monad.Extra                   (concatMapM, unless,-                                                        when)-import qualified Data.Aeson.Encode.Pretty              as A-import           Data.Default                          (Default (def))-import           Data.Foldable                         (traverse_)-import qualified Data.HashMap.Strict                   as HashMap-import           Data.Hashable                         (hashed)-import           Data.List.Extra                       (intercalate, isPrefixOf,-                                                        nub, nubOrd, partition)-import           Data.Maybe                            (catMaybes, isJust)-import qualified Data.Text                             as T-import           Data.Text.Lazy.Encoding               (decodeUtf8)-import qualified Data.Text.Lazy.IO                     as LT-import           Data.Typeable                         (typeOf)-import           Development.IDE                       (Action, GhcVersion (..),-                                                        Priority (Debug, Error), Rules,-                                                        ghcVersion,-                                                        hDuplicateTo')-import           Development.IDE.Core.Debouncer        (Debouncer,-                                                        newAsyncDebouncer)-import           Development.IDE.Core.FileStore        (isWatchSupported)-import           Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),-                                                        registerIdeConfiguration)-import           Development.IDE.Core.OfInterest       (FileOfInterestStatus (OnDisk),-                                                        kick,-                                                        setFilesOfInterest)-import           Development.IDE.Core.RuleTypes        (GenerateCore (GenerateCore),-                                                        GetHieAst (GetHieAst),-                                                        GhcSession (GhcSession),-                                                        GhcSessionDeps (GhcSessionDeps),-                                                        TypeCheck (TypeCheck))-import           Development.IDE.Core.Rules            (GhcSessionIO (GhcSessionIO),-                                                        mainRule)-import qualified Development.IDE.Core.Rules            as Rules-import           Development.IDE.Core.Service          (initialise, runAction)-import qualified Development.IDE.Core.Service          as Service-import           Development.IDE.Core.Shake            (IdeState (shakeExtras),-                                                        ShakeExtras (state),-                                                        shakeSessionInit, uses)-import qualified Development.IDE.Core.Shake            as Shake-import           Development.IDE.Core.Tracing          (measureMemory)-import           Development.IDE.Graph                 (action)-import           Development.IDE.LSP.LanguageServer    (runLanguageServer)-import qualified Development.IDE.LSP.LanguageServer    as LanguageServer-import           Development.IDE.Main.HeapStats        (withHeapStats)-import qualified Development.IDE.Main.HeapStats        as HeapStats-import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))-import           Development.IDE.Plugin.HLS            (asGhcIdePlugin)-import qualified Development.IDE.Plugin.HLS            as PluginHLS-import qualified Development.IDE.Plugin.HLS.GhcIde     as GhcIde-import qualified Development.IDE.Plugin.Test           as Test-import           Development.IDE.Session               (SessionLoadingOptions,-                                                        getHieDbLoc,-                                                        loadSessionWithOptions,-                                                        retryOnSqliteBusy,-                                                        runWithDb,-                                                        setInitialDynFlags)-import qualified Development.IDE.Session               as Session-import           Development.IDE.Types.Location        (NormalizedUri,-                                                        toNormalizedFilePath')-import           Development.IDE.Types.Logger          (Logger, Pretty (pretty),-                                                        Priority (Info, Warning),-                                                        Recorder, WithPriority,-                                                        cmapWithPrio, logWith,-                                                        vsep, (<+>))-import           Development.IDE.Types.Options         (IdeGhcSession,-                                                        IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),-                                                        IdeTesting (IdeTesting),-                                                        clientSupportsProgress,-                                                        defaultIdeOptions,-                                                        optModifyDynFlags,-                                                        optTesting)-import           Development.IDE.Types.Shake           (fromKeyType)-import           GHC.Conc                              (getNumProcessors)-import           GHC.IO.Encoding                       (setLocaleEncoding)-import           GHC.IO.Handle                         (hDuplicate)-import           HIE.Bios.Cradle                       (findCradle)-import qualified HieDb.Run                             as HieDb-import           Ide.Plugin.Config                     (CheckParents (NeverCheck),-                                                        Config, checkParents,-                                                        checkProject,-                                                        getConfigFromNotification)-import           Ide.Plugin.ConfigUtils                (pluginsToDefaultConfig,-                                                        pluginsToVSCodeExtensionSchema)-import           Ide.PluginUtils                       (allLspCmdIds',-                                                        getProcessID,-                                                        idePluginsToPluginDesc,-                                                        pluginDescToIdePlugins)-import           Ide.Types                             (IdeCommand (IdeCommand),-                                                        IdePlugins,-                                                        PluginDescriptor (PluginDescriptor, pluginCli),-                                                        PluginId (PluginId),-                                                        ipMap)-import qualified Language.LSP.Server                   as LSP+import           Control.Concurrent.Extra                 (withNumCapabilities)+import           Control.Concurrent.STM.Stats             (atomically,+                                                           dumpSTMStats)+import           Control.Exception.Safe                   (SomeException,+                                                           catchAny,+                                                           displayException)+import           Control.Monad.Extra                      (concatMapM, unless,+                                                           when)+import qualified Data.Aeson.Encode.Pretty                 as A+import           Data.Coerce                              (coerce)+import           Data.Default                             (Default (def))+import           Data.Foldable                            (traverse_)+import           Data.Hashable                            (hashed)+import qualified Data.HashMap.Strict                      as HashMap+import           Data.List.Extra                          (intercalate,+                                                           isPrefixOf, nub,+                                                           nubOrd, partition)+import           Data.Maybe                               (catMaybes, isJust)+import qualified Data.Text                                as T+import           Data.Text.Lazy.Encoding                  (decodeUtf8)+import qualified Data.Text.Lazy.IO                        as LT+import           Data.Typeable                            (typeOf)+import           Development.IDE                          (Action,+                                                           GhcVersion (..),+                                                           Priority (Debug, Error),+                                                           Rules, ghcVersion,+                                                           hDuplicateTo')+import           Development.IDE.Core.Debouncer           (Debouncer,+                                                           newAsyncDebouncer)+import           Development.IDE.Core.FileStore           (isWatchSupported)+import           Development.IDE.Core.IdeConfiguration    (IdeConfiguration (..),+                                                           registerIdeConfiguration)+import           Development.IDE.Core.OfInterest          (FileOfInterestStatus (OnDisk),+                                                           kick,+                                                           setFilesOfInterest)+import           Development.IDE.Core.Rules               (GhcSessionIO (GhcSessionIO),+                                                           mainRule)+import qualified Development.IDE.Core.Rules               as Rules+import           Development.IDE.Core.RuleTypes           (GenerateCore (GenerateCore),+                                                           GetHieAst (GetHieAst),+                                                           GhcSession (GhcSession),+                                                           GhcSessionDeps (GhcSessionDeps),+                                                           TypeCheck (TypeCheck))+import           Development.IDE.Core.Service             (initialise,+                                                           runAction)+import qualified Development.IDE.Core.Service             as Service+import           Development.IDE.Core.Shake               (IdeState (shakeExtras),+                                                           IndexQueue,+                                                           ShakeExtras (state),+                                                           shakeSessionInit,+                                                           uses)+import qualified Development.IDE.Core.Shake               as Shake+import           Development.IDE.Core.Tracing             (measureMemory)+import           Development.IDE.Graph                    (action)+import           Development.IDE.LSP.LanguageServer       (runLanguageServer,+                                                           setupLSP)+import qualified Development.IDE.LSP.LanguageServer       as LanguageServer+import           Development.IDE.Main.HeapStats           (withHeapStats)+import qualified Development.IDE.Main.HeapStats           as HeapStats+import qualified Development.IDE.Monitoring.EKG           as EKG+import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry+import           Development.IDE.Plugin                   (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))+import           Development.IDE.Plugin.HLS               (asGhcIdePlugin)+import qualified Development.IDE.Plugin.HLS               as PluginHLS+import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde+import qualified Development.IDE.Plugin.Test              as Test+import           Development.IDE.Session                  (SessionLoadingOptions,+                                                           getHieDbLoc,+                                                           loadSessionWithOptions,+                                                           retryOnSqliteBusy,+                                                           runWithDb,+                                                           setInitialDynFlags)+import qualified Development.IDE.Session                  as Session+import           Development.IDE.Types.Location           (NormalizedUri,+                                                           toNormalizedFilePath')+import           Development.IDE.Types.Logger             (Logger,+                                                           Pretty (pretty),+                                                           Priority (Info, Warning),+                                                           Recorder,+                                                           WithPriority,+                                                           cmapWithPrio,+                                                           logWith, nest, vsep,+                                                           (<+>))+import           Development.IDE.Types.Monitoring         (Monitoring)+import           Development.IDE.Types.Options            (IdeGhcSession,+                                                           IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),+                                                           IdeTesting (IdeTesting),+                                                           clientSupportsProgress,+                                                           defaultIdeOptions,+                                                           optModifyDynFlags,+                                                           optTesting)+import           Development.IDE.Types.Shake              (WithHieDb,+                                                           fromKeyType)+import           GHC.Conc                                 (getNumProcessors)+import           GHC.IO.Encoding                          (setLocaleEncoding)+import           GHC.IO.Handle                            (hDuplicate)+import           HIE.Bios.Cradle                          (findCradle)+import qualified HieDb.Run                                as HieDb+import           Ide.Plugin.Config                        (CheckParents (NeverCheck),+                                                           Config, checkParents,+                                                           checkProject,+                                                           getConfigFromNotification)+import           Ide.Plugin.ConfigUtils                   (pluginsToDefaultConfig,+                                                           pluginsToVSCodeExtensionSchema)+import           Ide.PluginUtils                          (allLspCmdIds',+                                                           getProcessID,+                                                           idePluginsToPluginDesc,+                                                           pluginDescToIdePlugins)+import           Ide.Types                                (IdeCommand (IdeCommand),+                                                           IdePlugins,+                                                           PluginDescriptor (PluginDescriptor, pluginCli),+                                                           PluginId (PluginId),+                                                           ipMap, pluginId)+import qualified Language.LSP.Server                      as LSP import qualified "list-t" ListT-import           Numeric.Natural                       (Natural)-import           Options.Applicative                   hiding (action)-import qualified StmContainers.Map                     as STM-import qualified System.Directory.Extra                as IO-import           System.Exit                           (ExitCode (ExitFailure),-                                                        exitWith)-import           System.FilePath                       (takeExtension,-                                                        takeFileName)-import           System.IO                             (BufferMode (LineBuffering, NoBuffering),-                                                        Handle, hFlush,-                                                        hPutStrLn,-                                                        hSetBuffering,-                                                        hSetEncoding, stderr,-                                                        stdin, stdout, utf8)-import           System.Random                         (newStdGen)-import           System.Time.Extra                     (Seconds, offsetTime,-                                                        showDuration)-import           Text.Printf                           (printf)+import           Numeric.Natural                          (Natural)+import           Options.Applicative                      hiding (action)+import qualified StmContainers.Map                        as STM+import qualified System.Directory.Extra                   as IO+import           System.Exit                              (ExitCode (ExitFailure),+                                                           exitWith)+import           System.FilePath                          (takeExtension,+                                                           takeFileName)+import           System.IO                                (BufferMode (LineBuffering, NoBuffering),+                                                           Handle, hFlush,+                                                           hPutStrLn,+                                                           hSetBuffering,+                                                           hSetEncoding, stderr,+                                                           stdin, stdout, utf8)+import           System.Random                            (newStdGen)+import           System.Time.Extra                        (Seconds, offsetTime,+                                                           showDuration)+import           Text.Printf                              (printf)  data Log   = LogHeapStats !HeapStats.Log-  | LogLspStart+  | LogLspStart [PluginId]   | LogLspStartDuration !Seconds   | LogShouldRunSubset !Bool-  | LogOnlyPartialGhc9Support+  | LogOnlyPartialGhc92Support   | LogSetInitialDynFlagsException !SomeException   | LogService Service.Log   | LogShake Shake.Log@@ -149,16 +165,18 @@ instance Pretty Log where   pretty = \case     LogHeapStats log -> pretty log-    LogLspStart ->-      vsep-        [ "Staring LSP server..."-        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"]+    LogLspStart pluginIds ->+      nest 2 $ vsep+        [ "Starting LSP server..."+        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"+        , "PluginIds:" <+> pretty (coerce @_ @[T.Text] pluginIds)+        ]     LogLspStartDuration duration ->       "Started LSP server in" <+> pretty (showDuration duration)     LogShouldRunSubset shouldRunSubset ->       "shouldRunSubset:" <+> pretty shouldRunSubset-    LogOnlyPartialGhc9Support ->-      "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail."+    LogOnlyPartialGhc92Support ->+      "Currently, HLS supports GHC 9.2 only partially. See [issue #2982](https://github.com/haskell/haskell-language-server/issues/2982) for more detail."     LogSetInitialDynFlagsException e ->       "setInitialDynFlags:" <+> pretty (displayException e)     LogService log -> pretty log@@ -210,7 +228,7 @@      pluginCommands = mconcat         [ command (T.unpack pId) (Custom <$> p)-        | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins+        | PluginDescriptor{pluginCli = Just p, pluginId = PluginId pId} <- ipMap plugins         ]  @@ -231,9 +249,9 @@     , argsHandleIn              :: IO Handle     , argsHandleOut             :: IO Handle     , argsThreads               :: Maybe Natural+    , argsMonitoring            :: IO Monitoring     } - defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments defaultArguments recorder logger = Arguments         { argsProjectRoot = Nothing@@ -268,6 +286,7 @@                 -- the language server tests without the redirection.                 putStr " " >> hFlush stdout                 return newStdout+        , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999         }  @@ -289,7 +308,6 @@       , argsIdeOptions = ideOptions       } - defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun  where@@ -322,49 +340,57 @@             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins         LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do             t <- offsetTime-            log Info LogLspStart+            log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) -            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do-                traverse_ IO.setCurrentDirectory rootPath-                t <- t-                log Info $ LogLspStartDuration t+            let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState+                getIdeState env rootPath withHieDb hieChan = do+                  traverse_ IO.setCurrentDirectory rootPath+                  t <- t+                  log Info $ LogLspStartDuration t -                dir <- maybe IO.getCurrentDirectory return rootPath+                  dir <- maybe IO.getCurrentDirectory return rootPath -                -- We want to set the global DynFlags right now, so that we can use-                -- `unsafeGlobalDynFlags` even before the project is configured-                _mlibdir <--                    setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions-                        -- TODO: should probably catch/log/rethrow at top level instead-                        `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing)+                  -- We want to set the global DynFlags right now, so that we can use+                  -- `unsafeGlobalDynFlags` even before the project is configured+                  _mlibdir <-+                      setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions+                          -- TODO: should probably catch/log/rethrow at top level instead+                          `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) -                sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir-                config <- LSP.runLspT env LSP.getConfig-                let def_options = argsIdeOptions config sessionLoader+                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir+                  config <- LSP.runLspT env LSP.getConfig+                  let def_options = argsIdeOptions config sessionLoader -                -- disable runSubset if the client doesn't support watched files-                runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported-                log Debug $ LogShouldRunSubset runSubset+                  -- disable runSubset if the client doesn't support watched files+                  runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported+                  log Debug $ LogShouldRunSubset runSubset -                let options = def_options-                            { optReportProgress = clientSupportsProgress caps-                            , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins-                            , optRunSubset = runSubset-                            }-                    caps = LSP.resClientCapabilities env-                -- FIXME: Remove this after GHC 9 gets fully supported-                when (ghcVersion == GHC90) $-                    log Warning LogOnlyPartialGhc9Support-                initialise-                    (cmapWithPrio LogService recorder)-                    argsDefaultHlsConfig-                    rules-                    (Just env)-                    logger-                    debouncer-                    options-                    withHieDb-                    hieChan+                  let options = def_options+                              { optReportProgress = clientSupportsProgress caps+                              , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins+                              , optRunSubset = runSubset+                              }+                      caps = LSP.resClientCapabilities env+                  -- FIXME: Remove this after GHC 9.2 gets fully supported+                  when (ghcVersion == GHC92) $+                      log Warning LogOnlyPartialGhc92Support+                  monitoring <- argsMonitoring+                  initialise+                      (cmapWithPrio LogService recorder)+                      argsDefaultHlsConfig+                      argsHlsPlugins+                      rules+                      (Just env)+                      logger+                      debouncer+                      options+                      withHieDb+                      hieChan+                      monitoring++            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState++            runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup             dumpSTMStats         Check argFiles -> do           dir <- maybe IO.getCurrentDirectory return argsProjectRoot@@ -397,7 +423,7 @@                         , optCheckProject = pure False                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -450,13 +476,10 @@                     , optCheckProject = pure False                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)             c ide--{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}-  expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do
+ src/Development/IDE/Monitoring/EKG.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+module Development.IDE.Monitoring.EKG(monitoring) where++import           Development.IDE.Types.Logger     (Logger)+import           Development.IDE.Types.Monitoring (Monitoring (..))+#ifdef MONITORING_EKG+import           Control.Concurrent               (killThread)+import           Control.Concurrent.Async         (async, waitCatch)+import           Control.Monad                    (forM_)+import           Data.Text                        (pack)+import           Development.IDE.Types.Logger     (logInfo)+import qualified System.Metrics                   as Monitoring+import qualified System.Remote.Monitoring.Wai     as Monitoring++-- | Monitoring using EKG+monitoring :: Logger -> Int -> IO Monitoring+monitoring logger port = do+    store <- Monitoring.newStore+    Monitoring.registerGcMetrics store+    let registerCounter name read = Monitoring.registerCounter name read store+        registerGauge name read = Monitoring.registerGauge name read store+        start = do+            server <- do+                let startServer = Monitoring.forkServerWith store "localhost" port+                -- this can fail if the port is busy, throwing an async exception back to us+                -- to handle that, wrap the server thread in an async+                mb_server <- async startServer >>= waitCatch+                case mb_server of+                    Right s -> do+                        logInfo logger $ pack $+                            "Started monitoring server on port " <> show port+                        return $ Just s+                    Left e -> do+                        logInfo logger $ pack $+                            "Unable to bind monitoring server on port "+                            <> show port <> ":" <> show e+                        return Nothing+            return $ forM_ server $ \s -> do+                logInfo logger "Stopping monitoring server"+                killThread $ Monitoring.serverThreadId s+    return $ Monitoring {..}++#else++monitoring :: Logger -> Int -> IO Monitoring+monitoring _ _ = mempty++#endif
+ src/Development/IDE/Monitoring/OpenTelemetry.hs view
@@ -0,0 +1,31 @@+module Development.IDE.Monitoring.OpenTelemetry (monitoring) where++import           Control.Concurrent.Async         (Async, async, cancel)+import           Control.Monad                    (forever)+import           Data.IORef.Extra                 (atomicModifyIORef'_,+                                                   newIORef, readIORef)+import           Data.Text.Encoding               (encodeUtf8)+import           Debug.Trace.Flags                (userTracingEnabled)+import           Development.IDE.Types.Monitoring (Monitoring (..))+import           OpenTelemetry.Eventlog           (mkValueObserver, observe)+import           System.Time.Extra                (Seconds, sleep)++-- | Dump monitoring to the eventlog using the Opentelemetry package+monitoring :: IO Monitoring+monitoring+  | userTracingEnabled = do+    actions <- newIORef []+    let registerCounter name read = do+            observer <- mkValueObserver (encodeUtf8 name)+            let update = observe observer . fromIntegral =<< read+            atomicModifyIORef'_ actions (update :)+        registerGauge = registerCounter+    let start = do+            a <- regularly 1 $ sequence_ =<< readIORef actions+            return (cancel a)+    return Monitoring{..}+  | otherwise = mempty+++regularly :: Seconds -> IO () -> IO (Async ())+regularly delay act = async $ forever (act >> sleep delay)
− src/Development/IDE/Plugin/CodeAction.hs 
@@ -1,1775 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}---- | Go to the definition of a variable.--module Development.IDE.Plugin.CodeAction-    (-    iePluginDescriptor,-    typeSigsPluginDescriptor,-    bindingsPluginDescriptor,-    fillHolePluginDescriptor,-    newImport,-    newImportToEdit-    -- * For testing-    , matchRegExMultipleImports-    ) where--import           Control.Applicative                               ((<|>))-import           Control.Arrow                                     (second,-                                                                    (>>>))-import           Control.Concurrent.STM.Stats                      (atomically)-import           Control.Monad                                     (guard, join,-                                                                    msum)-import           Control.Monad.IO.Class-import           Data.Char-import qualified Data.DList                                        as DL-import           Data.Function-import           Data.Functor-import qualified Data.HashMap.Strict                               as Map-import qualified Data.HashSet                                      as Set-import           Data.List.Extra-import           Data.List.NonEmpty                                (NonEmpty ((:|)))-import qualified Data.List.NonEmpty                                as NE-import qualified Data.Map                                          as M-import           Data.Maybe-import qualified Data.Rope.UTF16                                   as Rope-import qualified Data.Set                                          as S-import qualified Data.Text                                         as T-import           Data.Tuple.Extra                                  (fst3)-import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Rules-import           Development.IDE.Core.Service-import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.Compat.Util-import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.GHC.Util                          (printOutputable,-                                                                    printRdrName,-                                                                    traceAst)-import           Development.IDE.Plugin.CodeAction.Args-import           Development.IDE.Plugin.CodeAction.ExactPrint-import           Development.IDE.Plugin.CodeAction.PositionIndexed-import           Development.IDE.Plugin.TypeLenses                 (suggestSignature)-import           Development.IDE.Types.Exports-import           Development.IDE.Types.Location-import           Development.IDE.Types.Options-import qualified GHC.LanguageExtensions                            as Lang-import           Ide.PluginUtils                                   (subRange)-import           Ide.Types-import qualified Language.LSP.Server                               as LSP-import           Language.LSP.Types                                (CodeAction (..),-                                                                    CodeActionContext (CodeActionContext, _diagnostics),-                                                                    CodeActionKind (CodeActionQuickFix, CodeActionUnknown),-                                                                    CodeActionParams (CodeActionParams),-                                                                    Command,-                                                                    Diagnostic (..),-                                                                    List (..),-                                                                    ResponseError,-                                                                    SMethod (STextDocumentCodeAction),-                                                                    TextDocumentIdentifier (TextDocumentIdentifier),-                                                                    TextEdit (TextEdit),-                                                                    UInt,-                                                                    WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges),-                                                                    type (|?) (InR),-                                                                    uriToFilePath)-import           Language.LSP.VFS-import           Text.Regex.TDFA                                   (mrAfter,-                                                                    (=~), (=~~))------------------------------------------------------------------------------------------------------- | Generate code actions.-codeAction-    :: IdeState-    -> PluginId-    -> CodeActionParams-    -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction)))-codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do-  contents <- LSP.getVirtualFile $ toNormalizedUri uri-  liftIO $ do-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents-        mbFile = toNormalizedFilePath' <$> uriToFilePath uri-    diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state-    (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile-    let-      actions = caRemoveRedundantImports parsedModule text diag xs uri-               <> caRemoveInvalidExports parsedModule text diag xs uri-    pure $ Right $ List actions-----------------------------------------------------------------------------------------------------iePluginDescriptor :: PluginId -> PluginDescriptor IdeState-iePluginDescriptor plId =-  let old =-        mkGhcideCAsPlugin [-           wrap suggestExtendImport-          , wrap suggestImportDisambiguation-          , wrap suggestNewOrExtendImportForClassMethod-          , wrap suggestNewImport-          , wrap suggestModuleTypo-          , wrap suggestFixConstructorImport-          , wrap suggestHideShadow-          , wrap suggestExportUnusedTopBinding-          ]-          plId-   in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction}--typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState-typeSigsPluginDescriptor =-  mkGhcideCAsPlugin [-      wrap $ suggestSignature True-    , wrap suggestFillTypeWildcard-    , wrap removeRedundantConstraints-    , wrap suggestAddTypeAnnotationToSatisfyContraints-    , wrap suggestConstraint-    ]--bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState-bindingsPluginDescriptor =-  mkGhcideCAsPlugin [-      wrap suggestReplaceIdentifier-    , wrap suggestImplicitParameter-    , wrap suggestNewDefinition-    , wrap suggestDeleteUnusedBinding-    ]--fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState-fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole-----------------------------------------------------------------------------------------------------findSigOfDecl :: p ~ GhcPass p0 => (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p)-findSigOfDecl pred decls =-  listToMaybe-    [ sig-      | L _ (SigD _ sig@(TypeSig _ idsSig _)) <- decls,-        any (pred . unLoc) idsSig-    ]--findSigOfDeclRanged :: forall p p0 . p ~ GhcPass p0 => Range -> [LHsDecl p] -> Maybe (Sig p)-findSigOfDeclRanged range decls = do-  dec <- findDeclContainingLoc (_start range) decls-  case dec of-     L _ (SigD _ sig@TypeSig {})     -> Just sig-     L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind-     _                               -> Nothing--findSigOfBind :: forall p p0. p ~ GhcPass p0 => Range -> HsBind p -> Maybe (Sig p)-findSigOfBind range bind =-    case bind of-      FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind))-      _          -> Nothing-  where-    findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p)-    findSigOfLMatch ls = do-      match <- findDeclContainingLoc (_start range) ls-      let grhs = m_grhss $ unLoc match-#if !MIN_VERSION_ghc(9,2,0)-          span = getLoc $ reLoc $ grhssLocalBinds grhs-      if _start range `isInsideSrcSpan` span-        then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause-        else do-          grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)-          case unLoc grhs of-            GRHS _ _ bd -> findSigOfExpr (unLoc bd)-            _           -> Nothing-#else-      msum-        [findSigOfBinds range (grhssLocalBinds grhs) -- where clause-        , do-          grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs)-          case unLoc grhs of-            GRHS _ _ bd -> findSigOfExpr (unLoc bd)-        ]-#endif--    findSigOfExpr :: HsExpr p -> Maybe (Sig p)-    findSigOfExpr = go-      where-        go (HsLet _ binds _) = findSigOfBinds range binds-        go (HsDo _ _ stmts) = do-          stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts)-          case stmtlr of-            LetStmt _ lhsLocalBindsLR -> findSigOfBinds range lhsLocalBindsLR-            _                         -> Nothing-        go _ = Nothing--findSigOfBinds :: p ~ GhcPass p0 => Range -> HsLocalBinds p -> Maybe (Sig p)-findSigOfBinds range = go-  where-    go (HsValBinds _ (ValBinds _ binds lsigs)) =-        case unLoc <$> findDeclContainingLoc (_start range) lsigs of-          Just sig' -> Just sig'-          Nothing -> do-            lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds)-            findSigOfBind range (unLoc lHsBindLR)-    go _ = Nothing--findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p)-findInstanceHead df instanceHead decls =-  listToMaybe-#if !MIN_VERSION_ghc(9,2,0)-    [ hsib_body-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB {hsib_body}})) <- decls,-        showSDoc df (ppr hsib_body) == instanceHead-    ]-#else-    [ hsib_body-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls,-        showSDoc df (ppr hsib_body) == instanceHead-    ]-#endif--#if MIN_VERSION_ghc(9,2,0)-findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e)-#else--- TODO populate this type signature for GHC versions <9.2-#endif-findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l)---- Single:--- This binding for ‘mod’ shadows the existing binding---   imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40---   (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing)--- Multi:---This binding for ‘pack’ shadows the existing bindings---  imported from ‘Data.ByteString’ at B.hs:6:1-22---  imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27---  imported from ‘Data.Text’ at B.hs:7:1-16-suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])]-suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagnostic {_message, _range}-  | Just [identifier, modName, s] <--      matchRegexUnifySpaces-        _message-        "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" =-    suggests identifier modName s-  | Just [identifier] <--      matchRegexUnifySpaces-        _message-        "This binding for ‘([^`]+)’ shadows the existing bindings",-    Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)",-    mods <- [(modName, s) | [_, modName, s] <- matched],-    result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),-    hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) =-    result <> [hideAll]-  | otherwise = []-  where-    suggests identifier modName s-      | Just tcM <- mTcM,-        Just har <- mHar,-        [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s],-        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing),-        mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName,-        title <- "Hide " <> identifier <> " from " <> modName =-        if modName == "Prelude" && null mDecl-          then maybeToList $ (\(_, te) -> (title, [Left te])) <$> newImportToEdit (hideImplicitPreludeSymbol identifier) ps fileContents-          else maybeToList $ (title,) . pure . pure . hideSymbol (T.unpack identifier) <$> mDecl-      | otherwise = []--findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)-findImportDeclByModuleName decls modName = flip find decls $ \case-  (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName)-  _                     -> error "impossible"--isTheSameLine :: SrcSpan -> SrcSpan -> Bool-isTheSameLine s1 s2-  | Just sl1 <- getStartLine s1,-    Just sl2 <- getStartLine s2 =-    sl1 == sl2-  | otherwise = False-  where-    getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x--isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool-isUnusedImportedId-  TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}}-  HAR {refMap}-  identifier-  modName-  importSpan-    | occ <- mkVarOcc identifier,-      impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods,-      Just rdrEnv <--        listToMaybe-          [ imv_all_exports-            | ImportedModsVal {..} <- impModsVals,-              imv_name == mkModuleName modName,-              isTheSameLine imv_span importSpan-          ],-      [GRE {gre_name = name}] <- lookupGlobalRdrEnv rdrEnv occ,-      importedIdentifier <- Right name,-      refs <- M.lookup importedIdentifier refMap =-      maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs-    | otherwise = False--suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _  HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}---     The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant-    | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"-    , Just (L _ impDecl) <- find (\(L (locA -> l) _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports-    , Just c <- contents-    , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings)-    , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges)-    , not (null ranges')-    = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]---- File.hs:16:1: warning:---     The import of `Data.List' is redundant---       except perhaps to import instances from `Data.List'---     To import instances alone, use: import Data.List()-    | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)-        = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]-    | otherwise = []--caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction]-caRemoveRedundantImports m contents digs ctxDigs uri-  | Just pm <- m,-    r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs,-    allEdits <- [ e | (_, (_, edits)) <- r, e <- edits],-    caRemoveAll <- removeAll allEdits,-    ctxEdits <- [ x | x@(d, _) <- r, d `elem` ctxDigs],-    not $ null ctxEdits,-    caRemoveCtx <- map (\(d, (title, tedit)) -> removeSingle title tedit d) ctxEdits-      = caRemoveCtx ++ [caRemoveAll]-  | otherwise = []-  where-    removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where-        _changes = Just $ Map.singleton uri $ List tedit-        _documentChanges = Nothing-        _changeAnnotations = Nothing-    removeAll tedit = InR $ CodeAction{..} where-        _changes = Just $ Map.singleton uri $ List tedit-        _title = "Remove all redundant imports"-        _kind = Just CodeActionQuickFix-        _diagnostics = Nothing-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _isPreferred = Nothing-        _command = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing--caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction]-caRemoveInvalidExports m contents digs ctxDigs uri-  | Just pm <- m,-    Just txt <- contents,-    txt' <- indexedByPosition $ T.unpack txt,-    r <- mapMaybe (groupDiag pm) digs,-    r' <- map (\(t,d,rs) -> (t,d,extend txt' rs)) r,-    caRemoveCtx <- mapMaybe removeSingle r',-    allRanges <- nubOrd $ [ range | (_,_,ranges) <- r, range <- ranges],-    allRanges' <- extend txt' allRanges,-    Just caRemoveAll <- removeAll allRanges',-    ctxEdits <- [ x | x@(_, d, _) <- r, d `elem` ctxDigs],-    not $ null ctxEdits-      = caRemoveCtx ++ [caRemoveAll]-  | otherwise = []-  where-    extend txt ranges = extendAllToIncludeCommaIfPossible True txt ranges--    groupDiag pm dig-      | Just (title, ranges) <- suggestRemoveRedundantExport pm dig-      = Just (title, dig, ranges)-      | otherwise = Nothing--    removeSingle (_, _, []) = Nothing-    removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where-        tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges-        _changes = Just $ Map.singleton uri $ List tedit-        _title = title-        _kind = Just CodeActionQuickFix-        _diagnostics = Just $ List [diagnostic]-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _command = Nothing-        _isPreferred = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing-    removeAll [] = Nothing-    removeAll ranges = Just $ InR $ CodeAction{..} where-        tedit = concatMap (\r -> [TextEdit r ""]) ranges-        _changes = Just $ Map.singleton uri $ List tedit-        _title = "Remove all redundant exports"-        _kind = Just CodeActionQuickFix-        _diagnostics = Nothing-        _documentChanges = Nothing-        _edit = Just WorkspaceEdit{..}-        _command = Nothing-        _isPreferred = Nothing-        _disabled = Nothing-        _xdata = Nothing-        _changeAnnotations = Nothing--suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range])-suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}-  | msg <- unifySpaces _message-  , Just export <- hsmodExports-  , Just exportRange <- getLocatedRange $ reLoc export-  , exports <- unLoc export-  , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg)-                         <|> (,[_range]) <$> matchExportItem msg-                         <|> (,[_range]) <$> matchDupExport msg-  , subRange _range exportRange-    = Just ("Remove ‘" <> removeFromExport <> "’ from export", ranges)-  where-    matchExportItem msg = regexSingleMatch msg "The export item ‘([^’]+)’"-    matchDupExport msg = regexSingleMatch msg "Duplicate ‘([^’]+)’ in export list"-    getRanges exports txt = case smallerRangesForBindingExport exports (T.unpack txt) of-      []     -> (txt, [_range])-      ranges -> (txt, ranges)-suggestRemoveRedundantExport _ _ = Nothing--suggestDeleteUnusedBinding :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestDeleteUnusedBinding-  ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}}-  contents-  Diagnostic{_range=_range,..}--- Foo.hs:4:1: warning: [-Wunused-binds] Defined but not used: ‘f’-    | Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"-    , Just indexedContent <- indexedByPosition . T.unpack <$> contents-      = let edits = flip TextEdit "" <$> relatedRanges indexedContent (T.unpack name)-        in ([("Delete ‘" <> name <> "’", edits) | not (null edits)])-    | otherwise = []-    where-      relatedRanges indexedContent name =-        concatMap (findRelatedSpans indexedContent name . reLoc) hsmodDecls-      toRange = realSrcSpanToRange-      extendForSpaces = extendToIncludePreviousNewlineIfPossible--      findRelatedSpans :: PositionIndexedString -> String -> Located (HsDecl GhcPs) -> [Range]-      findRelatedSpans-        indexedContent-        name-        (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =-        case lname of-          (L nLoc _name) | isTheBinding nLoc ->-            let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig-                findSig _ = []-            in-              extendForSpaces indexedContent (toRange l) :-              concatMap (findSig . reLoc) hsmodDecls-          _ -> concatMap (findRelatedSpanForMatch indexedContent name) matches-      findRelatedSpans _ _ _ = []--      extractNameAndMatchesFromFunBind-        :: HsBind GhcPs-        -> Maybe (Located (IdP GhcPs), [LMatch GhcPs (LHsExpr GhcPs)])-      extractNameAndMatchesFromFunBind-        FunBind-          { fun_id=lname-          , fun_matches=MG {mg_alts=L _ matches}-          } = Just (reLoc lname, matches)-      extractNameAndMatchesFromFunBind _ = Nothing--      findRelatedSigSpan :: PositionIndexedString -> String -> RealSrcSpan -> Sig GhcPs -> [Range]-      findRelatedSigSpan indexedContent name l sig =-        let maybeSpan = findRelatedSigSpan1 name sig-        in case maybeSpan of-          Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int-          Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused-          _ -> []--      -- Second of the tuple means there is only one match-      findRelatedSigSpan1 :: String -> Sig GhcPs -> Maybe (SrcSpan, Bool)-      findRelatedSigSpan1 name (TypeSig _ lnames _) =-        let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames-        in case maybeIdx of-            Nothing -> Nothing-            Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True)-            Just idx ->-              let targetLname = getLoc $ reLoc $ lnames !! idx-                  startLoc = srcSpanStart targetLname-                  endLoc = srcSpanEnd targetLname-                  startLoc' = if idx == 0-                              then startLoc-                              else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1)-                  endLoc' = if idx == 0 && idx < length lnames - 1-                            then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1)-                            else endLoc-              in Just (mkSrcSpan startLoc' endLoc', False)-      findRelatedSigSpan1 _ _ = Nothing--      -- for where clause-      findRelatedSpanForMatch-        :: PositionIndexedString-        -> String-        -> LMatch GhcPs (LHsExpr GhcPs)-        -> [Range]-      findRelatedSpanForMatch-        indexedContent-        name-        (L _ Match{m_grhss=GRHSs{grhssLocalBinds}}) = do-        let go bag lsigs =-                if isEmptyBag bag-                then []-                else concatMap (findRelatedSpanForHsBind indexedContent name lsigs) bag-#if !MIN_VERSION_ghc(9,2,0)-        case grhssLocalBinds of-          (L _ (HsValBinds _ (ValBinds _ bag lsigs))) -> go bag lsigs-          _                                           -> []-#else-        case grhssLocalBinds of-          (HsValBinds _ (ValBinds _ bag lsigs)) -> go bag lsigs-          _                                     -> []-#endif-      findRelatedSpanForMatch _ _ _ = []--      findRelatedSpanForHsBind-        :: PositionIndexedString-        -> String-        -> [LSig GhcPs]-        -> LHsBind GhcPs-        -> [Range]-      findRelatedSpanForHsBind-        indexedContent-        name-        lsigs-        (L (locA -> (RealSrcSpan l _)) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =-        if isTheBinding (getLoc lname)-        then-          let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig-              findSig _ = []-          in extendForSpaces indexedContent (toRange l) : concatMap (findSig . reLoc) lsigs-        else concatMap (findRelatedSpanForMatch indexedContent name) matches-      findRelatedSpanForHsBind _ _ _ _ = []--      isTheBinding :: SrcSpan -> Bool-      isTheBinding span = srcSpanToRange span == Just _range--      isSameName :: IdP GhcPs -> String -> Bool-      isSameName x name = T.unpack (printOutputable x) == name--data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll-  deriving (Eq)--getLocatedRange :: Located a -> Maybe Range-getLocatedRange = srcSpanToRange . getLoc--suggestExportUnusedTopBinding :: Maybe T.Text -> ParsedModule -> Diagnostic -> [(T.Text, TextEdit)]-suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}--- Foo.hs:4:1: warning: [-Wunused-top-binds] Defined but not used: ‘f’--- Foo.hs:5:1: warning: [-Wunused-top-binds] Defined but not used: type constructor or class ‘F’--- Foo.hs:6:1: warning: [-Wunused-top-binds] Defined but not used: data constructor ‘Bar’-  | Just source <- srcOpt-  , Just [name] <- matchRegexUnifySpaces _message ".*Defined but not used: ‘([^ ]+)’"-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: type constructor or class ‘([^ ]+)’"-                   <|> matchRegexUnifySpaces _message ".*Defined but not used: data constructor ‘([^ ]+)’"-  , Just (exportType, _) <- find (matchWithDiagnostic _range . snd)-                            . mapMaybe-                                (\(L (locA -> l) b) -> if maybe False isTopLevel $ srcSpanToRange l-                                                then exportsAs b else Nothing)-                            $ hsmodDecls-  , Just pos <- (fmap _end . getLocatedRange) . reLoc =<< hsmodExports-  , Just needComma <- needsComma source <$> fmap reLoc hsmodExports-  , let exportName = (if needComma then ", " else "") <> printExport exportType name-        insertPos = pos {_character = pred $ _character pos}-  = [("Export ‘" <> name <> "’", TextEdit (Range insertPos insertPos) exportName)]-  | otherwise = []-  where-    -- we get the last export and the closing bracket and check for comma in that range-    needsComma :: T.Text -> Located [LIE GhcPs] -> Bool-    needsComma _ (L _ []) = False-    needsComma source (L (RealSrcSpan l _) exports) =-      let closeParan = _end $ realSrcSpanToRange l-          lastExport = fmap _end . getLocatedRange $ last $ fmap reLoc exports-      in case lastExport of-        Just lastExport -> not $ T.isInfixOf "," $ textInRange (Range lastExport closeParan) source-        _ -> False-    needsComma _ _ = False--    opLetter :: String-    opLetter = ":!#$%&*+./<=>?@\\^|-~"--    parenthesizeIfNeeds :: Bool -> T.Text -> T.Text-    parenthesizeIfNeeds needsTypeKeyword x-      | T.head x `elem` opLetter = (if needsTypeKeyword then "type " else "") <> "(" <> x <>")"-      | otherwise = x--    matchWithDiagnostic :: Range -> Located (IdP GhcPs) -> Bool-    matchWithDiagnostic Range{_start=l,_end=r} x =-      let loc = fmap _start . getLocatedRange $ x-       in loc >= Just l && loc <= Just r--    printExport :: ExportsAs -> T.Text -> T.Text-    printExport ExportName x    = parenthesizeIfNeeds False x-    printExport ExportPattern x = "pattern " <> x-    printExport ExportFamily x  = parenthesizeIfNeeds True x-    printExport ExportAll x     = parenthesizeIfNeeds True x <> "(..)"--    isTopLevel :: Range -> Bool-    isTopLevel l = (_character . _start) l == 0--    exportsAs :: HsDecl GhcPs -> Maybe (ExportsAs, Located (IdP GhcPs))-    exportsAs (ValD _ FunBind {fun_id})          = Just (ExportName, reLoc fun_id)-    exportsAs (ValD _ (PatSynBind _ PSB {psb_id})) = Just (ExportPattern, reLoc psb_id)-    exportsAs (TyClD _ SynDecl{tcdLName})      = Just (ExportName, reLoc tcdLName)-    exportsAs (TyClD _ DataDecl{tcdLName})     = Just (ExportAll, reLoc tcdLName)-    exportsAs (TyClD _ ClassDecl{tcdLName})    = Just (ExportAll, reLoc tcdLName)-    exportsAs (TyClD _ FamDecl{tcdFam})        = Just (ExportFamily, reLoc $ fdLName tcdFam)-    exportsAs _                                = Nothing--suggestAddTypeAnnotationToSatisfyContraints :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestAddTypeAnnotationToSatisfyContraints sourceOpt Diagnostic{_range=_range,..}--- File.hs:52:41: warning:---     * Defaulting the following constraint to type ‘Integer’---        Num p0 arising from the literal ‘1’---     * In the expression: 1---       In an equation for ‘f’: f = 1--- File.hs:52:41: warning:---     * Defaulting the following constraints to type ‘[Char]’---        (Show a0)---          arising from a use of ‘traceShow’---          at A.hs:228:7-25---        (IsString a0)---          arising from the literal ‘"debug"’---          at A.hs:228:17-23---     * In the expression: traceShow "debug" a---       In an equation for ‘f’: f a = traceShow "debug" a--- File.hs:52:41: warning:---     * Defaulting the following constraints to type ‘[Char]’---         (Show a0)---          arising from a use of ‘traceShow’---          at A.hs:255:28-43---        (IsString a0)---          arising from the literal ‘"test"’---          at /Users/serhiip/workspace/ghcide/src/Development/IDE/Plugin/CodeAction.hs:255:38-43---     * In the fourth argument of ‘seq’, namely ‘(traceShow "test")’---       In the expression: seq "test" seq "test" (traceShow "test")---       In an equation for ‘f’:---          f = seq "test" seq "test" (traceShow "test")-    | Just [ty, lit] <- matchRegexUnifySpaces _message (pat False False True False)-                        <|> matchRegexUnifySpaces _message (pat False False False True)-                        <|> matchRegexUnifySpaces _message (pat False False False False)-            = codeEdit ty lit (makeAnnotatedLit ty lit)-    | Just source <- sourceOpt-    , Just [ty, lit] <- matchRegexUnifySpaces _message (pat True True False False)-            = let lit' = makeAnnotatedLit ty lit;-                  tir = textInRange _range source-              in codeEdit ty lit (T.replace lit lit' tir)-    | otherwise = []-    where-      makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"-      pat multiple at inArg inExpr = T.concat [ ".*Defaulting the following constraint"-                                       , if multiple then "s" else ""-                                       , " to type ‘([^ ]+)’ "-                                       , ".*arising from the literal ‘(.+)’"-                                       , if inArg then ".+In the.+argument" else ""-                                       , if at then ".+at" else ""-                                       , if inExpr then ".+In the expression" else ""-                                       , ".+In the expression"-                                       ]-      codeEdit ty lit replacement =-        let title = "Add type annotation ‘" <> ty <> "’ to ‘" <> lit <> "’"-            edits = [TextEdit _range replacement]-        in  [( title, edits )]---suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestReplaceIdentifier contents Diagnostic{_range=_range,..}--- File.hs:52:41: error:---     * Variable not in scope:---         suggestAcion :: Maybe T.Text -> Range -> Range---     * Perhaps you meant ‘suggestAction’ (line 83)--- File.hs:94:37: error:---     Not in scope: ‘T.isPrfixOf’---     Perhaps you meant one of these:---       ‘T.isPrefixOf’ (imported from Data.Text),---       ‘T.isInfixOf’ (imported from Data.Text),---       ‘T.isSuffixOf’ (imported from Data.Text)---     Module ‘Data.Text’ does not export ‘isPrfixOf’.-    | renameSuggestions@(_:_) <- extractRenamableTerms _message-        = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]-    | otherwise = []--suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]-suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}---     * Variable not in scope:---         suggestAcion :: Maybe T.Text -> Range -> Range-    | Just [name, typ] <- matchRegexUnifySpaces message "Variable not in scope: ([^ ]+) :: ([^*•]+)"-    = newDefinitionAction ideOptions parsedModule _range name typ-    | Just [name, typ] <- matchRegexUnifySpaces message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"-    , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ-    = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]-    | otherwise = []-    where-      message = unifySpaces _message--newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]-newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ-    | Range _ lastLineP : _ <--      [ realSrcSpanToRange sp-      | (L (locA -> l@(RealSrcSpan sp _)) _) <- hsmodDecls-      , _start `isInsideSrcSpan` l]-    , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}-    = [ ("Define " <> sig-        , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])]-        )]-    | otherwise = []-  where-    colon = if optNewColonConvention then " : " else " :: "-    sig = name <> colon <> T.dropWhileEnd isSpace typ-    ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule--suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillTypeWildcard Diagnostic{_range=_range,..}--- Foo.hs:3:8: error:---     * Found type wildcard `_' standing for `p -> p1 -> p'--    | "Found type wildcard" `T.isInfixOf` _message-    , " standing for " `T.isInfixOf` _message-    , typeSignature <- extractWildCardTypeSignature _message-        =  [("Use type signature: ‘" <> typeSignature <> "’", TextEdit _range typeSignature)]-    | otherwise = []--{- Handles two variants with different formatting--1. Could not find module ‘Data.Cha’-   Perhaps you meant Data.Char (from base-4.12.0.0)--2. Could not find module ‘Data.I’-   Perhaps you meant-      Data.Ix (from base-4.14.3.0)-      Data.Eq (from base-4.14.3.0)-      Data.Int (from base-4.14.3.0)--}-suggestModuleTypo :: Diagnostic -> [(T.Text, TextEdit)]-suggestModuleTypo Diagnostic{_range=_range,..}-    | "Could not find module" `T.isInfixOf` _message =-      case T.splitOn "Perhaps you meant" _message of-          [_, stuff] ->-              [ ("replace with " <> modul, TextEdit _range modul)-              | modul <- mapMaybe extractModule (T.lines stuff)-              ]-          _ -> []-    | otherwise = []-  where-    extractModule line = case T.words line of-        [modul, "(from", _] -> Just modul-        _                   -> Nothing---suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]-suggestFillHole Diagnostic{_range=_range,..}-    | Just holeName <- extractHoleName _message-    , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =-      let isInfixHole = _message =~ addBackticks holeName :: Bool in-        map (proposeHoleFit holeName False isInfixHole) holeFits-        ++ map (proposeHoleFit holeName True isInfixHole) refFits-    | otherwise = []-    where-      extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"-      addBackticks text = "`" <> text <> "`"-      addParens text = "(" <> text <> ")"-      proposeHoleFit holeName parenthise isInfixHole name =-        let isInfixOperator = T.head name == '('-            name' = getOperatorNotation isInfixHole isInfixOperator name in-          ( "replace " <> holeName <> " with " <> name-          , TextEdit _range (if parenthise then addParens name' else name')-          )-      getOperatorNotation True False name                    = addBackticks name-      getOperatorNotation True True name                     = T.drop 1 (T.dropEnd 1 name)-      getOperatorNotation _isInfixHole _isInfixOperator name = name--processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text])-processHoleSuggestions mm = (holeSuggestions, refSuggestions)-{--    • Found hole: _ :: LSP.Handlers--      Valid hole fits include def-      Valid refinement hole fits include-        fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)-        fromJust (_ :: Maybe LSP.Handlers)-        haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams-                                                                                                        LSP.Handlers)-        T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)-                (_ :: LSP.Handlers)-                (_ :: T.Text)-        T.foldl' (_ :: LSP.Handlers -> Char -> LSP.Handlers)-                 (_ :: LSP.Handlers)-                 (_ :: T.Text)--}-  where-    t = id @T.Text-    holeSuggestions = do-      -- get the text indented under Valid hole fits-      validHolesSection <--        getIndentedGroupsBy (=~ t " *Valid (hole fits|substitutions) include") mm-      -- the Valid hole fits line can contain a hole fit-      holeFitLine <--        mapHead-            (mrAfter . (=~ t " *Valid (hole fits|substitutions) include"))-            validHolesSection-      let holeFit = T.strip $ T.takeWhile (/= ':') holeFitLine-      guard (not $ T.null holeFit)-      return holeFit-    refSuggestions = do -- @[]-      -- get the text indented under Valid refinement hole fits-      refinementSection <--        getIndentedGroupsBy (=~ t " *Valid refinement hole fits include") mm-      -- get the text for each hole fit-      holeFitLines <- getIndentedGroups (tail refinementSection)-      let holeFit = T.strip $ T.unwords holeFitLines-      guard $ not $ holeFit =~ t "Some refinement hole fits suppressed"-      return holeFit--    mapHead f (a:aa) = f a : aa-    mapHead _ []     = []---- > getIndentedGroups [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1,", "  l1", "  l2"], [" H2", "  l3"]]-getIndentedGroups :: [T.Text] -> [[T.Text]]-getIndentedGroups [] = []-getIndentedGroups ll@(l:_) = getIndentedGroupsBy ((== indentation l) . indentation) ll--- |--- > getIndentedGroupsBy (" H" `isPrefixOf`) [" H1", "  l1", "  l2", " H2", "  l3"] = [[" H1", "  l1", "  l2"], [" H2", "  l3"]]-getIndentedGroupsBy :: (T.Text -> Bool) -> [T.Text] -> [[T.Text]]-getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of-    (l:ll) -> case span (\l' -> indentation l < indentation l') ll of-        (indented, rest) -> (l:indented) : getIndentedGroupsBy pred rest-    _ -> []--indentation :: T.Text -> Int-indentation = T.length . T.takeWhile isSpace--suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)]-suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}-    | Just [binding, mod, srcspan] <--      matchRegexUnifySpaces _message-      "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"-    = suggestions hsmodImports binding mod srcspan-    | Just (binding, mod_srcspan) <--      matchRegExMultipleImports _message-    = mod_srcspan >>= uncurry (suggestions hsmodImports binding)-    | otherwise = []-    where-        canUseDatacon = case extractNotInScopeName _message of-                            Just NotInScopeTypeConstructorOrClass{} -> False-                            _                                       -> True--        suggestions decls binding mod srcspan-          | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of-                [s] -> let x = realSrcSpanToRange s-                   in x{_end = (_end x){_character = succ (_character (_end x))}}-                _ -> error "bug in srcspan parser",-            Just decl <- findImportDeclByRange decls range,-            Just ident <- lookupExportMap binding mod-          = [ ( "Add " <> renderImportStyle importStyle <> " to the import list of " <> mod-              , quickFixImportKind' "extend" importStyle-              , uncurry extendImport (unImportStyle importStyle) decl-              )-            | importStyle <- NE.toList $ importStyles ident-            ]-          | otherwise = []-        lookupExportMap binding mod-          | Just match <- Map.lookup binding (getExportsMap exportsMap)-          -- Only for the situation that data constructor name is same as type constructor name,-          -- let ident with parent be in front of the one without.-          , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match)-          , idents <- filter (\ident -> moduleNameText ident == mod && (canUseDatacon || not (isDatacon ident))) sortedMatch-          , (not . null) idents -- Ensure fallback while `idents` is empty-          , ident <- head idents-          = Just ident--            -- fallback to using GHC suggestion even though it is not always correct-          | otherwise-          = Just IdentInfo-                { name = mkVarOcc $ T.unpack binding-                , rendered = binding-                , parent = Nothing-                , isDatacon = False-                , moduleNameText = mod}--data HidingMode-    = HideOthers [ModuleTarget]-    | ToQualified-        Bool-        -- ^ Parenthesised?-        ModuleName--data ModuleTarget-    = ExistingImp (NonEmpty (LImportDecl GhcPs))-    | ImplicitPrelude [LImportDecl GhcPs]--targetImports :: ModuleTarget -> [LImportDecl GhcPs]-targetImports (ExistingImp ne)     = NE.toList ne-targetImports (ImplicitPrelude xs) = xs--oneAndOthers :: [a] -> [(a, [a])]-oneAndOthers = go-    where-        go []       = []-        go (x : xs) = (x, xs) : map (second (x :)) (go xs)--isPreludeImplicit :: DynFlags -> Bool-isPreludeImplicit = xopt Lang.ImplicitPrelude---- | Suggests disambiguation for ambiguous symbols.-suggestImportDisambiguation ::-    DynFlags ->-    Maybe T.Text ->-    ParsedSource ->-    T.Text ->-    Diagnostic ->-    [(T.Text, [Either TextEdit Rewrite])]-suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileContents diag@Diagnostic {..}-    | Just [ambiguous] <--        matchRegexUnifySpaces-            _message-            "Ambiguous occurrence ‘([^’]+)’"-      , Just modules <--            map last-                <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’"-      , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" =-        suggestions ambiguous modules (isJust local)-    | otherwise = []-    where-        locDic =-            fmap (NE.fromList . DL.toList) $-            Map.fromListWith (<>) $-                map-                    ( \i@(L _ idecl) ->-                        ( T.pack $ moduleNameString $ unLoc $ ideclName idecl-                        , DL.singleton i-                        )-                    )-                    hsmodImports-        toModuleTarget "Prelude"-            | isPreludeImplicit df-             = Just $ ImplicitPrelude $-                maybe [] NE.toList (Map.lookup "Prelude" locDic)-        toModuleTarget mName = ExistingImp <$> Map.lookup mName locDic-        parensed =-            "(" `T.isPrefixOf` T.strip (textInRange _range txt)-        -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3]-        removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort-        hasDuplicate xs = length xs /= length (S.fromList xs)-        suggestions symbol mods local-          | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of-                                  Just targets -> suggestionsImpl symbol (map (, []) targets) local-                                  Nothing      -> []-          | otherwise         = case mapM toModuleTarget mods of-                                  Just targets -> suggestionsImpl symbol (oneAndOthers targets) local-                                  Nothing      -> []-        suggestionsImpl symbol targetsWithRestImports local =-            sortOn fst-            [ ( renderUniquify mode modNameText symbol False-              , disambiguateSymbol ps fileContents diag symbol mode-              )-            | (modTarget, restImports) <- targetsWithRestImports-            , let modName = targetModuleName modTarget-                  modNameText = T.pack $ moduleNameString modName-            , mode <--                [ ToQualified parensed qual-                | ExistingImp imps <- [modTarget]-#if MIN_VERSION_ghc(9,0,0)-                {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -}-                -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation-                -- nubOrd can't be used since SrcSpan is intentionally no Ord-                , L _ qual <- nub $ mapMaybe (ideclAs . unLoc)-#else-                , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc)-#endif-                    $ NE.toList imps-                ]-                ++ [ToQualified parensed modName-                    | any (occursUnqualified symbol . unLoc)-                        (targetImports modTarget)-                    || case modTarget of-                        ImplicitPrelude{} -> True-                        _                 -> False-                    ]-                ++ [HideOthers restImports | not (null restImports)]-            ] ++ [ ( renderUniquify mode T.empty symbol True-              , disambiguateSymbol ps fileContents diag symbol mode-              ) | local, not (null targetsWithRestImports)-                , let mode = HideOthers (uncurry (:) (head targetsWithRestImports))-            ]-        renderUniquify HideOthers {} modName symbol local =-            "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports"-        renderUniquify (ToQualified _ qual) _ symbol _ =-            "Replace with qualified: "-                <> T.pack (moduleNameString qual)-                <> "."-                <> symbol-suggestImportDisambiguation _ _ _ _ _ = []--occursUnqualified :: T.Text -> ImportDecl GhcPs -> Bool-occursUnqualified symbol ImportDecl{..}-    | isNothing ideclAs = Just False /=-            -- I don't find this particularly comprehensible,-            -- but HLint suggested me to do so...-        (ideclHiding <&> \(isHiding, L _ ents) ->-            let occurs = any ((symbol `symbolOccursIn`) . unLoc) ents-            in isHiding && not occurs || not isHiding && occurs-        )-occursUnqualified _ _ = False--symbolOccursIn :: T.Text -> IE GhcPs -> Bool-symbolOccursIn symb = any ((== symb). printOutputable) . ieNames--targetModuleName :: ModuleTarget -> ModuleName-targetModuleName ImplicitPrelude{} = mkModuleName "Prelude"-targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) =-    unLoc ideclName-targetModuleName (ExistingImp _) =-    error "Cannot happen!"--disambiguateSymbol ::-    ParsedSource ->-    T.Text ->-    Diagnostic ->-    T.Text ->-    HidingMode ->-    [Either TextEdit Rewrite]-disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case-    (HideOthers hiddens0) ->-        [ Right $ hideSymbol symbol idecl-        | ExistingImp idecls <- hiddens0-        , idecl <- NE.toList idecls-        ]-            ++ mconcat-                [ if null imps-                    then maybeToList $ Left . snd <$> newImportToEdit (hideImplicitPreludeSymbol $ T.pack symbol) pm fileContents-                    else Right . hideSymbol symbol <$> imps-                | ImplicitPrelude imps <- hiddens0-                ]-    (ToQualified parensed qualMod) ->-        let occSym = mkVarOcc symbol-            rdr = Qual qualMod occSym-         in Right <$> [ if parensed-                then Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->-                    liftParseAST @(HsExpr GhcPs) df $-                    T.unpack $ printOutputable $-                        HsVar @GhcPs noExtField $-                            reLocA $ L (mkGeneralSrcSpan  "") rdr-                else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df ->-                    liftParseAST @RdrName df $-                    T.unpack $ printOutputable $ L (mkGeneralSrcSpan  "") rdr-            ]-findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs)-findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs--suggestFixConstructorImport :: Diagnostic -> [(T.Text, TextEdit)]-suggestFixConstructorImport Diagnostic{_range=_range,..}-    -- ‘Success’ is a data constructor of ‘Result’-    -- To import it use-    -- import Data.Aeson.Types( Result( Success ) )-    -- or-    -- import Data.Aeson.Types( Result(..) ) (lsp-ui)-  | Just [constructor, typ] <--    matchRegexUnifySpaces _message-    "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"-  = let fixedImport = typ <> "(" <> constructor <> ")"-    in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]-  | otherwise = []---- | Suggests a constraint for a declaration for which a constraint is missing.-suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..}-  | Just missingConstraint <- findMissingConstraint _message-  = let codeAction = if _message =~ ("the type signature for:" :: String)-                        then suggestFunctionConstraint df parsedModule-                        else suggestInstanceConstraint df parsedModule-     in codeAction diag missingConstraint-  | otherwise = []-    where-      findMissingConstraint :: T.Text -> Maybe T.Text-      findMissingConstraint t =-        let regex = "(No instance for|Could not deduce) \\((.+)\\) arising from" -- a use of / a do statement-            regexImplicitParams = "Could not deduce: (\\?.+) arising from a use of"-            match = matchRegexUnifySpaces t regex-            matchImplicitParams = matchRegexUnifySpaces t regexImplicitParams-        in match <|> matchImplicitParams <&> last---- | Suggests a constraint for an instance declaration for which a constraint is missing.-suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]--suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint-  | Just instHead <- instanceHead-  = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)]-  | otherwise = []-    where-      instanceHead-        -- Suggests a constraint for an instance declaration with no existing constraints.-        -- • No instance for (Eq a) arising from a use of ‘==’-        --   Possible fix: add (Eq a) to the context of the instance declaration-        -- • In the expression: x == y-        --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y-        --   In the instance declaration for ‘Eq (Wrap a)’-        | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"-        , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls-        = Just instHead-        -- Suggests a constraint for an instance declaration with one or more existing constraints.-        -- • Could not deduce (Eq b) arising from a use of ‘==’-        --   from the context: Eq a-        --     bound by the instance declaration at /path/to/Main.hs:7:10-32-        --   Possible fix: add (Eq b) to the context of the instance declaration-        -- • In the second argument of ‘(&&)’, namely ‘x' == y'’-        --   In the expression: x == y && x' == y'-        --   In an equation for ‘==’:-        --       (Pair x x') == (Pair y y') = x == y && x' == y'-        | Just [instanceLineStr, constraintFirstCharStr]-            <- matchRegexUnifySpaces _message "bound by the instance declaration at .+:([0-9]+):([0-9]+)"-#if !MIN_VERSION_ghc(9,2,0)-        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = HsIB{hsib_body}})))-#else-        , Just (L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig{sig_body = hsib_body})})))-#endif-            <- findDeclContainingLoc (Position (readPositionNumber instanceLineStr) (readPositionNumber constraintFirstCharStr)) hsmodDecls-        = Just hsib_body-        | otherwise-        = Nothing--      readPositionNumber :: T.Text -> UInt-      readPositionNumber = T.unpack >>> read @Integer >>> fromIntegral--      actionTitle :: T.Text -> T.Text-      actionTitle constraint = "Add `" <> constraint-        <> "` to the context of the instance declaration"--suggestImplicitParameter ::-  ParsedSource ->-  Diagnostic ->-  [(T.Text, Rewrite)]-suggestImplicitParameter (L _ HsModule {hsmodDecls}) Diagnostic {_message, _range}-  | Just [implicitT] <- matchRegexUnifySpaces _message "Unbound implicit parameter \\(([^:]+::.+)\\) arising",-    Just (L _ (ValD _ FunBind {fun_id = L _ funId})) <- findDeclContainingLoc (_start _range) hsmodDecls,-#if !MIN_VERSION_ghc(9,2,0)-    Just (TypeSig _ _ HsWC {hswc_body = HsIB {hsib_body}})-#else-    Just (TypeSig _ _ HsWC {hswc_body = (unLoc -> HsSig {sig_body = hsib_body})})-#endif-      <- findSigOfDecl (== funId) hsmodDecls-    =-      [( "Add " <> implicitT <> " to the context of " <> T.pack (printRdrName funId)-        , appendConstraint (T.unpack implicitT) hsib_body)]-  | otherwise = []--findTypeSignatureName :: T.Text -> Maybe T.Text-findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head---- | Suggests a constraint for a type signature with any number of existing constraints.-suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]--suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint--- • No instance for (Eq a) arising from a use of ‘==’---   Possible fix:---     add (Eq a) to the context of---       the type signature for:---         eq :: forall a. a -> a -> Bool--- • In the expression: x == y---   In an equation for ‘eq’: eq x y = x == y---- • Could not deduce (Eq b) arising from a use of ‘==’---   from the context: Eq a---     bound by the type signature for:---                eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool---     at Main.hs:5:1-42---   Possible fix:---     add (Eq b) to the context of---       the type signature for:---         eq :: forall a b. Eq a => Pair a b -> Pair a b -> Bool--- • In the second argument of ‘(&&)’, namely ‘y == y'’---   In the expression: x == x' && y == y'---   In an equation for ‘eq’:---       eq (Pair x y) (Pair x' y') = x == x' && y == y'-  | Just typeSignatureName <- findTypeSignatureName _message-#if !MIN_VERSION_ghc(9,2,0)-  , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}})-#else-  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})-#endif-    <- findSigOfDecl ((T.unpack typeSignatureName ==) . showSDoc df . ppr) hsmodDecls-  , title <- actionTitle missingConstraint typeSignatureName-  = [(title, appendConstraint (T.unpack missingConstraint) sig)]-  | otherwise-  = []-    where-      actionTitle :: T.Text -> T.Text -> T.Text-      actionTitle constraint typeSignatureName = "Add `" <> constraint-        <> "` to the context of the type signature for `" <> typeSignatureName <> "`"---- | Suggests the removal of a redundant constraint for a type signature.-removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]-removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..}--- • Redundant constraint: Eq a--- • In the type signature for:---      foo :: forall a. Eq a => a -> a--- • Redundant constraints: (Monoid a, Show a)--- • In the type signature for:---      foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool-  -- Account for both "Redundant constraint" and "Redundant constraints".-  | "Redundant constraint" `T.isInfixOf` _message-  , Just typeSignatureName <- findTypeSignatureName _message-#if !MIN_VERSION_ghc(9,2,0)-  , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}})-#else-  , Just (TypeSig _ _ HsWC{hswc_body = (unLoc -> HsSig {sig_body = sig})})-#endif-    <- fmap(traceAst "redundantConstraint") $ findSigOfDeclRanged _range hsmodDecls-  , Just redundantConstraintList <- findRedundantConstraints _message-  , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig-      = [(actionTitle redundantConstraintList typeSignatureName, rewrite)]-  | otherwise = []-    where-      toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list)--      parseConstraints :: T.Text -> [T.Text]-      parseConstraints t = t-        & (T.strip >>> stripConstraintsParens >>> T.splitOn ",")-        <&> T.strip--      stripConstraintsParens :: T.Text -> T.Text-      stripConstraintsParens constraints =-        if "(" `T.isPrefixOf` constraints-           then constraints & T.drop 1 & T.dropEnd 1 & T.strip-           else constraints--{--9.2: "message": "/private/var/folders/4m/d38fhm3936x_gy_9883zbq8h0000gn/T/extra-dir-53173393699/Testing.hs:4:1: warning:-    ⢠Redundant constraints: (Eq a, Show a)-    ⢠In the type signature for:-               foo :: forall a. (Eq a, Show a) => a -> Bool",--9.0: "message": "⢠Redundant constraints: (Eq a, Show a)-    ⢠In the type signature for:-           foo :: forall a. (Eq a, Show a) => a -> Bool",--}-      findRedundantConstraints :: T.Text -> Maybe [T.Text]-      findRedundantConstraints t = t-        & T.lines-        -- In <9.2 it's the first line, in 9.2 it' the second line-        & take 2-        & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip)-        & listToMaybe-        <&> (head >>> parseConstraints)--      formatConstraints :: [T.Text] -> T.Text-      formatConstraints [] = ""-      formatConstraints [constraint] = constraint-      formatConstraints constraintList = constraintList-        & T.intercalate ", "-        & \cs -> "(" <> cs <> ")"--      actionTitle :: [T.Text] -> T.Text -> T.Text-      actionTitle constraintList typeSignatureName =-        "Remove redundant constraint" <> (if length constraintList == 1 then "" else "s") <> " `"-        <> formatConstraints constraintList-        <> "` from the context of the type signature for `" <> typeSignatureName <> "`"-----------------------------------------------------------------------------------------------------suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])]-suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message}-  | Just [methodName, className] <--      matchRegexUnifySpaces-        _message-        "‘([^’]*)’ is not a \\(visible\\) method of class ‘([^’]*)’",-    idents <--      maybe [] (Set.toList . Set.filter (\x -> parent x == Just className)) $-        Map.lookup methodName $ getExportsMap packageExportsMap =-    mconcat $ suggest <$> idents-  | otherwise = []-  where-    suggest identInfo@IdentInfo {moduleNameText}-      | importStyle <- NE.toList $ importStyles identInfo,-        mImportDecl <- findImportDeclByModuleName (hsmodImports $ unLoc ps) (T.unpack moduleNameText) =-        case mImportDecl of-          -- extend-          Just decl ->-            [ ( "Add " <> renderImportStyle style <> " to the import list of " <> moduleNameText,-                quickFixImportKind' "extend" style,-                [Right $ uncurry extendImport (unImportStyle style) decl]-              )-              | style <- importStyle-            ]-          -- new-          _-            | Just (range, indent) <- newImportInsertRange ps fileContents-            ->-             (\(kind, unNewImport -> x) -> (x, kind, [Left $ TextEdit range (x <> "\n" <> T.replicate indent " ")])) <$>-            [ (quickFixImportKind' "new" style, newUnqualImport moduleNameText rendered False)-              | style <- importStyle,-                let rendered = renderImportStyle style-            ]-              <> [(quickFixImportKind "new.all", newImportAll moduleNameText)]-            | otherwise -> []--suggestNewImport :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]-suggestNewImport packageExportsMap ps@(L _ HsModule {..}) fileContents Diagnostic{_message}-  | msg <- unifySpaces _message-  , Just thingMissing <- extractNotInScopeName msg-  , qual <- extractQualifiedModuleName msg-  , qual' <--      extractDoesNotExportModuleName msg-        >>= (findImportDeclByModuleName hsmodImports . T.unpack)-        >>= ideclAs . unLoc-        <&> T.pack . moduleNameString . unLoc-  , Just (range, indent) <- newImportInsertRange ps fileContents-  , extendImportSuggestions <- matchRegexUnifySpaces msg-    "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"-  = sortOn fst3 [(imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))-    | (kind, unNewImport -> imp) <- constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions-    ]-suggestNewImport _ _ _ _ = []--constructNewImportSuggestions-  :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [(CodeActionKind, NewImport)]-constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrdOn snd-  [ suggestion-  | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing]-  , identInfo <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap)-  , canUseIdent thingMissing identInfo-  , moduleNameText identInfo `notElem` fromMaybe [] notTheseModules-  , suggestion <- renderNewImport identInfo-  ]- where-  renderNewImport :: IdentInfo -> [(CodeActionKind, NewImport)]-  renderNewImport identInfo-    | Just q <- qual-    = [(quickFixImportKind "new.qualified", newQualImport m q)]-    | otherwise-    = [(quickFixImportKind' "new" importStyle, newUnqualImport m (renderImportStyle importStyle) False)-      | importStyle <- NE.toList $ importStyles identInfo] ++-      [(quickFixImportKind "new.all", newImportAll m)]-    where-        m = moduleNameText identInfo--newtype NewImport = NewImport {unNewImport :: T.Text}-  deriving (Show, Eq, Ord)--newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit)-newImportToEdit (unNewImport -> imp) ps fileContents-  | Just (range, indent) <- newImportInsertRange ps fileContents-  = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " "))-  | otherwise = Nothing---- | Finds the next valid position for inserting a new import declaration--- * If the file already has existing imports it will be inserted under the last of these,--- it is assumed that the existing last import declaration is in a valid position--- * If the file does not have existing imports, but has a (module ... where) declaration,--- the new import will be inserted directly under this declaration (accounting for explicit exports)--- * If the file has neither existing imports nor a module declaration,--- the import will be inserted at line zero if there are no pragmas,--- * otherwise inserted one line after the last file-header pragma-newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int)-newImportInsertRange (L _ HsModule {..}) fileContents-  |  Just ((l, c), col) <- case hsmodImports of-      [] -> findPositionNoImports (fmap reLoc hsmodName) (fmap reLoc hsmodExports) fileContents-      _  -> findPositionFromImportsOrModuleDecl (map reLoc hsmodImports) last True-  , let insertPos = Position (fromIntegral l) (fromIntegral c)-    = Just (Range insertPos insertPos, col)-  | otherwise = Nothing---- | Insert the import under the Module declaration exports if they exist, otherwise just under the module declaration.--- If no module declaration exists, then no exports will exist either, in that case--- insert the import after any file-header pragmas or at position zero if there are no pragmas-findPositionNoImports :: Maybe (Located ModuleName) -> Maybe (Located [LIE name]) -> T.Text -> Maybe ((Int, Int), Int)-findPositionNoImports Nothing _ fileContents = findNextPragmaPosition fileContents-findPositionNoImports _ (Just hsmodExports) _ = findPositionFromImportsOrModuleDecl hsmodExports id False-findPositionNoImports (Just hsmodName) _ _ = findPositionFromImportsOrModuleDecl hsmodName id False--findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int)-findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of-  RealSrcSpan s _ ->-    let col = calcCol s-     in Just ((srcLocLine (realSrcSpanEnd s), col), col)-  _ -> Nothing-  where calcCol s = if hasImports then srcLocCol (realSrcSpanStart s) - 1 else 0---- | Find the position one after the last file-header pragma--- Defaults to zero if there are no pragmas in file-findNextPragmaPosition :: T.Text -> Maybe ((Int, Int), Int)-findNextPragmaPosition contents = Just ((lineNumber, 0), 0)-  where-    lineNumber = afterLangPragma . afterOptsGhc $ afterShebang-    afterLangPragma = afterPragma "LANGUAGE" contents'-    afterOptsGhc = afterPragma "OPTIONS_GHC" contents'-    afterShebang = lastLineWithPrefix (T.isPrefixOf "#!") contents' 0-    contents' = T.lines contents--afterPragma :: T.Text -> [T.Text] -> Int -> Int-afterPragma name contents lineNum = lastLineWithPrefix (checkPragma name) contents lineNum--lastLineWithPrefix :: (T.Text -> Bool) -> [T.Text] -> Int -> Int-lastLineWithPrefix p contents lineNum = max lineNum next-  where-    next = maybe lineNum succ $ listToMaybe . reverse $ findIndices p contents--checkPragma :: T.Text -> T.Text -> Bool-checkPragma name = check-  where-    check l = isPragma l && getName l == name-    getName l = T.take (T.length name) $ T.dropWhile isSpace $ T.drop 3 l-    isPragma = T.isPrefixOf "{-#"---- | Construct an import declaration with at most one symbol-newImport-  :: T.Text -- ^ module name-  -> Maybe T.Text -- ^  the symbol-  -> Maybe T.Text -- ^ qualified name-  -> Bool -- ^ the symbol is to be imported or hidden-  -> NewImport-newImport modName mSymbol mQual hiding = NewImport impStmt-  where-     symImp-            | Just symbol <- mSymbol-              , symOcc <- mkVarOcc $ T.unpack symbol =-              " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")"-            | otherwise = ""-     impStmt =-       "import "-         <> maybe "" (const "qualified ") mQual-         <> modName-         <> (if hiding then " hiding" else "")-         <> symImp-         <> maybe "" (\qual -> if modName == qual then "" else " as " <> qual) mQual--newQualImport :: T.Text -> T.Text -> NewImport-newQualImport modName qual = newImport modName Nothing (Just qual) False--newUnqualImport :: T.Text -> T.Text -> Bool -> NewImport-newUnqualImport modName symbol = newImport modName (Just symbol) Nothing--newImportAll :: T.Text -> NewImport-newImportAll modName = newImport modName Nothing Nothing False--hideImplicitPreludeSymbol :: T.Text -> NewImport-hideImplicitPreludeSymbol symbol = newUnqualImport "Prelude" symbol True--canUseIdent :: NotInScope -> IdentInfo -> Bool-canUseIdent NotInScopeDataConstructor{}        = isDatacon-canUseIdent NotInScopeTypeConstructorOrClass{} = not . isDatacon-canUseIdent _                                  = const True--data NotInScope-    = NotInScopeDataConstructor T.Text-    | NotInScopeTypeConstructorOrClass T.Text-    | NotInScopeThing T.Text-    deriving Show--notInScope :: NotInScope -> T.Text-notInScope (NotInScopeDataConstructor t)        = t-notInScope (NotInScopeTypeConstructorOrClass t) = t-notInScope (NotInScopeThing t)                  = t--extractNotInScopeName :: T.Text -> Maybe NotInScope-extractNotInScopeName x-  | Just [name] <- matchRegexUnifySpaces x "Data constructor not in scope: ([^ ]+)"-  = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegexUnifySpaces x "Not in scope: data constructor [^‘]*‘([^’]*)’"-  = Just $ NotInScopeDataConstructor name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"-  = Just $ NotInScopeTypeConstructorOrClass name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: \\(([^‘ ]+)\\)"-  = Just $ NotInScopeThing name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope: ([^‘ ]+)"-  = Just $ NotInScopeThing name-  | Just [name] <- matchRegexUnifySpaces x "ot in scope:[^‘]*‘([^’]*)’"-  = Just $ NotInScopeThing name-  | otherwise-  = Nothing--extractQualifiedModuleName :: T.Text -> Maybe T.Text-extractQualifiedModuleName x-  | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’"-  = Just m-  | otherwise-  = Nothing---- | If a module has been imported qualified, and we want to ues the same qualifier for other modules--- which haven't been imported, 'extractQualifiedModuleName' won't work. Thus we need extract the qualifier--- from the imported one.------ For example, we write f = T.putStrLn, where putStrLn comes from Data.Text.IO, with the following import(s):--- 1.--- import qualified Data.Text as T------ Module ‘Data.Text’ does not export ‘putStrLn’.------ 2.--- import qualified Data.Text as T--- import qualified Data.Functor as T------ Neither ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.------ 3.--- import qualified Data.Text as T--- import qualified Data.Functor as T--- import qualified Data.Function as T------ Neither ‘Data.Function’,---         ‘Data.Functor’ nor ‘Data.Text’ exports ‘putStrLn’.-extractDoesNotExportModuleName :: T.Text -> Maybe T.Text-extractDoesNotExportModuleName x-  | Just [m] <--    matchRegexUnifySpaces x "Module ‘([^’]*)’ does not export"-      <|> matchRegexUnifySpaces x "nor ‘([^’]*)’ exports"-  = Just m-  | otherwise-  = Nothing-----------------------------------------------------------------------------------------------------mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit-mkRenameEdit contents range name =-    if maybeIsInfixFunction == Just True-      then TextEdit range ("`" <> name <> "`")-      else TextEdit range name-  where-    maybeIsInfixFunction = do-      curr <- textInRange range <$> contents-      pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr----- | Extract the type and surround it in parentheses except in obviously safe cases.------ Inferring when parentheses are actually needed around the type signature would--- require understanding both the precedence of the context of the hole and of--- the signature itself. Inserting them (almost) unconditionally is ugly but safe.-extractWildCardTypeSignature :: T.Text -> T.Text-extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature-  where-    msgSigPart = snd $ T.breakOnEnd "standing for " msg-    signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart-    -- parenthesize type applications, e.g. (Maybe Char)-    application = any isSpace . T.unpack $ signature-    -- do not add extra parentheses to lists, tuples and already parenthesized types-    enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')]-    bracket = ("(" `T.append`) . (`T.append` ")")--extractRenamableTerms :: T.Text -> [T.Text]-extractRenamableTerms msg-  -- Account for both "Variable not in scope" and "Not in scope"-  | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg-  | otherwise = []-  where-    extractSuggestions = map getEnclosed-                       . concatMap singleSuggestions-                       . filter isKnownSymbol-                       . T.lines-    singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited-    isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t-    getEnclosed = T.dropWhile (== '‘')-                . T.dropWhileEnd (== '’')-                . T.dropAround (\c -> c /= '‘' && c /= '’')---- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace--- between the end of the range and the next newline), extend the range to take up the whole line.-extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range-extendToWholeLineIfPossible contents range@Range{..} =-    let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents-        extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line-    in if extend then Range _start (Position (_line _end + 1) 0) else range--splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)-splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x-    | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x-    , (preCol, postCol) <- T.splitAt col mid-        = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)-    | otherwise = (x, T.empty)---- | Returns [start .. end[-textInRange :: Range -> T.Text -> T.Text-textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =-    case compare startRow endRow of-      LT ->-        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine-            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of-              [] -> ("", [])-              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)-            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines-        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)-      EQ ->-        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)-        in T.take (endCol - startCol) (T.drop startCol line)-      GT -> ""-    where-      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)---- | Returns the ranges for a binding in an import declaration-rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]-rangesForBindingImport ImportDecl{ideclHiding = Just (False, L _ lies)} b =-    concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies-  where-    b' = wrapOperatorInParens b-rangesForBindingImport _ _ = []--wrapOperatorInParens :: String -> String-wrapOperatorInParens x =-  case uncons x of-    Just (h, _t) -> if is_ident h then x else "(" <> x <> ")"-    Nothing      -> mempty--smallerRangesForBindingExport :: [LIE GhcPs] -> String -> [Range]-smallerRangesForBindingExport lies b =-    concatMap (mapMaybe srcSpanToRange . ranges') lies-  where-    unqualify = snd . breakOnEnd "."-    b' = wrapOperatorInParens . unqualify $ b-#if !MIN_VERSION_ghc(9,2,0)-    ranges' (L _ (IEThingWith _ thing _  inners labels))-      | T.unpack (printOutputable thing) == b' = []-      | otherwise =-          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']-          ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b']-#else-    ranges' (L _ (IEThingWith _ thing _  inners))-      | T.unpack (printOutputable thing) == b' = []-      | otherwise =-          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']-#endif-    ranges' _ = []--rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]-rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l]-rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l]-rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l]-#if !MIN_VERSION_ghc(9,2,0)-rangesForBinding' b (L l (IEThingWith _ thing _  inners labels))-#else-rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _  inners))-#endif-    | T.unpack (printOutputable thing) == b = [l]-    | otherwise =-        [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b]-#if !MIN_VERSION_ghc(9,2,0)-        ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b]-#endif-rangesForBinding' _ _ = []---- | 'matchRegex' combined with 'unifySpaces'-matchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [T.Text]-matchRegexUnifySpaces message = matchRegex (unifySpaces message)---- | 'allMatchRegex' combined with 'unifySpaces'-allMatchRegexUnifySpaces :: T.Text -> T.Text -> Maybe [[T.Text]]-allMatchRegexUnifySpaces message =-    allMatchRegex (unifySpaces message)---- | Returns Just (the submatches) for the first capture, or Nothing.-matchRegex :: T.Text -> T.Text -> Maybe [T.Text]-matchRegex message regex = case message =~~ regex of-    Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings-    Nothing                                                -> Nothing---- | Returns Just (all matches) for the first capture, or Nothing.-allMatchRegex :: T.Text -> T.Text -> Maybe [[T.Text]]-allMatchRegex message regex = message =~~ regex---unifySpaces :: T.Text -> T.Text-unifySpaces    = T.unwords . T.words---- functions to help parse multiple import suggestions---- | Returns the first match if found-regexSingleMatch :: T.Text -> T.Text -> Maybe T.Text-regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of-    Just (h:_) -> Just h-    _          -> Nothing---- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and--- | return (Data.Map, app/ModuleB.hs:2:1-18)-regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)-regExPair (modname, srcpair) = do-  x <- regexSingleMatch modname "‘([^’]*)’"-  y <- regexSingleMatch srcpair "\\((.*)\\)"-  return (x, y)---- | Process a list of (module_name, filename:src_span) values--- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]-regExImports :: T.Text -> Maybe [(T.Text, T.Text)]-regExImports msg = result-  where-    parts = T.words msg-    isPrefix = not . T.isPrefixOf "("-    (mod, srcspan) = partition isPrefix  parts-    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))-    result = if length mod == length srcspan then-               regExPair `traverse` zip mod srcspan-             else Nothing--matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])-matchRegExMultipleImports message = do-  let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"-  (binding, imports) <- case matchRegexUnifySpaces message pat of-                            Just [x, xs] -> Just (x, xs)-                            _            -> Nothing-  imps <- regExImports imports-  return (binding, imps)---- | Possible import styles for an 'IdentInfo'.------ The first 'Text' parameter corresponds to the 'rendered' field of the--- 'IdentInfo'.-data ImportStyle-    = ImportTopLevel T.Text-      -- ^ Import a top-level export from a module, e.g., a function, a type, a-      -- class.-      ---      -- > import M (?)-      ---      -- Some exports that have a parent, like a type-class method or an-      -- associated type/data family, can still be imported as a top-level-      -- import.-      ---      -- Note that this is not the case for constructors, they must always be-      -- imported as part of their parent data type.--    | ImportViaParent T.Text T.Text-      -- ^ Import an export (first parameter) through its parent (second-      -- parameter).-      ---      -- import M (P(?))-      ---      -- @P@ and @?@ can be a data type and a constructor, a class and a method,-      -- a class and an associated type/data family, etc.--    | ImportAllConstructors T.Text-      -- ^ Import all constructors for a specific data type.-      ---      -- import M (P(..))-      ---      -- @P@ can be a data type or a class.-  deriving Show--importStyles :: IdentInfo -> NonEmpty ImportStyle-importStyles IdentInfo {parent, rendered, isDatacon}-  | Just p <- parent-    -- Constructors always have to be imported via their parent data type, but-    -- methods and associated type/data families can also be imported as-    -- top-level exports.-  = ImportViaParent rendered p-      :| [ImportTopLevel rendered | not isDatacon]-      <> [ImportAllConstructors p]-  | otherwise-  = ImportTopLevel rendered :| []---- | Used for adding new imports-renderImportStyle :: ImportStyle -> T.Text-renderImportStyle (ImportTopLevel x)   = x-renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"-renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"-renderImportStyle (ImportAllConstructors p) = p <> "(..)"---- | Used for extending import lists-unImportStyle :: ImportStyle -> (Maybe String, String)-unImportStyle (ImportTopLevel x)    = (Nothing, T.unpack x)-unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)-unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)---quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind-quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel"-quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"-quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"--quickFixImportKind :: T.Text -> CodeActionKind-quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x
− src/Development/IDE/Plugin/CodeAction/Args.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleInstances #-}--module Development.IDE.Plugin.CodeAction.Args-  ( CodeActionTitle,-    CodeActionPreferred,-    GhcideCodeActionResult,-    GhcideCodeAction,-    mkGhcideCAPlugin,-    mkGhcideCAsPlugin,-    ToTextEdit (..),-    ToCodeAction (..),-    wrap,-    mkCA,-  )-where--import           Control.Concurrent.STM.Stats                 (readTVarIO)-import           Control.Monad.Reader-import           Control.Monad.Trans.Maybe-import           Data.Either                                  (fromRight)-import qualified Data.HashMap.Strict                          as Map-import           Data.IORef.Extra-import           Data.Maybe                                   (fromMaybe)-import qualified Data.Text                                    as T-import           Development.IDE                              hiding-                                                              (pluginHandlers)-import           Development.IDE.Core.Shake-import           Development.IDE.GHC.Compat-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite,-                                                               rewriteToEdit)-import           Development.IDE.Plugin.TypeLenses            (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs),-                                                               GlobalBindingTypeSigsResult)-import           Development.IDE.Spans.LocalBindings          (Bindings)-import           Development.IDE.Types.Exports                (ExportsMap)-import           Development.IDE.Types.Options                (IdeOptions)-import           Ide.Plugin.Config                            (Config)-import           Ide.Types-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types--type CodeActionTitle = T.Text--type CodeActionPreferred = Bool--type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])]--type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult-----------------------------------------------------------------------------------------------------{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-}-runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult-runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do-  let mbFile = toNormalizedFilePath' <$> uriToFilePath uri-      runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key-  caaGhcSession <- onceIO $ runRule GhcSession-  caaExportsMap <--    onceIO $-      caaGhcSession >>= \case-        Just env -> do-          pkgExports <- envPackageExports env-          localExports <- readTVarIO (exportsMap $ shakeExtras state)-          pure $ localExports <> pkgExports-        _ -> pure mempty-  caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions-  caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments-  caaContents <--    onceIO $-      runRule GetFileContents >>= \case-        Just (_, txt) -> pure txt-        _             -> pure Nothing-  caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule-  caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource-  caaTmr <- onceIO $ runRule TypeCheck-  caaHar <- onceIO $ runRule GetHieAst-  caaBindings <- onceIO $ runRule GetBindings-  caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs-  liftIO $-    concat-      <$> sequence-        [ runReaderT codeAction caa-          | caaDiagnostic <- diags,-            let caa = CodeActionArgs {..}-        ]--mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction)-mkCA title kind isPreferred diags edit =-  InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing--mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState-mkGhcideCAPlugin codeAction plId =-  (defaultPluginDescriptor plId)-    { pluginHandlers = mkPluginHandler STextDocumentCodeAction $-        \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do-          results <- runGhcideCodeAction state params codeAction-          pure $-            Right $-              List-                [ mkCA title kind isPreferred diags edit-                  | (title, kind, isPreferred, tedit) <- results,-                    let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing-                ]-    }--mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState-mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions-----------------------------------------------------------------------------------------------------class ToTextEdit a where-  toTextEdit :: CodeActionArgs -> a -> IO [TextEdit]--instance ToTextEdit TextEdit where-  toTextEdit _ = pure . pure--instance ToTextEdit Rewrite where-  toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $-    runMaybeT $ do-      df <- MaybeT caaDf-#if !MIN_VERSION_ghc(9,2,0)-      ps <- MaybeT caaAnnSource-      let r = rewriteToEdit df (annsA ps) rw-#else-      let r = rewriteToEdit df rw-#endif-      pure $ fromRight [] r--instance ToTextEdit a => ToTextEdit [a] where-  toTextEdit caa = foldMap (toTextEdit caa)--instance ToTextEdit a => ToTextEdit (Maybe a) where-  toTextEdit caa = maybe (pure []) (toTextEdit caa)--instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where-  toTextEdit caa = either (toTextEdit caa) (toTextEdit caa)-----------------------------------------------------------------------------------------------------data CodeActionArgs = CodeActionArgs-  { caaExportsMap   :: IO ExportsMap,-    caaGhcSession   :: IO (Maybe HscEnvEq),-    caaIdeOptions   :: IO IdeOptions,-    caaParsedModule :: IO (Maybe ParsedModule),-    caaContents     :: IO (Maybe T.Text),-    caaDf           :: IO (Maybe DynFlags),-    caaAnnSource    :: IO (Maybe (Annotated ParsedSource)),-    caaTmr          :: IO (Maybe TcModuleResult),-    caaHar          :: IO (Maybe HieAstResult),-    caaBindings     :: IO (Maybe Bindings),-    caaGblSigs      :: IO (Maybe GlobalBindingTypeSigsResult),-    caaDiagnostic   :: Diagnostic-  }---- | There's no concurrency in each provider,--- so we don't need to be thread-safe here-onceIO :: MonadIO m => IO a -> m (IO a)-onceIO io = do-  var <- liftIO $ newIORef Nothing-  pure $-    readIORef var >>= \case-      Just x -> pure x-      _      -> io >>= \x -> writeIORef' var (Just x) >> pure x-----------------------------------------------------------------------------------------------------wrap :: (ToCodeAction a) => a -> GhcideCodeAction-wrap = toCodeAction--class ToCodeAction a where-  toCodeAction :: a -> GhcideCodeAction--instance ToCodeAction GhcideCodeAction where-  toCodeAction = id--instance Semigroup GhcideCodeAction where-  a <> b = toCodeAction [a, b]--instance Monoid GhcideCodeAction where-  mempty = pure []--instance ToCodeAction a => ToCodeAction [a] where-  toCodeAction = fmap concat . mapM toCodeAction--instance ToCodeAction a => ToCodeAction (Maybe a) where-  toCodeAction = maybe (pure []) toCodeAction--instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where-  toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where-  toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where-  toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te--instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where-  toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te-----------------------------------------------------------------------------------------------------toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction-toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f--toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction-toCodeAction2 get f = ReaderT $ \caa ->-  get caa >>= \case-    Just x -> flip runReaderT caa . toCodeAction . f $ x-    _      -> pure []--toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction-toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f---- | this instance returns a delta AST, useful for exactprint transforms-instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where-  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} ->-    x >>= \case-      Just s -> flip runReaderT caa . toCodeAction . f . astA $ s-      _      -> pure []--instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where-  toCodeAction = toCodeAction3 caaExportsMap--instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where-  toCodeAction = toCodeAction3 caaIdeOptions--instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where-  toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x--instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where-  toCodeAction = toCodeAction1 caaParsedModule--instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where-  toCodeAction = toCodeAction2 caaParsedModule--instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where-  toCodeAction = toCodeAction1 caaContents--instance ToCodeAction r => ToCodeAction (T.Text -> r) where-  toCodeAction = toCodeAction2 caaContents--instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where-  toCodeAction = toCodeAction1 caaDf--instance ToCodeAction r => ToCodeAction (DynFlags -> r) where-  toCodeAction = toCodeAction2 caaDf--instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where-  toCodeAction = toCodeAction1 caaAnnSource--instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where-  toCodeAction = toCodeAction2 caaAnnSource--instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where-  toCodeAction = toCodeAction1 caaTmr--instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where-  toCodeAction = toCodeAction2 caaTmr--instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where-  toCodeAction = toCodeAction1 caaHar--instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where-  toCodeAction = toCodeAction2 caaHar--instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where-  toCodeAction = toCodeAction1 caaBindings--instance ToCodeAction r => ToCodeAction (Bindings -> r) where-  toCodeAction = toCodeAction2 caaBindings--instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where-  toCodeAction = toCodeAction1 caaGblSigs--instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where-  toCodeAction = toCodeAction2 caaGblSigs--instance ToCodeAction r => ToCodeAction (Maybe HscEnvEq -> r) where-  toCodeAction = toCodeAction1 caaGhcSession--instance ToCodeAction r => ToCodeAction (Maybe HscEnv -> r) where-  toCodeAction = toCodeAction1 ((fmap.fmap.fmap) hscEnv caaGhcSession)
− src/Development/IDE/Plugin/CodeAction/ExactPrint.hs 
@@ -1,698 +0,0 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs              #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE FlexibleInstances #-}--module Development.IDE.Plugin.CodeAction.ExactPrint (-  Rewrite (..),-  rewriteToEdit,-  rewriteToWEdit,-#if !MIN_VERSION_ghc(9,2,0)-  transferAnn,-#endif--  -- * Utilities-  appendConstraint,-  removeConstraint,-  extendImport,-  hideSymbol,-  liftParseAST,--  wildCardSymbol-) where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.Extra                   (whenJust)-import           Control.Monad.Trans-import           Data.Char                             (isAlphaNum)-import           Data.Data                             (Data)-import           Data.Functor-import           Data.Generics                         (listify)-import qualified Data.Map.Strict                       as Map-import           Data.Maybe                            (fromJust, isNothing,-                                                        mapMaybe)-import qualified Data.Text                             as T-import           Development.IDE.GHC.Compat hiding (Annotation)-import           Development.IDE.GHC.Error-import           Development.IDE.GHC.ExactPrint-import           Development.IDE.Spans.Common-import           GHC.Exts                              (IsList (fromList))-import           Language.Haskell.GHC.ExactPrint-#if !MIN_VERSION_ghc(9,2,0)-import qualified Development.IDE.GHC.Compat.Util       as Util-import           Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP),-                                                        KeywordId (G), mkAnnKey)-#else-import Data.Default-import           GHC (AddEpAnn (..), AnnContext (..), AnnParen (..),-                      DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta),-                      IsUnicodeSyntax (NormalSyntax),-                      NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments,-                      reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA)-#endif-import           Language.LSP.Types-import Development.IDE.GHC.Util-import Data.Bifunctor (first)-import Control.Lens (_head, _last, over)-import GHC.Stack (HasCallStack)------------------------------------------------------------------------------------ | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the---   given 'ast'.-data Rewrite where-  Rewrite ::-#if !MIN_VERSION_ghc(9,2,0)-    Annotate ast =>-#else-    (ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) =>-#endif-    -- | The 'SrcSpan' that we want to rewrite-    SrcSpan ->-    -- | The ast that we want to graft-#if !MIN_VERSION_ghc(9,2,0)-    (DynFlags -> TransformT (Either String) (Located ast)) ->-#else-    (DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) ->-#endif-    Rewrite---------------------------------------------------------------------------------#if MIN_VERSION_ghc(9,2,0)-class ResetEntryDP ann where-    resetEntryDP :: GenLocated ann ast -> GenLocated ann ast-instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where-    -- resetEntryDP = flip setEntryDP (SameLine 0)-    resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0)-instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where-    resetEntryDP = id-#endif---- | Convert a 'Rewrite' into a list of '[TextEdit]'.-rewriteToEdit :: HasCallStack =>-  DynFlags ->-#if !MIN_VERSION_ghc(9,2,0)-  Anns ->-#endif-  Rewrite ->-  Either String [TextEdit]-rewriteToEdit dflags-#if !MIN_VERSION_ghc(9,2,0)-              anns-#endif-              (Rewrite dst f) = do-  (ast, anns , _) <- runTransformT-#if !MIN_VERSION_ghc(9,2,0)-                            anns-#endif-                          $ do-    ast <- f dflags-#if !MIN_VERSION_ghc(9,2,0)-    ast <$ setEntryDPT ast (DP (0, 0))-#else-    pure $ traceAst "REWRITE_result" $ resetEntryDP ast-#endif-  let editMap =-        [ TextEdit (fromJust $ srcSpanToRange dst) $-            T.pack $ exactPrint ast-#if !MIN_VERSION_ghc(9,2,0)-                       (fst anns)-#endif-        ]-  pure editMap---- | Convert a 'Rewrite' into a 'WorkspaceEdit'-rewriteToWEdit :: DynFlags-               -> Uri-#if !MIN_VERSION_ghc(9,2,0)-               -> Anns-#endif-               -> Rewrite-               -> Either String WorkspaceEdit-rewriteToWEdit dflags uri-#if !MIN_VERSION_ghc(9,2,0)-               anns-#endif-               r = do-  edits <- rewriteToEdit dflags-#if !MIN_VERSION_ghc(9,2,0)-                         anns-#endif-                         r-  return $-    WorkspaceEdit-      { _changes = Just (fromList [(uri, List edits)])-      , _documentChanges = Nothing-      , _changeAnnotations = Nothing-      }----------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,2,0)--- | Fix the parentheses around a type context-fixParens ::-  (Monad m, Data (HsType pass), pass ~ GhcPass p0) =>-  Maybe DeltaPos ->-  Maybe DeltaPos ->-  LHsContext pass ->-  TransformT m [LHsType pass]-fixParens-          openDP closeDP-          ctxt@(L _ elems) = do-  -- Paren annotation for type contexts are usually quite screwed up-  -- we remove duplicates and fix negative DPs-  let parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)]-  modifyAnnsT $-    Map.adjust-      ( \x ->-          let annsMap = Map.fromList (annsDP x)-           in x-                { annsDP =-                    Map.toList $-                      Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $-                        Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $-                          annsMap <> parens-                }-      )-      (mkAnnKey ctxt)-  return $ map dropHsParTy elems-#endif--dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass)-dropHsParTy (L _ (HsParTy _ ty)) = ty-dropHsParTy other                = other--removeConstraint ::-  -- | Predicate: Which context to drop.-  (LHsType GhcPs -> Bool) ->-  LHsType GhcPs ->-  Rewrite-removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"-  where-    go :: LHsType GhcPs -> Rewrite-#if !MIN_VERSION_ghc(9,2,0)-    go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do-#else-    go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do-#endif-      let ctxt' = filter (not . toRemove) ctxt-          removeStuff = (toRemove <$> headMaybe ctxt) == Just True-#if !MIN_VERSION_ghc(9,2,0)-      when removeStuff  $-        setEntryDPT hst_body (DP (0, 0))-      return $ L l $ it{hst_ctxt =  L l' ctxt'}-#else-      let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body-      return $ case ctxt' of-          [] -> hst_body'-          _ -> do-            let ctxt'' = over _last (first removeComma) ctxt'-            L l $ it{ hst_ctxt = Just $ L l' ctxt''-                    , hst_body = hst_body'-                    }-#endif-    go (L _ (HsParTy _ ty)) = go ty-    go (L _ HsForAllTy{hst_body}) = go hst_body-    go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other---- | Append a constraint at the end of a type context.---   If no context is present, a new one will be created.-appendConstraint ::-  -- | The new constraint to append-  String ->-  -- | The type signature where the constraint is to be inserted, also assuming annotated-  LHsType GhcPs ->-  Rewrite-appendConstraint constraintT = go . traceAst "appendConstraint"- where-#if !MIN_VERSION_ghc(9,2,0)-  go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do-#else-  go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do-#endif-    constraint <- liftParseAST df constraintT-#if !MIN_VERSION_ghc(9,2,0)-    setEntryDPT constraint (DP (0, 1))--    -- Paren annotations are usually attached to the first and last constraints,-    -- rather than to the constraint list itself, so to preserve them we need to reposition them-    closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt-    openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt-    ctxt' <- fixParens-                (join openParenDP) (join closeParenDP)-                (L l' ctxt)-    addTrailingCommaT (last ctxt')-    return $ L l $ it{hst_ctxt = L l' $ ctxt' ++ [constraint]}-#else-    constraint <- pure $ setEntryDP constraint (SameLine 1)-    let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'-    -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint-    -- we have to reposition it manually into the AnnContext-        close_dp = case ctxt of-            [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close-            _ -> Nothing-        ctxt' = over _last (first addComma) $ map dropHsParTy ctxt-    return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]}-#endif-  go (L _ HsForAllTy{hst_body}) = go hst_body-  go (L _ (HsParTy _ ty)) = go ty-  go ast@(L l _) = Rewrite (locA l) $ \df -> do-    -- there isn't a context, so we must create one-    constraint <- liftParseAST df constraintT-    lContext <- uniqueSrcSpanT-    lTop <- uniqueSrcSpanT-#if !MIN_VERSION_ghc(9,2,0)-    let context = L lContext [constraint]-    addSimpleAnnT context dp00 $-      (G AnnDarrow, DP (0, 1)) :-      concat-        [ [ (G AnnOpenP, dp00)-          , (G AnnCloseP, dp00)-          ]-        | hsTypeNeedsParens sigPrec $ unLoc constraint-        ]-#else-    let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]-        annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]-        needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint-    ast <- pure $ setEntryDP ast (SameLine 1)-#endif--    return $ reLocA $ L lTop $ HsQualTy noExtField context ast--liftParseAST-    :: forall ast l.  (ASTElement l ast, ExactPrint (LocatedAn l ast))-    => DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)-liftParseAST df s = case parseAST df "" s of-#if !MIN_VERSION_ghc(9,2,0)-  Right (anns, x) -> modifyAnnsT (anns <>) $> x-#else-  Right x ->  pure (makeDeltaAst x)-#endif-  Left _          -> lift $ Left $ "No parse: " <> s--#if !MIN_VERSION_ghc(9,2,0)-lookupAnn :: (Data a, Monad m)-          => KeywordId -> Located a -> TransformT m (Maybe DeltaPos)-lookupAnn comment la = do-  anns <- getAnnsT-  return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP--dp00 :: DeltaPos-dp00 = DP (0, 0)---- | Copy anns attached to a into b with modification, then delete anns of a-transferAnn :: (Data a, Data b) => Located a -> Located b -> (Annotation -> Annotation) -> TransformT (Either String) ()-transferAnn la lb f = do-  anns <- getAnnsT-  let oldKey = mkAnnKey la-      newKey = mkAnnKey lb-  oldValue <- liftMaybe "Unable to find ann" $ Map.lookup oldKey anns-  putAnnsT $ Map.delete oldKey $ Map.insert newKey (f oldValue) anns--#endif--headMaybe :: [a] -> Maybe a-headMaybe []      = Nothing-headMaybe (a : _) = Just a--lastMaybe :: [a] -> Maybe a-lastMaybe []    = Nothing-lastMaybe other = Just $ last other--liftMaybe :: String -> Maybe a -> TransformT (Either String) a-liftMaybe _ (Just x) = return x-liftMaybe s _        = lift $ Left s---------------------------------------------------------------------------------extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite-extendImport mparent identifier lDecl@(L l _) =-  Rewrite (locA l) $ \df -> do-    case mparent of-      -- This will also work for `ImportAllConstructors`-      Just parent -> extendImportViaParent df parent identifier lDecl-      _           -> extendImportTopLevel identifier lDecl---- | Add an identifier or a data type to import list. Expects a Delta AST------ extendImportTopLevel "foo" AST:------ import A --> Error--- import A (foo) --> Error--- import A (bar) --> import A (bar, foo)-extendImportTopLevel ::-  -- | rendered-  String ->-  LImportDecl GhcPs ->-  TransformT (Either String) (LImportDecl GhcPs)-extendImportTopLevel thing (L l it@ImportDecl{..})-  | Just (hide, L l' lies) <- ideclHiding-    , hasSibling <- not $ null lies = do-    src <- uniqueSrcSpanT-    top <- uniqueSrcSpanT-    let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing-    let alreadyImported =-          printOutputable (occName (unLoc rdr))-            `elem` map (printOutputable @OccName) (listify (const True) lies)-    when alreadyImported $-      lift (Left $ thing <> " already imported")--    let lie = reLocA $ L src $ IEName rdr-        x = reLocA $ L top $ IEVar noExtField lie--    if x `elem` lies-      then lift (Left $ thing <> " already imported")-      else do-#if !MIN_VERSION_ghc(9,2,0)-        when hasSibling $-          addTrailingCommaT (last lies)-        addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) []-        addSimpleAnnT rdr dp00 [(G AnnVal, dp00)]-        -- Parens are attachted to `lies`, so if `lies` was empty previously,-        -- we need change the ann key from `[]` to `:` to keep parens and other anns.-        unless hasSibling $-          transferAnn (L l' lies) (L l' [x]) id-        return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])}-#else-        lies' <- addCommaInImportList lies x-        return $ L l it{ideclHiding = Just (hide, L l' lies')}-#endif-extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"--wildCardSymbol :: String-wildCardSymbol = ".."---- | Add an identifier with its parent to import list------ extendImportViaParent "Bar" "Cons" AST:------ import A --> Error--- import A (Bar(..)) --> Error--- import A (Bar(Cons)) --> Error--- import A () --> import A (Bar(Cons))--- import A (Foo, Bar) --> import A (Foo, Bar(Cons))--- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))------ extendImportViaParent "Bar" ".." AST:--- import A () --> import A (Bar(..))--- import A (Foo, Bar) -> import A (Foo, Bar(..))--- import A (Foo, Bar()) -> import A (Foo, Bar(..))-extendImportViaParent ::-  DynFlags ->-  -- | parent (already parenthesized if needs)-  String ->-  -- | rendered child-  String ->-  LImportDecl GhcPs ->-  TransformT (Either String) (LImportDecl GhcPs)-extendImportViaParent df parent child (L l it@ImportDecl{..})-  | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies- where-  go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)-    | parent == unIEWrappedName ie = lift . Left $ child <> " already included in " <> parent <> " imports"-  go hide l' pre (lAbs@(L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)-    -- ThingAbs ie => ThingWith ie child-    | parent == unIEWrappedName ie = do-      srcChild <- uniqueSrcSpanT-      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-          childLIE = reLocA $ L srcChild $ IEName childRdr-#if !MIN_VERSION_ghc(9,2,0)-          x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] []-      -- take anns from ThingAbs, and attatch parens to it-      transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]}-      addSimpleAnnT childRdr dp00 [(G AnnVal, dp00)]-#else-          x :: LIE GhcPs = L ll' $ IEThingWith (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) absIE NoIEWildcard [childLIE]-#endif-      return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)}-#if !MIN_VERSION_ghc(9,2,0)-  go hide l' pre ((L l'' (IEThingWith _ twIE@(L _ ie) _ lies' _)) : xs)-#else-  go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs)-#endif-    -- ThingWith ie lies' => ThingWith ie (lies' ++ [child])-    | parent == unIEWrappedName ie-    , child == wildCardSymbol = do-#if MIN_VERSION_ghc(9,2,0)-        let it' = it{ideclHiding = Just (hide, lies)}-            thing = IEThingWith newl twIE (IEWildcard 2) []-            newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l'''-            lies = L l' $ reverse pre ++ [L l'' thing] ++ xs-        return $ L l it'-#else-        let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2)  [] [])-        modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann}))-        return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)}-#endif-    | parent == unIEWrappedName ie-    , hasSibling <- not $ null lies' =-      do-        srcChild <- uniqueSrcSpanT-        let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-#if MIN_VERSION_ghc(9,2,0)-        childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0-#endif-        let alreadyImported =-              printOutputable (occName (unLoc childRdr))-                `elem` map (printOutputable @OccName) (listify (const True) lies')-        when alreadyImported $-          lift (Left $ child <> " already included in " <> parent <> " imports")--        let childLIE = reLocA $ L srcChild $ IEName childRdr-#if !MIN_VERSION_ghc(9,2,0)-        when hasSibling $-          addTrailingCommaT (last lies')-        addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)]-        return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)}-#else-        let it' = it{ideclHiding = Just (hide, lies)}-            lies = L l' $ reverse pre ++-                [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs-            fixLast = if hasSibling then first addComma else id-        return $ L l it'-#endif-  go hide l' pre (x : xs) = go hide l' (x : pre) xs-  go hide l' pre []-    | hasSibling <- not $ null pre = do-      -- [] => ThingWith parent [child]-      l'' <- uniqueSrcSpanT-      srcParent <- uniqueSrcSpanT-      srcChild <- uniqueSrcSpanT-      parentRdr <- liftParseAST df parent-      let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child-          isParentOperator = hasParen parent-#if !MIN_VERSION_ghc(9,2,0)-      when hasSibling $-        addTrailingCommaT (head pre)-      let parentLIE = L srcParent (if isParentOperator then IEType parentRdr else IEName parentRdr)-          childLIE = reLocA $ L srcChild $ IEName childRdr-#else-      let parentLIE = reLocA $ L srcParent $ (if isParentOperator then IEType (epl 0) parentRdr' else IEName parentRdr')-          parentRdr' = modifyAnns parentRdr $ \case-              it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1}-              other -> other-          childLIE = reLocA $ L srcChild $ IEName childRdr-#endif-#if !MIN_VERSION_ghc(9,2,0)-          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] []-      -- Add AnnType for the parent if it's parenthesized (type operator)-      when isParentOperator $-        addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))]-      addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator-      addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)]-      addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))]-      -- Parens are attachted to `pre`, so if `pre` was empty previously,-      -- we need change the ann key from `[]` to `:` to keep parens and other anns.-      unless hasSibling $-        transferAnn (L l' $ reverse pre) (L l' [x]) id--      let lies' = reverse pre ++ [x]-#else-          listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]-          x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]--      let hasSibling = not (null pre)-      lies' <- addCommaInImportList (reverse pre) x-#endif-      return $ L l it{ideclHiding = Just (hide, L l' lies')}-extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent"--#if MIN_VERSION_ghc(9,2,0)--- Add an item in an import list, taking care of adding comma if needed.-addCommaInImportList :: Monad m =>-  -- | Initial list-  [LocatedAn AnnListItem a]-  -- | Additionnal item-  -> LocatedAn AnnListItem a-  -> m [LocatedAn AnnListItem a]-addCommaInImportList lies x = do-  let hasSibling = not (null lies)-  -- Add the space before the comma-  x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0)--  -- Add the comma (if needed)-  let-    fixLast = if hasSibling then first addComma else id-    lies' = over _last fixLast lies ++ [x]--  pure lies'-#endif--unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String-unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ)--hasParen :: String -> Bool-hasParen ('(' : _) = True-hasParen _         = False--#if !MIN_VERSION_ghc(9,2,0)-unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)]-unqalDP c paren =-  ( if paren-      then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)]-      else pure-  )-    (G AnnVal, dp00)-#endif------------------------------------------------------------------------------------ | Hide a symbol from import declaration-hideSymbol ::-  String -> LImportDecl GhcPs -> Rewrite-hideSymbol symbol lidecl@(L loc ImportDecl{..}) =-  case ideclHiding of-    Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing-    Just (True, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)-    Just (False, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports-hideSymbol _ (L _ (XImportDecl _)) =-  error "cannot happen"--extendHiding ::-  String ->-  LImportDecl GhcPs ->-#if !MIN_VERSION_ghc(9,2,0)-  Maybe (Located [LIE GhcPs]) ->-#else-  Maybe (XRec GhcPs [LIE GhcPs]) ->-#endif-  DynFlags ->-  TransformT (Either String) (LImportDecl GhcPs)-extendHiding symbol (L l idecls) mlies df = do-  L l' lies <- case mlies of-#if !MIN_VERSION_ghc(9,2,0)-    Nothing -> flip L [] <$> uniqueSrcSpanT-#else-    Nothing -> do-        src <- uniqueSrcSpanT-        let ann = noAnnSrcSpanDP0 src-            ann' = flip (fmap.fmap) ann $ \x -> x-                {al_rest = [AddEpAnn AnnHiding (epl 1)]-                ,al_open = Just $ AddEpAnn AnnOpenP (epl 1)-                ,al_close = Just $ AddEpAnn AnnCloseP (epl 0)-                }-        return $ L ann' []-#endif-    Just pr -> pure pr-  let hasSibling = not $ null lies-  src <- uniqueSrcSpanT-  top <- uniqueSrcSpanT-  rdr <- liftParseAST df symbol-#if MIN_VERSION_ghc(9,2,0)-  rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr)-#endif-  let lie = reLocA $ L src $ IEName rdr-      x = reLocA $ L top $ IEVar noExtField lie-#if MIN_VERSION_ghc(9,2,0)-  x <- pure $ if hasSibling then first addComma x else x-  lies <- pure $ over _head (`setEntryDP` SameLine 1) lies-#endif-#if !MIN_VERSION_ghc(9,2,0)-      singleHide = L l' [x]-  when (isNothing mlies) $ do-    addSimpleAnnT-      singleHide-      dp00-      [ (G AnnHiding, DP (0, 1))-      , (G AnnOpenP, DP (0, 1))-      , (G AnnCloseP, DP (0, 0))-      ]-  addSimpleAnnT x (DP (0, 0)) []-  addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr-  if hasSibling-    then do-      addTrailingCommaT x-      addSimpleAnnT (head lies) (DP (0, 1)) []-      unless (null $ tail lies) $-        addTrailingCommaT (head lies) -- Why we need this?-    else forM_ mlies $ \lies0 -> do-      transferAnn lies0 singleHide id-#endif-  return $ L l idecls{ideclHiding = Just (True, L l' $ x : lies)}- where-  isOperator = not . all isAlphaNum . occNameString . rdrNameOcc--deleteFromImport ::-  String ->-  LImportDecl GhcPs ->-#if !MIN_VERSION_ghc(9,2,0)-  Located [LIE GhcPs] ->-#else-  XRec GhcPs [LIE GhcPs] ->-#endif-  DynFlags ->-  TransformT (Either String) (LImportDecl GhcPs)-deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do-  let edited = L lieLoc deletedLies-      lidecl' =-        L l $-          idecl-            { ideclHiding = Just (False, edited)-            }-#if !MIN_VERSION_ghc(9,2,0)-  -- avoid import A (foo,)-  whenJust (lastMaybe deletedLies) removeTrailingCommaT-  when (not (null lies) && null deletedLies) $ do-    transferAnn llies edited id-    addSimpleAnnT-      edited-      dp00-      [ (G AnnOpenP, DP (0, 1))-      , (G AnnCloseP, DP (0, 0))-      ]-#endif-  pure lidecl'- where-  deletedLies =-#if MIN_VERSION_ghc(9,2,0)-    over _last removeTrailingComma $-#endif-    mapMaybe killLie lies-  killLie :: LIE GhcPs -> Maybe (LIE GhcPs)-  killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam))))-    | nam == symbol = Nothing-    | otherwise = Just v-  killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam))))-    | nam == symbol = Nothing-    | otherwise = Just v-#if !MIN_VERSION_ghc(9,2,0)-  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons flds))-#else-  killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons))-#endif-    | nam == symbol = Nothing-    | otherwise =-      Just $-        L lieL $-          IEThingWith-            xt-            ty-            wild-            (filter ((/= symbol) . unqualIEWrapName . unLoc) cons)-#if !MIN_VERSION_ghc(9,2,0)-            (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds)-#endif-  killLie v = Just v
− src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs 
@@ -1,141 +0,0 @@--- | Position indexed streams of characters-module Development.IDE.Plugin.CodeAction.PositionIndexed-  ( PositionIndexed-  , PositionIndexedString-  , indexedByPosition-  , indexedByPositionStartingFrom-  , extendAllToIncludeCommaIfPossible-  , extendToIncludePreviousNewlineIfPossible-  , mergeRanges-  )-where--import           Data.Char-import           Data.List-import           Language.LSP.Types (Position (Position),-                                     Range (Range, _end, _start))--type PositionIndexed a = [(Position, a)]--type PositionIndexedString = PositionIndexed Char---- | Add position indexing to a String.------   > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡---   >   [ ((0,0),'h')---   >   , ((0,1),'e')---   >   , ((0,2),'y')---   >   , ((0,3),'\n')---   >   , ((1,0),' ')---   >   , ((1,1),'h')---   >   , ((1,2),'o')---   >   ]-indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString-indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where-  f (_, []) = Nothing-  f (p@(Position l _), '\n' : rest) =-    Just ((p, '\n'), (Position (l + 1) 0, rest))-  f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))---- | Add position indexing to a String.------   > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)-indexedByPosition :: String -> PositionIndexedString-indexedByPosition = indexedByPositionStartingFrom (Position 0 0)---- | Returns a tuple (before, contents, after) if the range is present.---   The range is present only if both its start and end positions are present-unconsRange-  :: Range-  -> PositionIndexed a-  -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)-unconsRange Range {..} indexedString-  | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString-  , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest-  = Just (before, mid, after)-  | otherwise-  = Nothing---- | Strips out all the positions included in the range.---   Returns 'Nothing' if the start or end of the range are not included in the input.-stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)-stripRange r s = case unconsRange r s of-  Just (b, _, a) -> Just (b ++ a)-  Nothing        -> Nothing---- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.---   Assumes input ranges are sorted on the start positions.-mergeRanges :: [Range] -> [Range]-mergeRanges (r : r' : rest)-  |-    -- r' is contained in r-    _end r > _end r'   = mergeRanges (r : rest)-  |-    -- r and r' are overlapping-    _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)--  | otherwise          = r : mergeRanges (r' : rest)-mergeRanges other = other---- | Returns a sorted list of ranges with extended selections including preceding or trailing commas------ @---   a, |b|,  c  ===> a|, b|,  c---   a,  b,  |c| ===> a,  b|,  c|---   a, |b|, |c| ===> a|, b||, c|--- @------ If 'acceptNoComma' is enabled, additional ranges are returned------ @---   |a|       ===> |a|---   |a|,  |b| ===> |a,|  |b|--- @-extendAllToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> [Range] -> [Range]-extendAllToIncludeCommaIfPossible acceptNoComma indexedString =-  mergeRanges . go indexedString . sortOn _start- where-  go _ [] = []-  go input (r : rr)-    | r' : _ <- extendToIncludeCommaIfPossible acceptNoComma input r-    , Just input' <- stripRange r' input-    = r' : go input' rr-    | otherwise-    = go input rr--extendToIncludeCommaIfPossible :: Bool -> PositionIndexedString -> Range -> [Range]-extendToIncludeCommaIfPossible acceptNoComma indexedString range-  | Just (before, _, after) <- unconsRange range indexedString-  , after' <- dropWhile (isSpace . snd) after-  , before' <- dropWhile (isSpace . snd) (reverse before)-  =-    -- a, |b|, c ===> a|, b|, c-    [ range { _start = start' } | (start', ',') : _ <- [before'] ]-    ++-    -- a, |b|, c ===> a, |b, |c-    [ range { _end = end' }-    | (_, ',') : rest <- [after']-    , (end', _) : _ <- pure $ dropWhile (isSpace . snd) rest-    ]-    ++-    ([range | acceptNoComma])-  | otherwise-  = [range]--extendToIncludePreviousNewlineIfPossible :: PositionIndexedString -> Range -> Range-extendToIncludePreviousNewlineIfPossible indexedString range-  | Just (before, _, _) <- unconsRange range indexedString-  , maybeFirstSpacePos <- lastSpacePos $ reverse before-  = case maybeFirstSpacePos of-      Nothing  -> range-      Just pos -> range { _start = pos }-  | otherwise = range-  where-    lastSpacePos :: PositionIndexedString -> Maybe Position-    lastSpacePos [] = Nothing-    lastSpacePos ((pos, c):xs) =-      if not $ isSpace c-      then Nothing -- didn't find any space-      else case xs of-              (y:ys) | isSpace $ snd y -> lastSpacePos (y:ys)-              _                        -> Just pos
src/Development/IDE/Plugin/Completions.hs view
@@ -5,6 +5,7 @@ module Development.IDE.Plugin.Completions     ( descriptor     , Log(..)+    , ghcideCompletionsPluginPriority     ) where  import           Control.Concurrent.Async                     (concurrently)@@ -26,12 +27,8 @@ import qualified Development.IDE.Core.Shake                   as Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error                    (rangeToSrcSpan)-import           Development.IDE.GHC.ExactPrint               (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) import           Development.IDE.GHC.Util                     (printOutputable) import           Development.IDE.Graph-import           Development.IDE.Plugin.CodeAction            (newImport,-                                                               newImportToEdit)-import           Development.IDE.Plugin.CodeAction.ExactPrint import           Development.IDE.Plugin.Completions.Logic import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Types.Exports@@ -49,6 +46,7 @@ import qualified Language.LSP.Server                          as LSP import           Language.LSP.Types import qualified Language.LSP.VFS                             as VFS+import           Numeric.Natural import           Text.Fuzzy.Parallel                          (Scored (..))  data Log = LogShake Shake.Log deriving Show@@ -57,12 +55,15 @@   pretty = \case     LogShake log -> pretty log +ghcideCompletionsPluginPriority :: Natural+ghcideCompletionsPluginPriority = defaultPluginPriority+ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId)   { pluginRules = produceCompletions recorder   , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP-  , pluginCommands = [extendImportCommand]   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}+  , pluginPriority = ghcideCompletionsPluginPriority   }  produceCompletions :: Recorder (WithPriority Log) -> Rules ()@@ -149,8 +150,9 @@                 -> return (InL $ List [])               (Just pfix', _) -> do                 let clientCaps = clientCapabilities $ shakeExtras ide+                    plugins = idePlugins $ shakeExtras ide                 config <- getCompletionsConfig plId-                allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports+                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports                 pure $ InL (List $ orderedCompletions allCompletions)               _ -> return (InL $ List [])           _ -> return (InL $ List [])@@ -195,79 +197,3 @@ toModueNameText target = case target of   KT.TargetModule m -> T.pack $ moduleNameString m   _                 -> T.empty--extendImportCommand :: PluginCommand IdeState-extendImportCommand =-  PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler--extendImportHandler :: CommandFunction IdeState ExtendImport-extendImportHandler ideState edit@ExtendImport {..} = do-  res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit-  whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do-    let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList-        srcSpan = rangeToSrcSpan nfp _range-    LSP.sendNotification SWindowShowMessage $-      ShowMessageParams MtInfo $-        "Import "-          <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent-          <> "’ from "-          <> importName-          <> " (at "-          <> printOutputable srcSpan-          <> ")"-    void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())-  return $ Right Null--extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit)-extendImportHandler' ideState ExtendImport {..}-  | Just fp <- uriToFilePath doc,-    nfp <- toNormalizedFilePath' fp =-    do-      (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $-        runAction "extend import" ideState $-          runMaybeT $ do-            -- We want accurate edits, so do not use stale data here-            msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp-            ps <- MaybeT $ use GetAnnotatedParsedSource nfp-            (_, contents) <- MaybeT $ use GetFileContents nfp-            return (msr, ps, contents)-      let df = ms_hspp_opts msrModSummary-          wantedModule = mkModuleName (T.unpack importName)-          wantedQual = mkModuleName . T.unpack <$> importQual-          existingImport = find (isWantedModule wantedModule wantedQual) msrImports-      case existingImport of-        Just imp -> do-            fmap (nfp,) $ liftEither $-              rewriteToWEdit df doc-#if !MIN_VERSION_ghc(9,2,0)-                (annsA ps)-#endif-                $-                  extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp)-        Nothing -> do-            let n = newImport importName sym importQual False-                sym = if isNothing importQual then Just it else Nothing-                it = case thingParent of-                  Nothing -> newThing-                  Just p  -> p <> "(" <> newThing <> ")"-            t <- liftMaybe $ snd <$> newImportToEdit-                n-                (astA ps)-                (fromMaybe "" contents)-            return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing})-  | otherwise =-    mzero--isWantedModule :: ModuleName -> Maybe ModuleName -> GenLocated l (ImportDecl GhcPs) -> Bool-isWantedModule wantedModule Nothing (L _ it@ImportDecl{ideclName, ideclHiding = Just (False, _)}) =-    not (isQualifiedImport it) && unLoc ideclName == wantedModule-isWantedModule wantedModule (Just qual) (L _ ImportDecl{ideclAs, ideclName, ideclHiding = Just (False, _)}) =-    unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual)-isWantedModule _ _ _ = False--liftMaybe :: Monad m => Maybe a -> MaybeT m a-liftMaybe a = MaybeT $ pure a--liftEither :: Monad m => Either e a -> MaybeT m a-liftEither (Left _)  = mzero-liftEither (Right x) = return x
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -59,7 +59,7 @@ #endif import           Ide.PluginUtils                          (mkLspCommand) import           Ide.Types                                (CommandId (..),-                                                           PluginId)+                                                           IdePlugins(..), PluginId) import           Language.LSP.Types import           Language.LSP.Types.Capabilities import qualified Language.LSP.VFS                         as VFS@@ -161,7 +161,8 @@ showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString -mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem+mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command+        -> IdeOptions -> CompItem -> CompletionItem mkCompl   pId   IdeOptions {..}@@ -175,7 +176,7 @@       docs,       additionalTextEdits     } = do-  let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits+  let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits   let ci = CompletionItem                  {_label = label,                   _kind = kind,@@ -217,9 +218,9 @@             "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc)  -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command-mkAdditionalEditsCommand pId edits =-  mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])+mkAdditionalEditsCommand :: Maybe PluginId -> ExtendImport -> Maybe Command+mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits])+mkAdditionalEditsCommand _ _ = Nothing  mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..}@@ -462,11 +463,13 @@             ValD _ PatBind{pat_lhs} ->                 [mkComp id CiVariable Nothing                 | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]-            TyClD _ ClassDecl{tcdLName, tcdSigs} ->+            TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} ->                 mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) :                 [ mkComp id CiFunction (Just $ showForSnippet typ)                 | L _ (ClassOpSig _ _ ids typ) <- tcdSigs-                , id <- ids]+                , id <- ids] +++                [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName)+                | L _ (FamilyDecl{fdLName}) <- tcdATs]             TyClD _ x ->                 let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x)                         | id <- listify (\(_ :: LIdP GhcPs) -> True) x@@ -523,7 +526,11 @@             --             -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@             -- Hence, we must concat nested arguments into one to get all the fields.+#if MIN_VERSION_ghc(9,3,0)+            = map (foLabel . unLoc) cd_fld_names+#else             = map (rdrNameFieldOcc . unLoc) cd_fld_names+#endif         -- XConDeclField         extract _ = [] findRecordCompl _ _ _ _ = []@@ -551,7 +558,7 @@  -- | Returns the cached completions for the given module and position. getCompletions-    :: PluginId+    :: IdePlugins a     -> IdeOptions     -> CachedCompletions     -> Maybe (ParsedModule, PositionMapping)@@ -561,7 +568,7 @@     -> CompletionsConfig     -> HM.HashMap T.Text (HashSet.HashSet IdentInfo)     -> IO [Scored CompletionItem]-getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}+getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}                maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do   let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo       enteredQual = if T.null prefixModule then "" else prefixModule <> "."@@ -661,7 +668,8 @@     | otherwise -> do         -- assumes that nubOrdBy is stable         let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls-        let compls = (fmap.fmap.fmap) (mkCompl plId ideOpts) uniqueFiltCompls+        let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts) uniqueFiltCompls+            pId = lookupCommandProvider plugins (CommandId extendImportCommandId)         return $           (fmap.fmap) snd $           sortBy (compare `on` lexicographicOrdering) $
src/Development/IDE/Plugin/HLS.hs view
@@ -10,9 +10,9 @@     ) where  import           Control.Exception            (SomeException)+import           Control.Lens                 ((^.)) import           Control.Monad import qualified Data.Aeson                   as J-import           Data.Bifunctor import           Data.Dependent.Map           (DMap) import qualified Data.Dependent.Map           as DMap import           Data.Dependent.Sum@@ -21,6 +21,7 @@ import           Data.List.NonEmpty           (NonEmpty, nonEmpty, toList) import qualified Data.Map                     as Map import           Data.String+import           Data.Text                    (Text) import qualified Data.Text                    as T import           Development.IDE.Core.Shake   hiding (Log) import           Development.IDE.Core.Tracing@@ -33,9 +34,10 @@ import           Ide.PluginUtils              (getClientConfig) import           Ide.Types                    as HLS import qualified Language.LSP.Server          as LSP-import           Language.LSP.VFS import           Language.LSP.Types import qualified Language.LSP.Types           as J+import qualified Language.LSP.Types.Lens      as LSP+import           Language.LSP.VFS import           Text.Regex.TDFA.Text         () import           UnliftIO                     (MonadUnliftIO) import           UnliftIO.Async               (forConcurrently)@@ -44,28 +46,56 @@ -- --------------------------------------------------------------------- -- -data Log-  = LogNoEnabledPlugins-  deriving Show+data Log = LogPluginError ResponseError+    deriving Show  instance Pretty Log where   pretty = \case-    LogNoEnabledPlugins ->-      "extensibleNotificationPlugins no enabled plugins"+    LogPluginError err -> prettyResponseError err +-- various error message specific builders+prettyResponseError :: ResponseError -> Doc a+prettyResponseError err = errorCode <> ":" <+> errorBody+    where+        errorCode = pretty $ show $ err ^. LSP.code+        errorBody = pretty $ err ^. LSP.message++pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text+pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins)++pluginDoesntExist :: PluginId -> Text+pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"++commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text+commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are:\n" <> T.pack (unlines $ map (show . commandId) legalCmds)++failedToParseArgs :: CommandId  -- ^ command that failed to parse+                    -> PluginId -- ^ Plugin that created the command+                    -> String   -- ^ The JSON Error message+                    -> J.Value  -- ^ The Argument Values+                    -> Text+failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg)++-- | Build a ResponseError and log it before returning to the caller+logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a)+logAndReturnError recorder errCode msg = do+    let err = ResponseError errCode msg Nothing+    logWith recorder Warning $ LogPluginError err+    pure $ Left err+ -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) =     mkPlugin rulesPlugins HLS.pluginRules <>-    mkPlugin executeCommandPlugins HLS.pluginCommands <>-    mkPlugin extensiblePlugins HLS.pluginHandlers <>-    mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <>+    mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <>+    mkPlugin (extensiblePlugins recorder) id <>+    mkPlugin (extensibleNotificationPlugins recorder) id <>     mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags     where          mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config         mkPlugin maker selector =-          case map (second selector) ls of+          case map (\p -> (pluginId p, selector p)) ls of             -- If there are no plugins that provide a descriptor, use mempty to             -- create the plugin – otherwise we we end up declaring handlers for             -- capabilities that there are no plugins for@@ -91,13 +121,13 @@  -- --------------------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config-executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs }+executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config+executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)-executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd+executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)+executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd   where-    pluginMap = Map.fromList ecs+    pluginMap = Map.fromListWith (++) ecs      parseCmdId :: T.Text -> Maybe (PluginId, CommandId)     parseCmdId x = case T.splitOn ":" x of@@ -134,74 +164,73 @@         Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams          -- Couldn't parse the command identifier-        _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing+        _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier" -    runPluginCommand ide p@(PluginId p') com@(CommandId com') arg =+    runPluginCommand ide p com arg =       case Map.lookup p pluginMap  of-        Nothing -> return-          (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing)+        Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p)         Just xs -> case List.find ((com ==) . commandId) xs of-          Nothing -> return $ Left $-            ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'-                                          <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing+          Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs)           Just (PluginCommand _ _ f) -> case J.fromJSON arg of-            J.Error err -> return $ Left $-              ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'-                                           <> ": " <> T.pack err-                                           <> "\narg = " <> T.pack (show arg)) Nothing+            J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg)             J.Success a -> f ide a  -- --------------------------------------------------------------------- -extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config-extensiblePlugins xs = mempty { P.pluginHandlers = handlers }+extensiblePlugins ::  Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config+extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }   where     IdeHandlers handlers' = foldMap bakePluginId xs-    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers-    bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map-      (\(PluginHandler f) -> IdeHandler [(pid,f pid)])+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers+    bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map+      (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)])       hs+      where+        PluginHandlers hs = HLS.pluginHandlers pluginDesc     handlers = mconcat $ do       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'       pure $ requestHandler m $ \ide params -> do         config <- Ide.PluginUtils.getClientConfig-        let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs'+        -- Only run plugins that are allowed to run on this request+        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'+        -- Clients generally don't display ResponseErrors so instead we log any that we come across         case nonEmpty fs of-          Nothing -> pure $ Left $ ResponseError InvalidRequest-            ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))-            Nothing+          Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')           Just fs -> do-            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)-            es <- runConcurrently msg (show m) fs ide params+            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e)+                handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs+            es <- runConcurrently msg (show m) handlers ide params             let (errs,succs) = partitionEithers $ toList es+            unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err             case nonEmpty succs of               Nothing -> pure $ Left $ combineErrors errs               Just xs -> do                 caps <- LSP.getClientCapabilities                 pure $ Right $ combineResponses m config caps params xs+ -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config+extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers }   where     IdeNotificationHandlers handlers' = foldMap bakePluginId xs-    bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers-    bakePluginId (pid,PluginNotificationHandlers hs) = IdeNotificationHandlers $ DMap.map-      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,f pid)])+    bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeNotificationHandlers+    bakePluginId (pid,pluginDesc) = IdeNotificationHandlers $ DMap.map+      (\(PluginNotificationHandler f) -> IdeNotificationHandler [(pid,pluginDesc,f pid)])       hs+      where PluginNotificationHandlers hs = HLS.pluginNotificationHandlers pluginDesc     handlers = mconcat $ do       (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers'       pure $ notificationHandler m $ \ide vfs params -> do         config <- Ide.PluginUtils.getClientConfig-        let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs'+        -- Only run plugins that are allowed to run on this request+        let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'         case nonEmpty fs of-          Nothing -> do-              logWith recorder Info LogNoEnabledPlugins-              pure ()+          Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs')           Just fs -> do             -- We run the notifications in order, so the core ghcide provider             -- (which restarts the shake process) hopefully comes last-              mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs+            mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs  -- --------------------------------------------------------------------- @@ -210,12 +239,13 @@   => (SomeException -> PluginId -> T.Text)   -> String -- ^ label   -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))+  -- ^ Enabled plugin actions that we are allowed to run   -> a   -> b   -> m (NonEmpty (Either ResponseError d)) runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do   f a b-    `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)+     `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)  combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x@@ -223,11 +253,11 @@  -- | Combine the 'PluginHandler' for all plugins newtype IdeHandler (m :: J.Method FromClient Request)-  = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]  -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: J.Method FromClient Notification)-  = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]+  = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`  -- | Combine the 'PluginHandlers' for all plugins
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -12,7 +12,6 @@ import           Development.IDE.LSP.HoverDefinition import qualified Development.IDE.LSP.Notifications   as Notifications import           Development.IDE.LSP.Outline-import qualified Development.IDE.Plugin.CodeAction   as CodeAction import qualified Development.IDE.Plugin.Completions  as Completions import qualified Development.IDE.Plugin.TypeLenses   as TypeLenses import           Ide.Types@@ -35,10 +34,6 @@ descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder =   [ descriptor "ghcide-hover-and-symbols",-    CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports",-    CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures",-    CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings",-    CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes",     Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions",     TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses",     Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"@@ -49,7 +44,16 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)   { pluginHandlers = mkPluginHandler STextDocumentHover hover'-                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider,+                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider+                  <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} ->+                      gotoDefinition ide TextDocumentPositionParams{..})+                  <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->+                      gotoTypeDefinition ide TextDocumentPositionParams{..})+                  <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->+                      documentHighlight ide TextDocumentPositionParams{..})+                  <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params)+                  <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params),+     pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}   }
src/Development/IDE/Plugin/Test.hs view
@@ -25,10 +25,9 @@ import           Data.String import           Data.Text                            (Text, pack) import           Development.IDE.Core.OfInterest      (getFilesOfInterest)+import           Development.IDE.Core.Rules import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service import           Development.IDE.Core.Shake-import           Development.IDE.Core.Rules import           Development.IDE.GHC.Compat import           Development.IDE.Graph                (Action) import qualified Development.IDE.Graph                as Graph
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -29,9 +29,9 @@                                                       RuleResult, Rules, define,                                                       srcSpanToRange) import           Development.IDE.Core.Compile        (TcModuleResult (..))+import           Development.IDE.Core.Rules          (IdeState, runAction) import           Development.IDE.Core.RuleTypes      (GetBindings (GetBindings),                                                       TypeCheck (TypeCheck))-import           Development.IDE.Core.Rules          (IdeState, runAction) import           Development.IDE.Core.Service        (getDiagnostics) import           Development.IDE.Core.Shake          (getHiddenDiagnostics, use) import qualified Development.IDE.Core.Shake          as Shake
src/Development/IDE/Spans/AtPoint.hs view
@@ -32,9 +32,9 @@ import           Development.IDE.Core.RuleTypes import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util      as Util+import           Development.IDE.GHC.Util             (printOutputable) import           Development.IDE.Spans.Common import           Development.IDE.Types.Options-import           Development.IDE.GHC.Util             (printOutputable)  import           Control.Applicative import           Control.Monad.Extra@@ -231,11 +231,14 @@         prettyNames = map prettyName names         prettyName (Right n, dets) = T.unlines $           wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))-          : definedAt n-          ++ maybeToList (prettyPackageName n)+          : maybeToList (pretty (definedAt n) (prettyPackageName n))           ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n                        ]           where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n+                pretty Nothing Nothing = Nothing+                pretty (Just define) Nothing = Just $ define <> "\n"+                pretty Nothing (Just pkgName) = Just $ pkgName <> "\n"+                pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n"         prettyName (Left m,_) = printOutputable m          prettyPackageName n = do@@ -244,7 +247,7 @@           conf <- lookupUnit env pid           let pkgName = T.pack $ unitPackageNameString conf               version = T.pack $ showVersion (unitPackageVersion conf)-          pure $ " *(" <> pkgName <> "-" <> version <> ")*"+          pure $ "*(" <> pkgName <> "-" <> version <> ")*"          prettyTypes = map (("_ :: "<>) . prettyType) types         prettyType t = case kind of@@ -255,8 +258,8 @@           -- do not show "at <no location info>" and similar messages           -- see the code of 'pprNameDefnLoc' for more information           case nameSrcLoc name of-            UnhelpfulLoc {} | isInternalName name || isSystemName name -> []-            _ -> ["*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"]+            UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing+            _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"  typeLocationsAtPoint   :: forall m
src/Development/IDE/Spans/Common.hs view
@@ -50,10 +50,12 @@  -- Possible documentation for an element in the code data SpanDoc+#if MIN_VERSION_ghc(9,3,0)+  = SpanDocString [HsDocString] SpanDocUris+#else   = SpanDocString HsDocString SpanDocUris-    -- ^ Extern module doc+#endif   | SpanDocText   [T.Text] SpanDocUris-    -- ^ Local module doc   deriving stock (Eq, Show, Generic)   deriving anyclass NFData @@ -80,10 +82,20 @@ -- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc. -- Therefore we check every item in the value to make sure they all end with '\\n', -- this makes "xxxx\n---\nyyy\n" and can be rendered correctly.+--+-- Notes:+--+-- To insert a new line in Markdown, we need two '\\n', like ("\\n\\n"), __or__ a section+-- symbol with one '\\n', like ("***\\n"). spanDocToMarkdown :: SpanDoc -> [T.Text] spanDocToMarkdown = \case     (SpanDocString docs uris) ->-        let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs+        let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $+#if MIN_VERSION_ghc(9,3,0)+                      renderHsDocStrings docs+#else+                      unpackHDS docs+#endif         in  go [doc] uris     (SpanDocText txt uris) -> go txt uris   where
src/Development/IDE/Spans/Documentation.hs view
@@ -33,6 +33,9 @@ import           System.FilePath  import           Language.LSP.Types              (filePathToUri, getUri)+#if MIN_VERSION_ghc(9,3,0)+import GHC.Types.Unique.Map+#endif  mkDocMap   :: HscEnv@@ -41,12 +44,18 @@   -> IO DocAndKindMap mkDocMap env rm this_mod =   do-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,3,0)+     (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod+#elif MIN_VERSION_ghc(9,2,0)      (_ , DeclDocMap this_docs, _) <- extractDocs this_mod #else      let (_ , DeclDocMap this_docs, _) = extractDocs this_mod #endif+#if MIN_VERSION_ghc(9,3,0)+     d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names+#else      d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names+#endif      k <- foldrM getType (tcg_type_env this_mod) names      pure $ DKMap d k   where@@ -69,7 +78,7 @@     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod  getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc-getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n]+getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n]  getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env mod names = do@@ -78,7 +87,11 @@       Left _    -> return []       Right res -> zipWithM unwrap res names   where+#if MIN_VERSION_ghc(9,3,0)+    unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n+#else     unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n+#endif     unwrap _ n                      = mkSpanDocText n      mkSpanDocText name =
src/Development/IDE/Types/Action.hs view
@@ -11,9 +11,9 @@ where  import           Control.Concurrent.STM+import           Data.Hashable                (Hashable (..)) import           Data.HashSet                 (HashSet) import qualified Data.HashSet                 as Set-import           Data.Hashable                (Hashable (..)) import           Data.Unique                  (Unique) import           Development.IDE.Graph        (Action) import           Development.IDE.Types.Logger
src/Development/IDE/Types/Exports.hs view
@@ -17,12 +17,12 @@ import           Control.DeepSeq             (NFData (..)) import           Control.Monad import           Data.Bifunctor              (Bifunctor (second))+import           Data.Hashable               (Hashable) import           Data.HashMap.Strict         (HashMap, elems) import qualified Data.HashMap.Strict         as Map import           Data.HashSet                (HashSet) import qualified Data.HashSet                as Set-import           Data.Hashable               (Hashable)-import           Data.List                   (isSuffixOf, foldl')+import           Data.List                   (foldl', isSuffixOf) import           Data.Text                   (Text, pack) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Orphans ()
src/Development/IDE/Types/KnownTargets.hs view
@@ -3,11 +3,11 @@ module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where  import           Control.DeepSeq+import           Data.Hashable import           Data.HashMap.Strict import qualified Data.HashMap.Strict            as HMap import           Data.HashSet import qualified Data.HashSet                   as HSet-import           Data.Hashable import           Development.IDE.GHC.Compat     (ModuleName) import           Development.IDE.GHC.Orphans    () import           Development.IDE.Types.Location
src/Development/IDE/Types/Location.hs view
@@ -50,11 +50,7 @@ toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp  emptyFilePath :: LSP.NormalizedFilePath-#if MIN_VERSION_lsp_types(1,3,0)-emptyFilePath = LSP.normalizedFilePath emptyPathUri ""-#else-emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""-#endif+emptyFilePath = LSP.emptyNormalizedFilePath  -- | We use an empty string as a filepath when we don’t have a file. -- However, haskell-lsp doesn’t support that in uriToFilePath and given
src/Development/IDE/Types/Logger.hs view
@@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP        #-} {-# LANGUAGE RankNTypes #-} -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever@@ -26,45 +27,64 @@   , lspClientLogRecorder   , module PrettyPrinterModule   , renderStrict+  , toCologActionWithPrio   ) where -import           Control.Concurrent            (myThreadId)-import           Control.Concurrent.Extra      (Lock, newLock, withLock)-import           Control.Concurrent.STM        (atomically,-                                                newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue)-import           Control.Exception             (IOException)-import           Control.Monad                 (forM_, when, (>=>), unless)-import           Control.Monad.IO.Class        (MonadIO (liftIO))-import           Data.Foldable                 (for_)-import           Data.Functor.Contravariant    (Contravariant (contramap))-import           Data.Maybe                    (fromMaybe)-import           Data.Text                     (Text)-import qualified Data.Text                     as T-import qualified Data.Text                     as Text-import qualified Data.Text.IO                  as Text-import           Data.Time                     (defaultTimeLocale, formatTime,-                                                getCurrentTime)-import           GHC.Stack                     (CallStack, HasCallStack,-                                                SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),-                                                callStack, getCallStack,-                                                withFrozenCallStack)+import           Control.Concurrent                    (myThreadId)+import           Control.Concurrent.Extra              (Lock, newLock, withLock)+import           Control.Concurrent.STM                (atomically,+                                                        flushTBQueue,+                                                        isFullTBQueue,+                                                        newTBQueueIO, newTVarIO,+                                                        readTVarIO,+                                                        writeTBQueue, writeTVar)+import           Control.Exception                     (IOException)+import           Control.Monad                         (forM_, unless, when,+                                                        (>=>))+import           Control.Monad.IO.Class                (MonadIO (liftIO))+import           Data.Foldable                         (for_)+import           Data.Functor.Contravariant            (Contravariant (contramap))+import           Data.Maybe                            (fromMaybe)+import           Data.Text                             (Text)+import qualified Data.Text                             as T+import qualified Data.Text                             as Text+import qualified Data.Text.IO                          as Text+import           Data.Time                             (defaultTimeLocale,+                                                        formatTime,+                                                        getCurrentTime)+import           GHC.Stack                             (CallStack, HasCallStack,+                                                        SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),+                                                        callStack, getCallStack,+                                                        withFrozenCallStack) import           Language.LSP.Server-import qualified Language.LSP.Server           as LSP-import           Language.LSP.Types            (LogMessageParams (..),-                                                MessageType (..),-                                                SMethod (SWindowLogMessage, SWindowShowMessage),-                                                ShowMessageParams (..))-import           Prettyprinter                 as PrettyPrinterModule-import           Prettyprinter.Render.Text     (renderStrict)-import           System.IO                     (Handle, IOMode (AppendMode),-                                                hClose, hFlush, hSetEncoding,-                                                openFile, stderr, utf8)-import qualified System.Log.Formatter          as HSL-import qualified System.Log.Handler            as HSL-import qualified System.Log.Handler.Simple     as HSL-import qualified System.Log.Logger             as HsLogger-import           UnliftIO                      (MonadUnliftIO, displayException,-                                                finally, try)+import qualified Language.LSP.Server                   as LSP+import           Language.LSP.Types                    (LogMessageParams (..),+                                                        MessageType (..),+                                                        SMethod (SWindowLogMessage, SWindowShowMessage),+                                                        ShowMessageParams (..))+#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter                         as PrettyPrinterModule+import           Prettyprinter.Render.Text             (renderStrict)+#else+import           Data.Text.Prettyprint.Doc             as PrettyPrinterModule+import           Data.Text.Prettyprint.Doc.Render.Text (renderStrict)+#endif+import           Colog.Core                            (LogAction (..),+                                                        Severity,+                                                        WithSeverity (..))+import qualified Colog.Core                            as Colog+import           System.IO                             (Handle,+                                                        IOMode (AppendMode),+                                                        hClose, hFlush,+                                                        hSetEncoding, openFile,+                                                        stderr, utf8)+import qualified System.Log.Formatter                  as HSL+import qualified System.Log.Handler                    as HSL+import qualified System.Log.Handler.Simple             as HSL+import qualified System.Log.Logger                     as HsLogger+import           UnliftIO                              (MonadUnliftIO,+                                                        displayException,+                                                        finally, try)  data Priority -- Don't change the ordering of this type or you will mess up the Ord@@ -360,3 +380,14 @@     Info    -> MtInfo     Warning -> MtWarning     Error   -> MtError++toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)+toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do+    let priority = severityToPriority getSeverity+    _logger $ WithPriority priority callStack getMsg+  where+    severityToPriority :: Severity -> Priority+    severityToPriority Colog.Debug   = Debug+    severityToPriority Colog.Info    = Info+    severityToPriority Colog.Warning = Warning+    severityToPriority Colog.Error   = Error
+ src/Development/IDE/Types/Monitoring.hs view
@@ -0,0 +1,32 @@+module Development.IDE.Types.Monitoring+(Monitoring(..)+) where++import           Data.Int+import           Data.Text (Text)++-- | An abstraction for runtime monitoring inspired by the 'ekg' package+data Monitoring = Monitoring {+    -- | Register an integer-valued metric.+    registerGauge   :: Text -> IO Int64 -> IO (),+    -- | Register a non-negative, monotonically increasing, integer-valued metric.+    registerCounter :: Text -> IO Int64 -> IO (),+    start           :: IO (IO ()) -- ^ Start the monitoring system, returning an action which will stop the system.+  }++instance Semigroup Monitoring where+    a <> b = Monitoring {+        registerGauge   = \n v -> registerGauge a n v >> registerGauge b n v,+        registerCounter = \n v -> registerCounter a n v >> registerCounter b n v,+        start = do+            a' <- start a+            b' <- start b+            return $ a' >> b'+      }++instance Monoid Monitoring where+    mempty = Monitoring {+        registerGauge   = \_ _ -> return (),+        registerCounter = \_ _ -> return (),+        start = return $ return ()+      }
src/Development/IDE/Types/Options.hs view
@@ -83,6 +83,8 @@   , optProgressStyle      :: ProgressReportingStyle   , optRunSubset          :: Bool       -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed+  , optVerifyCoreFile     :: Bool+    -- ^ Verify core files after serialization   }  data OptHaddockParse = HaddockParse | NoHaddockParse@@ -135,6 +137,7 @@     ,optSkipProgress = defaultSkipProgress     ,optProgressStyle = Explicit     ,optRunSubset = True+    ,optVerifyCoreFile = False     ,optMaxDirtyAge = 100     }
src/Development/IDE/Types/Shake.hs view
@@ -25,6 +25,7 @@ import           Data.Typeable                        (cast) import           Data.Vector                          (Vector) import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.RuleTypes       (FileVersion) import           Development.IDE.Graph                (Key (..), RuleResult) import qualified Development.IDE.Graph                as Shake import           Development.IDE.Types.Diagnostics@@ -37,7 +38,6 @@                                                        typeOf, typeRep,                                                        typeRepTyCon) import           Unsafe.Coerce                        (unsafeCoerce)-import Development.IDE.Core.RuleTypes (FileVersion)  -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality
src/Text/Fuzzy/Parallel.hs view
@@ -7,12 +7,12 @@     Scored(..) ) where -import           Control.Parallel.Strategies (rseq, using, parList, evalList)+import           Control.Parallel.Strategies (evalList, parList, rseq, using) import           Data.Bits                   ((.|.)) import           Data.Maybe                  (fromMaybe, mapMaybe) import qualified Data.Text                   as T-import qualified Data.Text.Internal          as T import qualified Data.Text.Array             as TA+import qualified Data.Text.Internal          as T import           Prelude                     hiding (filter)  data Scored a = Scored {score :: !Int, original:: !a}
+ test/data/THCoreFile/THA.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+module THA where+import Language.Haskell.TH+import Control.Monad (when)++th_a :: DecsQ+th_a = do+  when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error"+  when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error"+  when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error"+  when (show (classMethod 'z') /= "True") $ error "TH validation error"+  when (show (classMethod 'a') /= "False") $ error "TH validation error"+  [d| a = () |]++data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show+data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show+data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show++class SingleMethodClass a where+  classMethod :: a -> Bool++instance SingleMethodClass Char where+  classMethod = (== 'z')
+ test/data/THCoreFile/THB.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}+module THB where+import THA+import Control.Monad (when)++$(do+  -- Need to verify in both defining module and usage module"+  when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error"+  when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error"+  when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error"+  when (show (classMethod 'z') /= "True") $ error "TH validation error"+  when (show (classMethod 'a') /= "False") $ error "TH validation error"+  th_a)
+ test/data/THCoreFile/THC.hs view
@@ -0,0 +1,5 @@+module THC where+import THB++c ::()+c = a
+ test/data/THCoreFile/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}}
test/data/THUnboxed/THA.hs view
@@ -1,9 +1,16 @@-{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}+{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} module THA where import Language.Haskell.TH -f :: Int -> (# Int, Int #)-f x = (# x , x+1 #)+data Foo = Foo !Int !Char !String+  deriving Show +newtype Bar = Bar Int+  deriving Show+++f :: Int -> (# Int, Int, Foo, Bar#)+f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #)+ th_a :: DecsQ-th_a = case f 1 of (# a , b #) -> [d| a = () |]+th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |]
− test/data/hiding/AVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module AVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/BVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module BVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/CVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module CVec (Vec, type (@@@), (++), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/DVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module DVec (Vec, (++), type (@@@), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/EVec.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module EVec (Vec, (++), type (@@@), cons, fromList, snoc) where--import Prelude hiding ((++))--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined--data (@@@) a b--fromList :: [a] -> Vec a-fromList = undefined--cons :: a -> Vec a -> Vec a-cons = undefined--snoc :: Vec a -> a -> Vec a-snoc = undefined
− test/data/hiding/FVec.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}--module FVec (RecA(..), RecB(..)) where--data Vec a--newtype RecA a = RecA { fromList :: [a] -> Vec a }--newtype RecB a = RecB { fromList :: [a] -> Vec a }
− test/data/hiding/HideFunction.expected.append.E.hs 
@@ -1,12 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E-import Prelude hiding ((++))--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.append.Prelude.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E hiding ((++))--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.fromList.A.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec ( (++))-import CVec hiding (fromList, cons)-import DVec hiding (fromList, cons, snoc)-import EVec as E hiding (fromList)--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.fromList.B.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec ()-import BVec (fromList, (++))-import CVec hiding (fromList, cons)-import DVec hiding (fromList, cons, snoc)-import EVec as E hiding (fromList)--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunction.expected.qualified.append.Prelude.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = fromList--theOp = (Prelude.++)
− test/data/hiding/HideFunction.expected.qualified.fromList.E.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = E.fromList--theOp = (++)
− test/data/hiding/HideFunction.hs 
@@ -1,11 +0,0 @@-module HideFunction where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theFun = fromList--theOp = (++)
− test/data/hiding/HideFunctionWithoutLocal.expected.hs 
@@ -1,14 +0,0 @@-module HideFunctionWithoutLocal where--import AVec (fromList)-import BVec (fromList)-import CVec hiding ((++), cons)-import DVec hiding ((++), cons, snoc)-import EVec as E hiding ((++))-import Prelude hiding ((++))--theOp = (++)--data Vec a--(++) = undefined
− test/data/hiding/HideFunctionWithoutLocal.hs 
@@ -1,13 +0,0 @@-module HideFunctionWithoutLocal where--import AVec (fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--theOp = (++)--data Vec a--(++) = undefined
− test/data/hiding/HidePreludeIndented.expected.hs 
@@ -1,5 +0,0 @@-module HidePreludeIndented where--   import AVec-   import Prelude hiding ((++))-   op = (++)
− test/data/hiding/HidePreludeIndented.hs 
@@ -1,4 +0,0 @@-module HidePreludeIndented where--   import AVec-   op = (++)
− test/data/hiding/HidePreludeLocalInfix.expected.hs 
@@ -1,9 +0,0 @@-module HidePreludeLocalInfix where-import Prelude hiding ((++))--infixed xs ys = xs ++ ys--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined
− test/data/hiding/HidePreludeLocalInfix.hs 
@@ -1,8 +0,0 @@-module HidePreludeLocalInfix where--infixed xs ys = xs ++ ys--data Vec a--(++) :: Vec a -> Vec a -> Vec a-(++) = undefined
− test/data/hiding/HideQualifyDuplicateRecordFields.expected.hs 
@@ -1,10 +0,0 @@-module HideQualifyDuplicateRecordFields where--import AVec-import BVec-import CVec-import DVec-import EVec-import FVec--theFun = AVec.fromList
− test/data/hiding/HideQualifyDuplicateRecordFields.hs 
@@ -1,10 +0,0 @@-module HideQualifyDuplicateRecordFields where--import AVec-import BVec-import CVec-import DVec-import EVec-import FVec--theFun = fromList
− test/data/hiding/HideQualifyDuplicateRecordFieldsSelf.hs 
@@ -1,5 +0,0 @@-module HideQualifyDuplicateRecordFieldsSelf where--import FVec--x = fromList
− test/data/hiding/HideQualifyInfix.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifyInfix where--import AVec--infixed xs ys = xs Prelude.++ ys
− test/data/hiding/HideQualifyInfix.hs 
@@ -1,5 +0,0 @@-module HideQualifyInfix where--import AVec--infixed xs ys = xs ++ ys
− test/data/hiding/HideQualifySectionLeft.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionLeft where--import AVec--sectLeft xs = (Prelude.++ xs)
− test/data/hiding/HideQualifySectionLeft.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionLeft where--import AVec--sectLeft xs = (++ xs)
− test/data/hiding/HideQualifySectionRight.expected.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionRight where--import AVec--sectLeft xs = (xs Prelude.++)
− test/data/hiding/HideQualifySectionRight.hs 
@@ -1,5 +0,0 @@-module HideQualifySectionRight where--import AVec--sectLeft xs = (xs ++)
− test/data/hiding/HideType.expected.A.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec (Vec, fromList)-import BVec (fromList, (++))-import CVec hiding (Vec, cons)-import DVec hiding (Vec, cons, snoc)-import EVec as E hiding (Vec)--type TheType = Vec
− test/data/hiding/HideType.expected.E.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec ( fromList)-import BVec (fromList, (++))-import CVec hiding (Vec, cons)-import DVec hiding (Vec, cons, snoc)-import EVec as E--type TheType = Vec
− test/data/hiding/HideType.hs 
@@ -1,9 +0,0 @@-module HideType where--import AVec (Vec, fromList)-import BVec (fromList, (++))-import CVec hiding (cons)-import DVec hiding (cons, snoc)-import EVec as E--type TheType = Vec
− test/data/hiding/hie.yaml 
@@ -1,10 +0,0 @@-cradle:-    direct:-        arguments:-        - -Wall-        - HideFunction.hs-        - AVec.hs-        - BVec.hs-        - CVec.hs-        - DVec.hs-        - EVec.hs
+ test/data/hover/RecordDotSyntax.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-}++module RecordDotSyntax ( module RecordDotSyntax) where++import qualified Data.Maybe as M++data MyRecord = MyRecord+  { a :: String+  , b :: Integer+  , c :: MyChild+  } deriving (Eq, Show)++newtype MyChild = MyChild+  { z :: String+  } deriving (Eq, Show)++x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } }+y = x.a ++ show x.b ++ x.c.z+#endif
test/data/hover/hie.yaml view
@@ -1,1 +1,1 @@-cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover"]}}+cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}}
− test/data/import-placement/CommentAtTop.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTop.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTopMultipleComments.expected.hs 
@@ -1,12 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- | Another comment-data SomethingElse = SomethingElse---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentAtTopMultipleComments.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where---- | Another comment-data SomethingElse = SomethingElse---- | Some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentCurlyBraceAtTop.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--{- Some comment -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/CommentCurlyBraceAtTop.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where--{- Some comment -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/DataAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--data Something = Something---- | some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/DataAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--data Something = Something---- | some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ImportAtTop.expected.hs 
@@ -1,14 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Monoid--{- Some multi -   line comment --}-class Semigroup a => SomeData a---- | a comment-instance SomeData All
− test/data/import-placement/ImportAtTop.hs 
@@ -1,13 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char--{- Some multi -   line comment --}-class Semigroup a => SomeData a---- | a comment-instance SomeData All
− test/data/import-placement/LangPragmaModuleAtTop.expected.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleAtTop.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleExplicitExports.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleExplicitExports.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleWithComment.expected.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where-import Data.Monoid---- comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LangPragmaModuleWithComment.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test-( SomeData(..)-) where---- comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTop.expected.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTop.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTopWithComment.expected.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid---- | comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmaAtTopWithComment.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmasThenShebangs.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/LanguagePragmasThenShebangs.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ModuleDeclAndImports.expected.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Char-import Data.Array-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ModuleDeclAndImports.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Char-import Data.Array--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLineCommentAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--{- Some multi -   line comment --}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLineCommentAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--{- Some multi -   line comment --}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLinePragma.expected.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards, -   OverloadedStrings #-}-{-# OPTIONS_GHC -Wall,-  -Wno-unused-imports #-}-import Data.Monoid----- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultiLinePragma.hs 
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards, -   OverloadedStrings #-}-{-# OPTIONS_GHC -Wall,-  -Wno-unused-imports #-}----- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultipleImportsAtTop.expected.hs 
@@ -1,14 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Bool-import Data.Eq-import Data.Monoid---- | A comment-class Semigroup a => SomeData a---- | another comment-instance SomeData All
− test/data/import-placement/MultipleImportsAtTop.hs 
@@ -1,13 +0,0 @@-module Test-( SomeData(..)-) where--import Data.Char-import Data.Bool-import Data.Eq---- | A comment-class Semigroup a => SomeData a---- | another comment-instance SomeData All
− test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.expected.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}-import Data.Monoid---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/MultipleLanguagePragmasNoModuleDeclaration.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}---- some comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NewTypeAtTop.expected.hs 
@@ -1,11 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid--newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NewTypeAtTop.hs 
@@ -1,10 +0,0 @@-module Test-( SomeData(..)-) where--newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExportCommentAtTop.expected.hs 
@@ -1,7 +0,0 @@-module Test where-import Data.Monoid---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExportCommentAtTop.hs 
@@ -1,6 +0,0 @@-module Test where---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExports.expected.hs 
@@ -1,8 +0,0 @@-module Test where-import Data.Monoid--newtype Something = S { foo :: Int }--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoExplicitExports.hs 
@@ -1,7 +0,0 @@-module Test where--newtype Something = S { foo :: Int }--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclaration.expected.hs 
@@ -1,7 +0,0 @@-import Data.Monoid-newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclaration.hs 
@@ -1,6 +0,0 @@-newtype Something = S { foo :: Int }---- | a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclarationCommentAtTop.expected.hs 
@@ -1,5 +0,0 @@-import Data.Monoid--- a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/NoModuleDeclarationCommentAtTop.hs 
@@ -1,4 +0,0 @@--- a comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# LANGUAGE TupleSections #-}-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsNotAtTopWithSpaces.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# LANGUAGE TupleSections #-}-----class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsPragmaNotAtTop.expected.hs 
@@ -1,8 +0,0 @@-import Data.Monoid-class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/OptionsPragmaNotAtTop.hs 
@@ -1,7 +0,0 @@-class Semigroup a => SomeData a-instance SomeData All--{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall,-   OPTIONS_GHC -Wno-unrecognised-pragmas #-}--- another comment--- oh-{- multi line -comment--}--{-# LANGUAGE TupleSections #-}-import Data.Monoid-{- some comment -}---- again-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopMultipleComments.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall,-   OPTIONS_GHC -Wno-unrecognised-pragmas #-}--- another comment--- oh-{- multi line -comment--}--{-# LANGUAGE TupleSections #-}-{- some comment -}---- again-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall #-}--- another comment--{-# LANGUAGE TupleSections #-}-import Data.Monoid-{- some comment -}---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -Wall #-}--- another comment--{-# LANGUAGE TupleSections #-}-{- some comment -}---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithImports.expected.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Text-import Data.Monoid---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithImports.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Text---class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithModuleDecl.expected.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmaNotAtTopWithModuleDecl.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}--{-# LANGUAGE TupleSections #-}-module Test-( SomeData(..)-) where-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/PragmasAndShebangsNoComment.expected.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasAndShebangsNoComment.hs 
@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsAndModuleDecl.expected.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsAndModuleDecl.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsModuleExplicitExports.expected.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test-( SomeData(..)-) where-import Data.Monoid--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasShebangsModuleExplicitExports.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--module Test-( SomeData(..)-) where--class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasThenShebangsMultilineComment.expected.hs 
@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-import Data.Monoid--{- | some multiline-  comment-   ... -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/PragmasThenShebangsMultilineComment.hs 
@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wall #-}-#! /usr/bin/env nix-shell-#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--{- | some multiline-  comment-   ... -}-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/ShebangNotAtTop.expected.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Data.Monoid--class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTop.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs 
@@ -1,8 +0,0 @@-import Data.Monoid-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopNoSpace.hs 
@@ -1,7 +0,0 @@-class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"--f :: Int -> Int -f x = x * x
− test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}----{-# LANGUAGE TupleSections #-}-import Data.Monoid-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/ShebangNotAtTopWithSpaces.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---{-# OPTIONS_GHC -Wall #-}----{-# LANGUAGE TupleSections #-}-----class Semigroup a => SomeData a-instance SomeData All--#! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])"-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}--addOne :: Int -> Int-addOne x = x + 1
− test/data/import-placement/TwoDashOnlyComment.expected.hs 
@@ -1,9 +0,0 @@-module Test-( SomeData(..)-) where-import Data.Monoid---- no vertical bar comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/TwoDashOnlyComment.hs 
@@ -1,8 +0,0 @@-module Test-( SomeData(..)-) where---- no vertical bar comment-class Semigroup a => SomeData a--instance SomeData All
− test/data/import-placement/WhereDeclLowerInFile.expected.hs 
@@ -1,18 +0,0 @@-module Asdf - (f- , where') - - where-import Data.Int----f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereDeclLowerInFile.hs 
@@ -1,17 +0,0 @@-module Asdf - (f- , where') - - where----f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereKeywordLowerInFileNoExports.expected.hs 
@@ -1,16 +0,0 @@-module Asdf - - - where-import Data.Int---f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
− test/data/import-placement/WhereKeywordLowerInFileNoExports.hs 
@@ -1,15 +0,0 @@-module Asdf - - - where---f :: Int64 -> Int64-f = id'-  where id' = id--g :: Int -> Int -g = id--where' :: Int -> Int -where' = id
+ test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_a (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/zubin/.cabal/bin"+libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace"+dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623"+datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0"+libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0"+sysconfdir = "/home/zubin/.cabal/etc"++getBinDir     = catchIO (getEnv "a_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "a_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "a_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "a_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)+++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_a (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/zubin/.cabal/bin"+libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace-a-test"+dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623"+datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0"+libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0"+sysconfdir = "/home/zubin/.cabal/etc"++getBinDir     = catchIO (getEnv "a_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "a_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "a_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "a_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir)+++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_b (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/zubin/.cabal/bin"+libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0-inplace"+dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623"+datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0"+libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0"+sysconfdir = "/home/zubin/.cabal/etc"++getBinDir     = catchIO (getEnv "b_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "b_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "b_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "b_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir)+++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
+ test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+module Paths_c (+    version,+    getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir,+    getDataFileName, getSysconfDir+  ) where+++import qualified Control.Exception as Exception+import qualified Data.List as List+import Data.Version (Version(..))+import System.Environment (getEnv)+import Prelude+++#if defined(VERSION_base)++#if MIN_VERSION_base(4,0,0)+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#else+catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a+#endif++#else+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#endif+catchIO = Exception.catch++version :: Version+version = Version [1,0,0] []++getDataFileName :: FilePath -> IO FilePath+getDataFileName name = do+  dir <- getDataDir+  return (dir `joinFileName` name)++getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath++++bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath+bindir     = "/home/zubin/.cabal/bin"+libdir     = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0-inplace"+dynlibdir  = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623"+datadir    = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0"+libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0"+sysconfdir = "/home/zubin/.cabal/etc"++getBinDir     = catchIO (getEnv "c_bindir")     (\_ -> return bindir)+getLibDir     = catchIO (getEnv "c_libdir")     (\_ -> return libdir)+getDynLibDir  = catchIO (getEnv "c_dynlibdir")  (\_ -> return dynlibdir)+getDataDir    = catchIO (getEnv "c_datadir")    (\_ -> return datadir)+getLibexecDir = catchIO (getEnv "c_libexecdir") (\_ -> return libexecdir)+getSysconfDir = catchIO (getEnv "c_sysconfdir") (\_ -> return sysconfdir)+++++joinFileName :: String -> String -> FilePath+joinFileName ""  fname = fname+joinFileName "." fname = fname+joinFileName dir ""    = dir+joinFileName dir fname+  | isPathSeparator (List.last dir) = dir ++ fname+  | otherwise                       = dir ++ pathSeparator : fname++pathSeparator :: Char+pathSeparator = '/'++isPathSeparator :: Char -> Bool+isPathSeparator c = c == '/'
test/exe/FuzzySearch.hs view
@@ -1,23 +1,23 @@ module FuzzySearch (tests) where -import Control.Monad (guard)-import Data.Char (toLower)-import Data.Maybe (catMaybes)-import qualified Data.Monoid.Textual as T-import Data.Text (Text, inits, pack)-import qualified Data.Text as Text-import System.Directory (doesFileExist)-import System.IO.Unsafe (unsafePerformIO)-import System.Info.Extra (isWindows)-import Test.QuickCheck-import Test.Tasty-import Test.Tasty.ExpectedFailure-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck (testProperty)-import Text.Fuzzy (Fuzzy (..))-import qualified Text.Fuzzy as Fuzzy-import Text.Fuzzy.Parallel-import Prelude hiding (filter)+import           Control.Monad              (guard)+import           Data.Char                  (toLower)+import           Data.Maybe                 (catMaybes)+import qualified Data.Monoid.Textual        as T+import           Data.Text                  (Text, inits, pack)+import qualified Data.Text                  as Text+import           Prelude                    hiding (filter)+import           System.Directory           (doesFileExist)+import           System.Info.Extra          (isWindows)+import           System.IO.Unsafe           (unsafePerformIO)+import           Test.QuickCheck+import           Test.Tasty+import           Test.Tasty.ExpectedFailure+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck      (testProperty)+import qualified Text.Fuzzy                 as Fuzzy+import           Text.Fuzzy                 (Fuzzy (..))+import           Text.Fuzzy.Parallel  tests :: TestTree tests =
test/exe/Main.hs view
@@ -22,6859 +22,3492 @@ import qualified Control.Lens                             as Lens import           Control.Monad import           Control.Monad.IO.Class                   (MonadIO, liftIO)-import           Data.Aeson                               (fromJSON, toJSON)-import qualified Data.Aeson                               as A-import           Data.Default-import           Data.Foldable-import           Data.List.Extra-import           Data.Maybe-import           Data.Rope.UTF16                          (Rope)-import qualified Data.Rope.UTF16                          as Rope-import qualified Data.Set                                 as Set-import qualified Data.Text                                as T-import           Development.IDE.Core.PositionMapping     (PositionResult (..),-                                                           fromCurrent,-                                                           positionResultToMaybe,-                                                           toCurrent)-import           Development.IDE.GHC.Compat               (GhcVersion (..),-                                                           ghcVersion)-import           Development.IDE.GHC.Util-import qualified Development.IDE.Main                     as IDE-import           Development.IDE.Plugin.Completions.Types (extendImportCommandId)-import           Development.IDE.Plugin.TypeLenses        (typeLensCommandId)-import           Development.IDE.Spans.Common-import           Development.IDE.Test                     (Cursor,-                                                           canonicalizeUri,-                                                           configureCheckProject,-                                                           diagnostic,-                                                           expectCurrentDiagnostics,-                                                           expectDiagnostics,-                                                           expectDiagnosticsWithTags,-                                                           expectMessages,-                                                           expectNoMoreDiagnostics,-                                                           flushMessages,-                                                           getInterfaceFilesDir,-                                                           getStoredKeys,-                                                           isReferenceReady,-                                                           referenceReady,-                                                           standardizeQuotes,-                                                           waitForAction,-                                                           waitForGC,-                                                           waitForTypecheck)-import           Development.IDE.Test.Runfiles-import qualified Development.IDE.Types.Diagnostics        as Diagnostics-import           Development.IDE.Types.Location-import           Development.Shake                        (getDirectoryFilesIO)-import qualified Experiments                              as Bench-import           Ide.Plugin.Config-import           Language.LSP.Test-import           Language.LSP.Types                       hiding-                                                          (SemanticTokenAbsolute (length, line),-                                                           SemanticTokenRelative (length),-                                                           SemanticTokensEdit (_start),-                                                           mkRange)-import           Language.LSP.Types.Capabilities-import qualified Language.LSP.Types.Lens                  as Lens (label)-import qualified Language.LSP.Types.Lens                  as Lsp (diagnostics,-                                                                  message,-                                                                  params)-import           Language.LSP.VFS                         (applyChange)-import           Network.URI-import           System.Directory-import           System.Environment.Blank                 (getEnv, setEnv,-                                                           unsetEnv)-import           System.Exit                              (ExitCode (ExitSuccess))-import           System.FilePath-import           System.IO.Extra                          hiding (withTempDir)-import qualified System.IO.Extra-import           System.Info.Extra                        (isMac, isWindows)-import           System.Mem                               (performGC)-import           System.Process.Extra                     (CreateProcess (cwd),-                                                           createPipe, proc,-                                                           readCreateProcessWithExitCode)-import           Test.QuickCheck--- import Test.QuickCheck.Instances ()-import           Control.Concurrent.Async-import           Control.Lens                             (to, (^.), (.~))-import           Control.Monad.Extra                      (whenJust)-import           Data.Function                            ((&))-import           Data.IORef-import           Data.IORef.Extra                         (atomicModifyIORef_)-import           Data.String                              (IsString (fromString))-import           Data.Tuple.Extra-import           Development.IDE.Core.FileStore           (getModTime)-import           Development.IDE.Plugin.CodeAction        (matchRegExMultipleImports)-import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide-import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds),-                                                           WaitForIdeRuleResult (..),-                                                           blockCommandId)-import           Development.IDE.Types.Logger             (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),-                                                           Pretty (pretty),-                                                           Priority (Debug),-                                                           Recorder (Recorder, logger_),-                                                           WithPriority (WithPriority, priority),-                                                           cfilter,-                                                           cmapWithPrio,-                                                           makeDefaultStderrRecorder)-import qualified FuzzySearch-import           GHC.Stack                                (emptyCallStack)-import qualified HieDbRetry-import           Ide.PluginUtils                          (pluginDescToIdePlugins)-import           Ide.Types-import qualified Language.LSP.Types                       as LSP-import qualified Language.LSP.Types.Lens                  as L-import           Language.LSP.Types.Lens                  (workspace, didChangeWatchedFiles)-import qualified Progress-import           System.Time.Extra-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           Test.Tasty.Ingredients.Rerun-import           Test.Tasty.QuickCheck-import           Text.Printf                              (printf)-import           Text.Regex.TDFA                          ((=~))--data Log-  = LogGhcIde Ghcide.Log-  | LogIDEMain IDE.Log--instance Pretty Log where-  pretty = \case-    LogGhcIde log  -> pretty log-    LogIDEMain log -> pretty log---- | Wait for the next progress begin step-waitForProgressBegin :: Session ()-waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just ()-  _ -> Nothing---- | Wait for the first progress end step--- Also implemented in hls-test-utils Test.Hls-waitForProgressDone :: Session ()-waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()-  _ -> Nothing---- | Wait for all progress to be done--- Needs at least one progress done notification to return--- Also implemented in hls-test-utils Test.Hls-waitForAllProgressDone :: Session ()-waitForAllProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop--main :: IO ()-main = do-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug--  let docWithFilteredPriorityRecorder@Recorder{ logger_ } =-        docWithPriorityRecorder-        & cfilter (\WithPriority{ priority } -> priority >= Debug)--  -- exists so old-style logging works. intended to be phased out-  let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))--  let recorder = docWithFilteredPriorityRecorder-               & cmapWithPrio pretty--  -- We mess with env vars so run single-threaded.-  defaultMainWithRerun $ testGroup "ghcide"-    [ testSession "open close" $ do-        doc <- createDoc "Testing.hs" "haskell" ""-        void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate)-        waitForProgressBegin-        closeDoc doc-        waitForProgressDone-    , codeActionTests-    , initializeResponseTests-    , completionTests-    , cppTests-    , diagnosticTests-    , codeLensesTests-    , outlineTests-    , highlightTests-    , findDefinitionAndHoverTests-    , pluginSimpleTests-    , pluginParsedResultTests-    , preprocessorTests-    , thTests-    , symlinkTests-    , safeTests-    , unitTests recorder logger-    , haddockTests-    , positionMappingTests-    , watchedFilesTests-    , cradleTests-    , dependentFileTest-    , nonLspCommandLine-    , benchmarkTests-    , ifaceTests-    , bootTests-    , rootUriTests-    , asyncTests-    , clientSettingsTest-    , codeActionHelperFunctionTests-    , referenceTests-    , garbageCollectionTests-    , HieDbRetry.tests-    ]--initializeResponseTests :: TestTree-initializeResponseTests = withResource acquire release tests where--  -- these tests document and monitor the evolution of the-  -- capabilities announced by the server in the initialize-  -- response. Currently the server advertises almost no capabilities-  -- at all, in some cases failing to announce capabilities that it-  -- actually does provide! Hopefully this will change ...-  tests :: IO (ResponseMessage Initialize) -> TestTree-  tests getInitializeResponse =-    testGroup "initialize response capabilities"-    [ chk "   text doc sync"             _textDocumentSync  tds-    , chk "   hover"                         _hoverProvider (Just $ InL True)-    , chk "   completion"               _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False))-    , chk "NO signature help"        _signatureHelpProvider Nothing-    , chk "   goto definition"          _definitionProvider (Just $ InL True)-    , chk "   goto type definition" _typeDefinitionProvider (Just $ InL True)-    -- BUG in lsp-test, this test fails, just change the accepted response-    -- for now-    , chk "NO goto implementation"  _implementationProvider (Just $ InL False)-    , chk "   find references"          _referencesProvider (Just $ InL True)-    , chk "   doc highlight"     _documentHighlightProvider (Just $ InL True)-    , chk "   doc symbol"           _documentSymbolProvider (Just $ InL True)-    , chk "   workspace symbol"    _workspaceSymbolProvider (Just True)-    , chk "   code action"             _codeActionProvider  (Just $ InL True)-    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just False))-    , chk "NO doc formatting"   _documentFormattingProvider (Just $ InL False)-    , chk "NO doc range formatting"-                           _documentRangeFormattingProvider (Just $ InL False)-    , chk "NO doc formatting on typing"-                          _documentOnTypeFormattingProvider Nothing-    , chk "NO renaming"                     _renameProvider (Just $ InL False)-    , chk "NO doc link"               _documentLinkProvider Nothing-    , chk "NO color"                         _colorProvider (Just $ InL False)-    , chk "NO folding range"          _foldingRangeProvider (Just $ InL False)-    , che "   execute command"      _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId]-    , chk "   workspace"                         _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))-    , chk "NO experimental"                   _experimental Nothing-    ] where--      tds = Just (InL (TextDocumentSyncOptions-                              { _openClose = Just True-                              , _change    = Just TdSyncIncremental-                              , _willSave  = Nothing-                              , _willSaveWaitUntil = Nothing-                              , _save = Just (InR $ SaveOptions {_includeText = Nothing})}))--      chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree-      chk title getActual expected =-        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir--      che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree-      che title getActual expected = testCase title doTest-        where-            doTest = do-                ir <- getInitializeResponse-                let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir-                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands--  innerCaps :: ResponseMessage Initialize -> ServerCapabilities-  innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c-  innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error"--  acquire :: IO (ResponseMessage Initialize)-  acquire = run initializeResponse--  release :: ResponseMessage Initialize -> IO ()-  release = const $ pure ()---diagnosticTests :: TestTree-diagnosticTests = testGroup "diagnostics"-  [ testSessionWait "fix syntax error" $ do-      let content = T.unlines [ "module Testing wher" ]-      doc <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 19))-            , _rangeLength = Nothing-            , _text = "where"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [])]-  , testSessionWait "introduce syntax error" $ do-      let content = T.unlines [ "module Testing where" ]-      doc <- createDoc "Testing.hs" "haskell" content-      void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate)-      waitForProgressBegin-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 18))-            , _rangeLength = Nothing-            , _text = "wher"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]-  , testSessionWait "update syntax error" $ do-      let content = T.unlines [ "module Testing(missing) where" ]-      doc <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])]-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 15) (Position 0 16))-            , _rangeLength = Nothing-            , _text = "l"-            }-      changeDoc doc [change]-      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])]-  , testSessionWait "variable not in scope" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int -> Int"-            , "foo a _b = a + ab"-            , "bar :: Int -> Int -> Int"-            , "bar _a b = cd + b"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [ (DsError, (2, 15), "Variable not in scope: ab")-            , (DsError, (4, 11), "Variable not in scope: cd")-            ]-          )-        ]-  , testSessionWait "type error" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> String -> Int"-            , "foo a b = a + b"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]-          )-        ]-  , testSessionWait "typed hole" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> String"-            , "foo a = _ a"-            ]-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs"-          , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]-          )-        ]--  , testGroup "deferral" $-    let sourceA a = T.unlines-          [ "module A where"-          , "a :: Int"-          , "a = " <> a]-        sourceB = T.unlines-          [ "module B where"-          , "import A ()"-          , "b :: Float"-          , "b = True"]-        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"-        expectedDs aMessage =-          [ ("A.hs", [(DsError, (2,4), aMessage)])-          , ("B.hs", [(DsError, (3,4), bMessage)])]-        deferralTest title binding msg = testSessionWait title $ do-          _ <- createDoc "A.hs" "haskell" $ sourceA binding-          _ <- createDoc "B.hs" "haskell"   sourceB-          expectDiagnostics $ expectedDs msg-    in-    [ deferralTest "type error"          "True"    "Couldn't match expected type"-    , deferralTest "typed hole"          "_"       "Found hole"-    , deferralTest "out of scope var"    "unbound" "Variable not in scope"-    ]--  , testSessionWait "remove required module" $ do-      let contentA = T.unlines [ "module ModuleA where" ]-      docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      let change = TextDocumentContentChangeEvent-            { _range = Just (Range (Position 0 0) (Position 0 20))-            , _rangeLength = Nothing-            , _text = ""-            }-      changeDoc docA [change]-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]-  , testSessionWait "add missing module" $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA ()"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]-      let contentA = T.unlines [ "module ModuleA where" ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      expectDiagnostics [("ModuleB.hs", [])]-  , testCase "add missing module (non workspace)" $-    -- By default lsp-test sends FileWatched notifications for all files, which we don't want-    -- as non workspace modules will not be watched by the LSP server.-    -- To work around this, we tell lsp-test that our client doesn't have the-    -- FileWatched capability, which is enough to disable the notifications-    withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA ()"-            ]-      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]-      let contentA = T.unlines [ "module ModuleA where" ]-      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA-      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]-  , testSessionWait "cyclic module dependency" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import ModuleB"-            ]-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics-        [ ( "ModuleA.hs"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        , ( "ModuleB.hs"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        ]-  , testSession' "deeply nested cyclic module dependency" $ \path -> do-      let contentA = unlines-            [ "module ModuleA where" , "import ModuleB" ]-      let contentB = unlines-            [ "module ModuleB where" , "import ModuleA" ]-      let contentC = unlines-            [ "module ModuleC where" , "import ModuleB" ]-      let contentD = T.unlines-            [ "module ModuleD where" , "import ModuleC" ]-          cradle =-            "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"-      liftIO $ writeFile (path </> "ModuleA.hs") contentA-      liftIO $ writeFile (path </> "ModuleB.hs") contentB-      liftIO $ writeFile (path </> "ModuleC.hs") contentC-      liftIO $ writeFile (path </> "hie.yaml") cradle-      _ <- createDoc "ModuleD.hs" "haskell" contentD-      expectDiagnostics-        [ ( "ModuleB.hs"-          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]-          )-        ]-  , testSessionWait "cyclic module dependency with hs-boot" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import {-# SOURCE #-} ModuleB"-            ]-      let contentB = T.unlines-            [ "{-# OPTIONS -Wmissing-signatures#-}"-            , "module ModuleB where"-            , "import ModuleA"-            -- introduce an artificial diagnostic-            , "foo = ()"-            ]-      let contentBboot = T.unlines-            [ "module ModuleB where"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "correct reference used with hs-boot" $ do-      let contentB = T.unlines-            [ "module ModuleB where"-            , "import {-# SOURCE #-} ModuleA()"-            ]-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import ModuleB()"-            , "x = 5"-            ]-      let contentAboot = T.unlines-            [ "module ModuleA where"-            ]-      let contentC = T.unlines-            [ "{-# OPTIONS -Wmissing-signatures #-}"-            , "module ModuleC where"-            , "import ModuleA"-            -- this reference will fail if it gets incorrectly-            -- resolved to the hs-boot file-            , "y = x"-            ]-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot-      _ <- createDoc "ModuleC.hs" "haskell" contentC-      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "redundant import" $ do-      let contentA = T.unlines ["module ModuleA where"]-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnosticsWithTags-        [ ( "ModuleB.hs"-          , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]-          )-        ]-  , testSessionWait "redundant import even without warning" $ do-      let contentA = T.unlines ["module ModuleA where"]-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"-            , "module ModuleB where"-            , "import ModuleA"-            -- introduce an artificial warning for testing purposes-            , "foo = ()"-            ]-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleB.hs" "haskell" contentB-      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]-  , testSessionWait "package imports" $ do-      let thisDataListContent = T.unlines-            [ "module Data.List where"-            , "x :: Integer"-            , "x = 123"-            ]-      let mainContent = T.unlines-            [ "{-# LANGUAGE PackageImports #-}"-            , "module Main where"-            , "import qualified \"this\" Data.List as ThisList"-            , "import qualified \"base\" Data.List as BaseList"-            , "useThis = ThisList.x"-            , "useBase = BaseList.map"-            , "wrong1 = ThisList.map"-            , "wrong2 = BaseList.x"-            ]-      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent-      _ <- createDoc "Main.hs" "haskell" mainContent-      expectDiagnostics-        [ ( "Main.hs"-          , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")-            ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")-            ]-          )-        ]-  , testSessionWait "unqualified warnings" $ do-      let fooContent = T.unlines-            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"-            , "module Foo where"-            , "foo :: Ord a => a -> Int"-            , "foo _a = 1"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-      -- The test is to make sure that warnings contain unqualified names-      -- where appropriate. The warning should use an unqualified name 'Ord', not-      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to-      -- test this is fairly arbitrary.-          , [(DsWarning, (2, 0), "Redundant constraint: Ord a")-            ]-          )-        ]-    , testSessionWait "lower-case drive" $ do-          let aContent = T.unlines-                [ "module A.A where"-                , "import A.B ()"-                ]-              bContent = T.unlines-                [ "{-# OPTIONS_GHC -Wall #-}"-                , "module A.B where"-                , "import Data.List"-                ]-          uriB <- getDocUri "A/B.hs"-          Just pathB <- pure $ uriToFilePath uriB-          uriB <- pure $-              let (drive, suffix) = splitDrive pathB-              in filePathToUri (joinDrive (lower drive) suffix)-          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)-          liftIO $ writeFileUTF8 pathB $ T.unpack bContent-          uriA <- getDocUri "A/A.hs"-          Just pathA <- pure $ uriToFilePath uriA-          uriA <- pure $-              let (drive, suffix) = splitDrive pathA-              in filePathToUri (joinDrive (lower drive) suffix)-          let itemA = TextDocumentItem uriA "haskell" 0 aContent-          let a = TextDocumentIdentifier uriA-          sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA)-          NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic-          -- Check that if we put a lower-case drive in for A.A-          -- the diagnostics for A.B will also be lower-case.-          liftIO $ fileUri @?= uriB-          let msg = _message (head (toList diags) :: Diagnostic)-          liftIO $ unless ("redundant" `T.isInfixOf` msg) $-              assertFailure ("Expected redundant import but got " <> T.unpack msg)-          closeDoc a-  , testSessionWait "haddock parse error" $ do-      let fooContent = T.unlines-            [ "module Foo where"-            , "foo :: Int"-            , "foo = 1 {-|-}"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      if ghcVersion >= GHC90 then-          -- Haddock parse errors are ignored on ghc-9.0-            pure ()-      else-        expectDiagnostics-            [ ( "Foo.hs"-              , [(DsWarning, (2, 8), "Haddock parse error on input")]-              )-            ]-  , testSessionWait "strip file path" $ do-      let-          name = "Testing"-          content = T.unlines-            [ "module " <> name <> " where"-            , "value :: Maybe ()"-            , "value = [()]"-            ]-      _ <- createDoc (T.unpack name <> ".hs") "haskell" content-      notification <- skipManyTill anyMessage diagnostic-      let-          offenders =-            Lsp.params .-            Lsp.diagnostics .-            Lens.folded .-            Lsp.message .-            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))-          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg-      Lens.mapMOf_ offenders failure notification-  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do-      liftIO $ writeFile (sessionDir </> "hie.yaml")-        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"-      let fooContent = T.unlines-            [ "module Foo where"-            , "foo = ()"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")-            ]-          )-        ]-  , testSessionWait "-Werror in pragma is ignored" $ do-      let fooContent = T.unlines-            [ "{-# OPTIONS_GHC -Wall -Werror #-}"-            , "module Foo() where"-            , "foo :: Int"-            , "foo = 1"-            ]-      _ <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics-        [ ( "Foo.hs"-          , [(DsWarning, (3, 0), "Defined but not used:")-            ]-          )-        ]-  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"-        aPath = dir </> "A.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int-    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int--    bdoc <- createDoc bPath "haskell" bSource-    _pdoc <- createDoc pPath "haskell" pSource-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded--    -- Change y from Int to B which introduces a type error in A (imported from P)-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $-                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ]--    -- Open A and edit to fix the type error-    adoc <- createDoc aPath "haskell" aSource-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $-                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]--    expectDiagnostics-      [ ( "P.hs",-          [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),-            (DsWarning, (4, 0), "Top-level binding")-          ]-        ),-        ("A.hs", [])-      ]-    expectNoMoreDiagnostics 1--  , testSessionWait "deduplicate missing module diagnostics" $  do-      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]-      doc <- createDoc "Foo.hs" "haskell" fooContent-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]--      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]-      expectDiagnostics []--      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines-            [ "module Foo() where" , "import MissingModule" ] ]-      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]--  , testGroup "Cancellation"-    [ cancellationTestGroup "edit header" editHeader yesSession noParse  noTc-    , cancellationTestGroup "edit import" editImport noSession  yesParse noTc-    , cancellationTestGroup "edit body"   editBody   yesSession yesParse yesTc-    ]-  ]-  where-      editPair x y = let p = Position x y ; p' = Position x (y+2) in-        (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}-        ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})-      editHeader = editPair 0 0-      editImport = editPair 2 10-      editBody   = editPair 3 10--      noParse = False-      yesParse = True--      noSession = False-      yesSession = True--      noTc = False-      yesTc = True--cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree-cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name-    [ cancellationTemplate edits Nothing-    , cancellationTemplate edits $ Just ("GetFileContents", True)-    , cancellationTemplate edits $ Just ("GhcSession", True)-      -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!)-    , cancellationTemplate edits $ Just ("GetModSummary", True)-    , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)-      -- getLocatedImports never fails-    , cancellationTemplate edits $ Just ("GetLocatedImports", True)-    , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)-    , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)-    , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)-    , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome)-    ]--cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree-cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do-      doc <- createDoc "Foo.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wall #-}"-            , "module Foo where"-            , "import Data.List()"-            , "f0 x = (x,x)"-            ]--      -- for the example above we expect one warning-      let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ]-      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags--      -- Now we edit the document and wait for the given key (if any)-      changeDoc doc [edit]-      whenJust mbKey $ \(key, expectedResult) -> do-        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc-        liftIO $ ideResultSuccess @?= expectedResult--      -- The 2nd edit cancels the active session and unbreaks the file-      -- wait for typecheck and check that the current diagnostics are accurate-      changeDoc doc [undoEdit]-      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags--      expectNoMoreDiagnostics 0.5-    where-        -- similar to run except it disables kick-        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s--        typeCheck doc = do-            WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc-            liftIO $ assertBool "The file should typecheck" ideResultSuccess-            -- wait for the debouncer to publish diagnostics if the rule runs-            liftIO $ sleep 0.2-            -- flush messages to ensure current diagnostics state is updated-            flushMessages--codeActionTests :: TestTree-codeActionTests = testGroup "code actions"-  [ insertImportTests-  , extendImportTests-  , renameActionTests-  , typeWildCardActionTests-  , removeImportTests-  , suggestImportClassMethodTests-  , suggestImportTests-  , suggestHideShadowTests-  , suggestImportDisambiguationTests-  , fixConstructorImportTests-  , fixModuleImportTypoTests-  , importRenameActionTests-  , fillTypedHoleTests-  , addSigActionTests-  , insertNewDefinitionTests-  , deleteUnusedDefinitionTests-  , addInstanceConstraintTests-  , addFunctionConstraintTests-  , removeRedundantConstraintsTests-  , addTypeAnnotationsToLiteralsTest-  , exportUnusedTests-  , addImplicitParamsConstraintTests-  , removeExportTests-  ]--codeActionHelperFunctionTests :: TestTree-codeActionHelperFunctionTests = testGroup "code action helpers"-    [-    extendImportTestsRegEx-    ]---codeLensesTests :: TestTree-codeLensesTests = testGroup "code lenses"-  [ addSigLensesTests-  ]--watchedFilesTests :: TestTree-watchedFilesTests = testGroup "watched files"-  [ testGroup "Subscriptions"-    [ testSession' "workspace files" $ \sessionDir -> do-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"-        _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"-        watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    , testSession' "non workspace file" $ \sessionDir -> do-        tmpDir <- liftIO getTemporaryDirectory-        let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"-        liftIO $ writeFile (sessionDir </> "hie.yaml") yaml-        _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"-        watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    -- TODO add a test for didChangeWorkspaceFolder-    ]-  , testGroup "Changes"-    [-      testSession' "workspace files" $ \sessionDir -> do-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Bool"-          ,"b = False"]-        _doc <- createDoc "A.hs" "haskell" $ T.unlines-          ["module A where"-          ,"import B"-          ,"a :: ()"-          ,"a = b"-          ]-        expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])]-        -- modify B off editor-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Int"-          ,"b = 0"]-        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-                List [FileEvent (filePathToUri $ sessionDir </> "B.hs") FcChanged ]-        expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])]-    ]-  ]--insertImportTests :: TestTree-insertImportTests = testGroup "insert import"-  [ expectFailBecause-      ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module declaration, "-      ++ "not accounting for case when 'where' keyword is placed on lower line")-      (checkImport-         "module where keyword lower in file no exports"-         "WhereKeywordLowerInFileNoExports.hs"-         "WhereKeywordLowerInFileNoExports.expected.hs"-         "import Data.Int")-  , expectFailBecause-      ("'findPositionFromImportsOrModuleDecl' function adds import directly under line with module exports list, "-      ++ "not accounting for case when 'where' keyword is placed on lower line")-      (checkImport-         "module where keyword lower in file with exports"-         "WhereDeclLowerInFile.hs"-         "WhereDeclLowerInFile.expected.hs"-         "import Data.Int")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"-      (checkImport-         "Shebang not at top with spaces"-         "ShebangNotAtTopWithSpaces.hs"-         "ShebangNotAtTopWithSpaces.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file"-      (checkImport-         "Shebang not at top no space"-         "ShebangNotAtTopNoSpace.hs"-         "ShebangNotAtTopNoSpace.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case "-      ++ "when OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "OPTIONS_GHC pragma not at top with spaces"-         "OptionsNotAtTopWithSpaces.hs"-         "OptionsNotAtTopWithSpaces.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for "-      ++ "case when shebang is not placed at top of file")-      (checkImport-         "Shebang not at top of file"-         "ShebangNotAtTop.hs"-         "ShebangNotAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case "-      ++ "when OPTIONS_GHC is not placed at top of file")-      (checkImport-         "OPTIONS_GHC pragma not at top of file"-         "OptionsPragmaNotAtTop.hs"-         "OptionsPragmaNotAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case when "-      ++ "OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "pragma not at top with comment at top"-         "PragmaNotAtTopWithCommentsAtTop.hs"-         "PragmaNotAtTopWithCommentsAtTop.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      ("'findNextPragmaPosition' function doesn't account for case when "-      ++ "OPTIONS_GHC pragma is not placed at top of file")-      (checkImport-         "pragma not at top multiple comments"-         "PragmaNotAtTopMultipleComments.hs"-         "PragmaNotAtTopMultipleComments.expected.hs"-         "import Data.Monoid")-  , expectFailBecause-      "'findNextPragmaPosition' function doesn't account for case of multiline pragmas"-      (checkImport-         "after multiline language pragmas"-         "MultiLinePragma.hs"-         "MultiLinePragma.expected.hs"-         "import Data.Monoid")-  , checkImport-      "pragmas not at top with module declaration"-      "PragmaNotAtTopWithModuleDecl.hs"-      "PragmaNotAtTopWithModuleDecl.expected.hs"-      "import Data.Monoid"-  , checkImport-      "pragmas not at top with imports"-      "PragmaNotAtTopWithImports.hs"-      "PragmaNotAtTopWithImports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment at top of module"-      "CommentAtTop.hs"-      "CommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above multiple comments below"-      "CommentAtTopMultipleComments.hs"-      "CommentAtTopMultipleComments.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above curly brace comment"-      "CommentCurlyBraceAtTop.hs"-      "CommentCurlyBraceAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above multi-line comment"-      "MultiLineCommentAtTop.hs"-      "MultiLineCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment with no module explicit exports"-      "NoExplicitExportCommentAtTop.hs"-      "NoExplicitExportCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above two-dash comment with no pipe"-      "TwoDashOnlyComment.hs"-      "TwoDashOnlyComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "above comment with no (module .. where) decl"-      "NoModuleDeclarationCommentAtTop.hs"-      "NoModuleDeclarationCommentAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top with no (module .. where) decl"-      "NoModuleDeclaration.hs"-      "NoModuleDeclaration.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top (data dec is)"-      "DataAtTop.hs"-      "DataAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "comment not at top (newtype is)"-      "NewTypeAtTop.hs"-      "NewTypeAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with no explicit module exports"-      "NoExplicitExports.hs"-      "NoExplicitExports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "add to correctly placed exisiting import"-      "ImportAtTop.hs"-      "ImportAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "add to multiple correctly placed exisiting imports"-      "MultipleImportsAtTop.hs"-      "MultipleImportsAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma at top of module"-      "LangPragmaModuleAtTop.hs"-      "LangPragmaModuleAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma and explicit module exports"-      "LangPragmaModuleWithComment.hs"-      "LangPragmaModuleWithComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with language pragma at top and no module declaration"-      "LanguagePragmaAtTop.hs"-      "LanguagePragmaAtTop.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with multiple lang pragmas and no module declaration"-      "MultipleLanguagePragmasNoModuleDeclaration.hs"-      "MultipleLanguagePragmasNoModuleDeclaration.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with pragmas and shebangs"-      "LanguagePragmasThenShebangs.hs"-      "LanguagePragmasThenShebangs.expected.hs"-      "import Data.Monoid"-  , checkImport-      "with pragmas and shebangs but no comment at top"-      "PragmasAndShebangsNoComment.hs"-      "PragmasAndShebangsNoComment.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl no exports under pragmas and shebangs"-      "PragmasShebangsAndModuleDecl.hs"-      "PragmasShebangsAndModuleDecl.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl with explicit import under pragmas and shebangs"-      "PragmasShebangsModuleExplicitExports.hs"-      "PragmasShebangsModuleExplicitExports.expected.hs"-      "import Data.Monoid"-  , checkImport-      "module decl and multiple imports"-      "ModuleDeclAndImports.hs"-      "ModuleDeclAndImports.expected.hs"-      "import Data.Monoid"-  ]--checkImport :: String -> FilePath -> FilePath -> T.Text -> TestTree-checkImport testComment originalPath expectedPath action =-  testSessionWithExtraFiles "import-placement" testComment $ \dir ->-    check (dir </> originalPath) (dir </> expectedPath) action-  where-    check :: FilePath -> FilePath -> T.Text -> Session ()-    check originalPath expectedPath action = do-      oSrc <- liftIO $ readFileUtf8 originalPath-      eSrc <- liftIO $  readFileUtf8 expectedPath-      originalDoc <- createDoc originalPath "haskell" oSrc-      _ <- waitForDiagnostics-      shouldBeDoc <- createDoc expectedPath "haskell" eSrc-      actionsOrCommands <- getAllCodeActions originalDoc-      chosenAction <- liftIO $ pickActionWithTitle action actionsOrCommands-      executeCodeAction chosenAction-      originalDocAfterAction <- documentContents originalDoc-      shouldBeDocContents <- documentContents shouldBeDoc-      liftIO $ T.replace "\r\n" "\n" shouldBeDocContents @=? T.replace "\r\n" "\n" originalDocAfterAction--renameActionTests :: TestTree-renameActionTests = testGroup "rename actions"-  [ testSession "change to local variable name" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int"-            , "foo argName = argNme"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "foo :: Int -> Int"-            , "foo argName = argName"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "change to name of imported function" $ do-      let content = T.unlines-            [ "module Testing where"-            , "import Data.Maybe (maybeToList)"-            , "foo :: Maybe a -> [a]"-            , "foo = maybToList"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      action <- findCodeAction doc (Range (Position 3 6) (Position 3 16))  "Replace with ‘maybeToList’"-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "import Data.Maybe (maybeToList)"-            , "foo :: Maybe a -> [a]"-            , "foo = maybeToList"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "suggest multiple local variable names" $ do-      let content = T.unlines-            [ "module Testing where"-            , "foo :: Char -> Char -> Char -> Char"-            , "foo argument1 argument2 argument3 = argumentX"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))-                           ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]-      return()-  , testSession "change infix function" $ do-      let content = T.unlines-            [ "module Testing where"-            , "monus :: Int -> Int"-            , "monus x y = max 0 (x - y)"-            , "foo x y = x `monnus` y"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))-      [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]-      executeCodeAction fixTypo-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "monus :: Int -> Int"-            , "monus x y = max 0 (x - y)"-            , "foo x y = x `monus` y"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  ]--typeWildCardActionTests :: TestTree-typeWildCardActionTests = testGroup "type wildcard actions"-  [ testUseTypeSignature "global signature"-        [ "func :: _"-        , "func x = x"-        ]-        [ "func :: (p -> p)"-        , "func x = x"-        ]-  , testUseTypeSignature "local signature"-        [ "func :: Int -> Int"-        , "func x ="-        , "  let y :: _"-        , "      y = x * 2"-        , "  in y"-        ]-        [ "func :: Int -> Int"-        , "func x ="-        , "  let y :: Int"-        , "      y = x * 2"-        , "  in y"-        ]-  , testUseTypeSignature "multi-line message"-        [ "func :: _"-        , "func x y = x + y"-        ]-        [ "func :: (Integer -> Integer -> Integer)"-        , "func x y = x + y"-        ]-  , testUseTypeSignature "type in parentheses"-        [ "func :: a -> _"-        , "func x = (x, const x)"-        ]-        [ "func :: a -> (a, b -> a)"-        , "func x = (x, const x)"-        ]-  , testUseTypeSignature "type in brackets"-        [ "func :: _ -> Maybe a"-        , "func xs = head xs"-        ]-        [ "func :: [Maybe a] -> Maybe a"-        , "func xs = head xs"-        ]-  , testUseTypeSignature "unit type"-        [ "func :: IO _"-        , "func = putChar 'H'"-        ]-        [ "func :: IO ()"-        , "func = putChar 'H'"-        ]-  ]-  where-    -- | Test session of given name, checking action "Use type signature..."-    --   on a test file with given content and comparing to expected result.-    testUseTypeSignature name textIn textOut = testSession name $ do-        let fileStart = "module Testing where"-            content = T.unlines $ fileStart : textIn-            expectedContentAfterAction = T.unlines $ fileStart : textOut-        doc <- createDoc "Testing.hs" "haskell" content-        _ <- waitForDiagnostics-        actionsOrCommands <- getAllCodeActions doc-        let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands-                                    , "Use type signature" `T.isInfixOf` actionTitle-                            ]-        executeCodeAction addSignature-        contentAfterAction <- documentContents doc-        liftIO $ expectedContentAfterAction @=? contentAfterAction--{-# HLINT ignore "Use nubOrd" #-}-removeImportTests :: TestTree-removeImportTests = testGroup "remove import actions"-  [ testSession "redundant" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "qualified redundant" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant binding" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "stuffA = False"-            , "stuffB :: Integer"-            , "stuffB = 123"-            , "stuffC = ()"-            , "_stuffD = '_'"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffA, stuffB, _stuffD, stuffC, stuffA)"-            , "main = print stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove _stuffD, stuffA, stuffC from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffB)"-            , "main = print stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant operator" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "a !! _b = a"-            , "a <?> _b = a"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA as A ((<?>), stuffB, (!!))"-            , "main = print A.stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove !!, <?> from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import qualified ModuleA as A (stuffB)"-            , "main = print A.stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant all import" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "data A = A"-            , "stuffB :: Integer"-            , "stuffB = 123"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (A(..), stuffB)"-            , "main = print stuffB"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove A from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (stuffB)"-            , "main = print stuffB"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "redundant constructor import" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "data D = A | B"-            , "data E = F"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (D(A,B), E(F))"-            , "main = B"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove A, E, F from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (D(B))"-            , "main = B"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "import containing the identifier Strict" $ do-      let contentA = T.unlines-            [ "module Strict where"-            ]-      _docA <- createDoc "Strict.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import Strict"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "remove all" $ do-      let content = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleA where"-            , "import Data.Function (fix, (&))"-            , "import qualified Data.Functor.Const"-            , "import Data.Functor.Identity"-            , "import Data.Functor.Sum (Sum (InL, InR))"-            , "import qualified Data.Kind as K (Constraint, Type)"-            , "x = InL (Identity 123)"-            , "y = fix id"-            , "type T = K.Type"-            ]-      doc <- createDoc "ModuleC.hs" "haskell" content-      _ <- waitForDiagnostics-      [_, _, _, _, InR action@CodeAction { _title = actionTitle }]-          <- nub <$> getAllCodeActions doc-      liftIO $ "Remove all redundant imports" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleA where"-            , "import Data.Function (fix)"-            , "import Data.Functor.Identity"-            , "import Data.Functor.Sum (Sum (InL))"-            , "import qualified Data.Kind as K (Type)"-            , "x = InL (Identity 123)"-            , "y = fix id"-            , "type T = K.Type"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  , testSession "remove unused operators whose name ends with '.'" $ do-      let contentA = T.unlines-            [ "module ModuleA where"-            , "(@.) = 0 -- Must have an operator whose name ends with '.'"-            , "a = 1 -- .. but also something else"-            ]-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      let contentB = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (a, (@.))"-            , "x = a -- Must use something from module A, but not (@.)"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" contentB-      _ <- waitForDiagnostics-      [InR action@CodeAction { _title = actionTitle }, _]-          <- getCodeActions docB (Range (Position 2 0) (Position 2 5))-      liftIO $ "Remove @. from import" @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      let expectedContentAfterAction = T.unlines-            [ "{-# OPTIONS_GHC -Wunused-imports #-}"-            , "module ModuleB where"-            , "import ModuleA (a)"-            , "x = a -- Must use something from module A, but not (@.)"-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction-  ]--extendImportTests :: TestTree-extendImportTests = testGroup "extend import actions"-  [ testGroup "with checkAll" $ tests True-  , testGroup "without checkAll" $ tests False-  ]-  where-    tests overrideCheckProject =-        [ testSession "extend all constructors for record field" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = B { a :: Int }"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A(B))"-                    , "f = a"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(a) to the import list of ModuleA"-            , "Add a to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A(..))"-                    , "f = a"-                    ])-        , testSession "extend all constructors with sibling" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo"-                    , "data Bar"-                    , "data A = B | C"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (C) , Bar ) "-                    , "f = B"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(B) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (..) , Bar ) "-                    , "f = B"-                    ])-        , testSession "extend all constructors with comment" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo"-                    , "data Bar"-                    , "data A = B | C"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (C{-comment--}) , Bar ) "-                    , "f = B"-                    ])-            (Range (Position 2 4) (Position 2 5))-            [ "Add A(..) to the import list of ModuleA"-            , "Add A(B) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ( Foo,  A (..{-comment--}) , Bar ) "-                    , "f = B"-                    ])-        , testSession "extend all constructors for type operator" $ template-            []-            ("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-            (Range (Position 3 17) (Position 3 18))-            [ "Add (:~:)(..) to the import list of Data.Type.Equality"-            , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]-            (T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:) (..))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-        , testSession "extend all constructors for class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add C(..) to the import list of ModuleA"-            , "Add C(m2) to the import list of ModuleA"-            , "Add m2 to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(..))"-                    , "b = m2"-                    ])-        , testSession "extend single line import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB)"-                    , "main = print (stuffA, stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB, stuffA)"-                    , "main = print (stuffA, stuffB)"-                    ])-        , testSession "extend single line import with operator" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "(.*) :: Integer -> Integer -> Integer"-                    , "x .* y = x * y"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB)"-                    , "main = print (stuffB .* stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add (.*) to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA as A (stuffB, (.*))"-                    , "main = print (stuffB .* stuffB)"-                    ])-        , testSession "extend single line import with infix constructor" $ template-            []-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import Data.List.NonEmpty (fromList)"-                    , "main = case (fromList []) of _ :| _ -> pure ()"-                    ])-            (Range (Position 2 5) (Position 2 6))-            [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"-            , "Add NonEmpty(..) to the import list of Data.List.NonEmpty"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))"-                    , "main = case (fromList []) of _ :| _ -> pure ()"-                    ])-        , testSession "extend single line import with prefix constructor" $ template-            []-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import Prelude hiding (Maybe(..))"-                    , "import Data.Maybe (catMaybes)"-                    , "x = Just 10"-                    ])-            (Range (Position 3 5) (Position 2 6))-            [ "Add Maybe(Just) to the import list of Data.Maybe"-            , "Add Maybe(..) to the import list of Data.Maybe"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import Prelude hiding (Maybe(..))"-                    , "import Data.Maybe (catMaybes, Maybe (Just))"-                    , "x = Just 10"-                    ])-        , testSession "extend single line import with type" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "type A = Double"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA ()"-                    , "b :: A"-                    , "b = 0"-                    ])-            (Range (Position 2 5) (Position 2 5))-            ["Add A to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A)"-                    , "b :: A"-                    , "b = 0"-                    ])-        , testSession "extend single line import with constructor" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = Constructor"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A)"-                    , "b :: A"-                    , "b = Constructor"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(Constructor) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (Constructor))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-        , testSession "extend single line import with constructor (with comments)" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = Constructor"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A ({-Constructor-}))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(Constructor) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (Constructor{-Constructor-}))"-                    , "b :: A"-                    , "b = Constructor"-                    ])-        , testSession "extend single line import with mixed constructors" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data A = ConstructorFoo | ConstructorBar"-                    , "a = 1"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (ConstructorBar), a)"-                    , "b :: A"-                    , "b = ConstructorFoo"-                    ])-            (Range (Position 3 5) (Position 3 5))-            [ "Add A(ConstructorFoo) to the import list of ModuleA"-            , "Add A(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)"-                    , "b :: A"-                    , "b = ConstructorFoo"-                    ])-        , testSession "extend single line qualified import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import qualified ModuleA as A (stuffB)"-                    , "main = print (A.stuffA, A.stuffB)"-                    ])-            (Range (Position 2 17) (Position 2 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import qualified ModuleA as A (stuffB, stuffA)"-                    , "main = print (A.stuffA, A.stuffB)"-                    ])-        , testSession "extend multi line import with value" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "stuffA :: Double"-                    , "stuffA = 0.00750"-                    , "stuffB :: Integer"-                    , "stuffB = 123"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (stuffB"-                    , "               )"-                    , "main = print (stuffA, stuffB)"-                    ])-            (Range (Position 3 17) (Position 3 18))-            ["Add stuffA to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (stuffB, stuffA"-                    , "               )"-                    , "main = print (stuffA, stuffB)"-                    ])-        , testSession "extend single line import with method within class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add C(m2) to the import list of ModuleA"-            , "Add m2 to the import list of ModuleA"-            , "Add C(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1, m2))"-                    , "b = m2"-                    ])-        , testSession "extend single line import with method without class" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "class C a where"-                    , "  m1 :: a -> a"-                    , "  m2 :: a -> a"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1))"-                    , "b = m2"-                    ])-            (Range (Position 2 5) (Position 2 5))-            [ "Add m2 to the import list of ModuleA"-            , "Add C(m2) to the import list of ModuleA"-            , "Add C(..) to the import list of ModuleA"-            ]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA (C(m1), m2)"-                    , "b = m2"-                    ])-        , testSession "extend import list with multiple choices" $ template-            [("ModuleA.hs", T.unlines-                    --  this is just a dummy module to help the arguments needed for this test-                    [  "module ModuleA (bar) where"-                    , "bar = 10"-                    ]),-            ("ModuleB.hs", T.unlines-                    --  this is just a dummy module to help the arguments needed for this test-                    [  "module ModuleB (bar) where"-                    , "bar = 10"-                    ])]-            ("ModuleC.hs", T.unlines-                    [ "module ModuleC where"-                    , "import ModuleB ()"-                    , "import ModuleA ()"-                    , "foo = bar"-                    ])-            (Range (Position 3 17) (Position 3 18))-            ["Add bar to the import list of ModuleA",-            "Add bar to the import list of ModuleB"]-            (T.unlines-                    [ "module ModuleC where"-                    , "import ModuleB ()"-                    , "import ModuleA (bar)"-                    , "foo = bar"-                    ])-        , testSession "extend import list with constructor of type operator" $ template-            []-            ("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-            (Range (Position 3 17) (Position 3 18))-            [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"-            , "Add (:~:)(..) to the import list of Data.Type.Equality"]-            (T.unlines-                    [ "module ModuleA where"-                    , "import Data.Type.Equality ((:~:) (Refl))"-                    , "x :: (:~:) [] []"-                    , "x = Refl"-                    ])-        , expectFailBecause "importing pattern synonyms is unsupported"-          $ testSession "extend import list with pattern synonym" $ template-            [("ModuleA.hs", T.unlines-                    [ "{-# LANGUAGE PatternSynonyms #-}"-                      , "module ModuleA where"-                      , "pattern Some x = Just x"-                    ])-            ]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import A ()"-                    , "k (Some x) = x"-                    ])-            (Range (Position 2 3) (Position 2 7))-            ["Add pattern Some to the import list of A"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import A (pattern Some)"-                    , "k (Some x) = x"-                    ])-        , ignoreForGHC92 "Diagnostic message has no suggestions" $-          testSession "type constructor name same as data constructor name" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "newtype Foo = Foo Int"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo)"-                    , "f :: Foo"-                    , "f = Foo 1"-                    ])-            (Range (Position 3 4) (Position 3 6))-            ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo (Foo))"-                    , "f :: Foo"-                    , "f = Foo 1"-                    ])-        , testSession "type constructor name same as data constructor name, data constructor extraneous" $ template-            [("ModuleA.hs", T.unlines-                    [ "module ModuleA where"-                    , "data Foo = Foo"-                    ])]-            ("ModuleB.hs", T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA()"-                    , "f :: Foo"-                    , "f = undefined"-                    ])-            (Range (Position 2 4) (Position 2 6))-            ["Add Foo to the import list of ModuleA"]-            (T.unlines-                    [ "module ModuleB where"-                    , "import ModuleA(Foo)"-                    , "f :: Foo"-                    , "f = undefined"-                    ])-        ]-      where-        codeActionTitle CodeAction{_title=x} = x--        template setUpModules moduleUnderTest range expectedTitles expectedContentB = do-            configureCheckProject overrideCheckProject--            mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules-            docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)-            _  <- waitForDiagnostics-            waitForProgressDone-            actionsOrCommands <- getCodeActions docB range-            let codeActions =-                  filter-                    (T.isPrefixOf "Add" . codeActionTitle)-                    [ca | InR ca <- actionsOrCommands]-                actualTitles = codeActionTitle <$> codeActions-            -- Note that we are not testing the order of the actions, as the-            -- order of the expected actions indicates which one we'll execute-            -- in this test, i.e., the first one.-            liftIO $ sort expectedTitles @=? sort actualTitles--            -- Execute the action with the same title as the first expected one.-            -- Since we tested that both lists have the same elements (possibly-            -- in a different order), this search cannot fail.-            let firstTitle:_ = expectedTitles-                action = fromJust $-                  find ((firstTitle ==) . codeActionTitle) codeActions-            executeCodeAction action-            contentAfterAction <- documentContents docB-            liftIO $ expectedContentB @=? contentAfterAction--fixModuleImportTypoTests :: TestTree-fixModuleImportTypoTests = testGroup "fix module import typo"-    [ testSession "works when single module suggested" $ do-        doc <- createDoc "A.hs" "haskell" "import Data.Cha"-        _ <- waitForDiagnostics-        InR action@CodeAction { _title = actionTitle } : _  <- getCodeActions doc (R 0 0 0 10)-        liftIO $ actionTitle @?= "replace with Data.Char"-        executeCodeAction action-        contentAfterAction <- documentContents doc-        liftIO $ contentAfterAction @?= "import Data.Char"-    , testSession "works when multiple modules suggested" $ do-        doc <- createDoc "A.hs" "haskell" "import Data.I"-        _ <- waitForDiagnostics-        actions <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> getCodeActions doc (R 0 0 0 10)-        let actionTitles = [ title | InR CodeAction{_title=title} <- actions ]-        liftIO $ actionTitles @?= [ "replace with Data.Eq"-                                  , "replace with Data.Int"-                                  , "replace with Data.Ix"-                                  ]-        let InR replaceWithDataEq : _ = actions-        executeCodeAction replaceWithDataEq-        contentAfterAction <- documentContents doc-        liftIO $ contentAfterAction @?= "import Data.Eq"-    ]--extendImportTestsRegEx :: TestTree-extendImportTestsRegEx = testGroup "regex parsing"-    [-      testCase "parse invalid multiple imports" $ template "foo bar foo" Nothing-    , testCase "parse malformed import list" $ template-                  "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217)"-                  Nothing-    , testCase "parse multiple imports" $ template-                 "\n\8226 Perhaps you want to add \8216fromList\8217 to one of these import lists:\n    \8216Data.Map\8217 (app/testlsp.hs:7:1-18)\n    \8216Data.HashMap.Strict\8217 (app/testlsp.hs:8:1-29)"-                 $ Just ("fromList",[("Data.Map","app/testlsp.hs:7:1-18"),("Data.HashMap.Strict","app/testlsp.hs:8:1-29")])-    ]-    where-        template message expected = do-            liftIO $ matchRegExMultipleImports message @=? expected--suggestImportClassMethodTests :: TestTree-suggestImportClassMethodTests =-  testGroup-    "suggest import class methods"-    [ testGroup-        "new"-        [ testSession "via parent" $-            template'-            "import Data.Semigroup (Semigroup(stimes))"-            (Range (Position 4 2) (Position 4 8)),-          testSession "top level" $-            template'-              "import Data.Semigroup (stimes)"-              (Range (Position 4 2) (Position 4 8)),-          testSession "all" $-            template'-              "import Data.Semigroup"-              (Range (Position 4 2) (Position 4 8))-        ],-      testGroup-        "extend"-        [ testSession "via parent" $-            template-              [ "module A where",-                "",-                "import Data.Semigroup ()"-              ]-              (Range (Position 6 2) (Position 6 8))-              "Add Semigroup(stimes) to the import list of Data.Semigroup"-              [ "module A where",-                "",-                "import Data.Semigroup (Semigroup (stimes))"-              ],-          testSession "top level" $-            template-              [ "module A where",-                "",-                "import Data.Semigroup ()"-              ]-              (Range (Position 6 2) (Position 6 8))-              "Add stimes to the import list of Data.Semigroup"-              [ "module A where",-                "",-                "import Data.Semigroup (stimes)"-              ]-        ]-    ]-  where-    decls =-      [ "data X = X",-        "instance Semigroup X where",-        "  (<>) _ _ = X",-        "  stimes _ _ = X"-      ]-    template beforeContent range executeTitle expectedContent = do-      doc <- createDoc "A.hs" "haskell" $ T.unlines (beforeContent <> decls)-      _ <- waitForDiagnostics-      waitForProgressDone-      actions <- getCodeActions doc range-      let actions' = [x | InR x <- actions]-          titles = [_title | CodeAction {_title} <- actions']-      liftIO $ executeTitle `elem` titles @? T.unpack executeTitle <> " does not in " <> show titles-      executeCodeAction $ fromJust $ find (\CodeAction {_title} -> _title == executeTitle) actions'-      content <- documentContents doc-      liftIO $ T.unlines (expectedContent <> decls) @=? content-    template' executeTitle range = let c = ["module A where"] in template c range executeTitle $ c <> [executeTitle]--suggestImportTests :: TestTree-suggestImportTests = testGroup "suggest import actions"-  [ testGroup "Dont want suggestion"-    [ -- extend import-      test False ["Data.List.NonEmpty ()"] "f = nonEmpty" []                "import Data.List.NonEmpty (nonEmpty)"-      -- data constructor-    , test False []                        "f = First"    []                "import Data.Monoid (First)"-      -- internal module-    , test False []         "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable.Internal (Typeable)"-      -- package not in scope-    , test False []         "f = quickCheck"              []                "import Test.QuickCheck (quickCheck)"-      -- don't omit the parent data type of a constructor-    , test False []         "f ExitSuccess = ()"          []                "import System.Exit (ExitSuccess)"-      -- don't suggest data constructor when we only need the type-    , test False []         "f :: Bar"                    []                "import Bar (Bar(Bar))"-      -- don't suggest all data constructors for the data type-    , test False []         "f :: Bar"                    []                "import Bar (Bar(..))"-    ]-  , testGroup "want suggestion"-    [ wantWait  []          "f = foo"                     []                "import Foo (foo)"-    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(Bar))"-    , wantWait  []          "f :: Bar"                    []                "import Bar (Bar)"-    , wantWait  []          "f = Bar"                     []                "import Bar (Bar(..))"-    , test True []          "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"-    , test True []          "f = (:|)"                    []                "import Data.List.NonEmpty (NonEmpty((:|)))"-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural (Natural)"-    , test True []          "f :: Natural"                ["f = undefined"] "import Numeric.Natural"-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty (NonEmpty)"-    , test True []          "f :: NonEmpty ()"            ["f = () :| []"]  "import Data.List.NonEmpty"-    , test True []          "f = First"                   []                "import Data.Monoid (First(First))"-    , test True []          "f = Endo"                    []                "import Data.Monoid (Endo(Endo))"-    , test True []          "f = Version"                 []                "import Data.Version (Version(Version))"-    , test True []          "f ExitSuccess = ()"          []                "import System.Exit (ExitCode(ExitSuccess))"-    , test True []          "f = AssertionFailed"         []                "import Control.Exception (AssertionFailed(AssertionFailed))"-    , test True ["Prelude"] "f = nonEmpty"                []                "import Data.List.NonEmpty (nonEmpty)"-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative (Alternative)"-    , test True []          "f :: Alternative f => f ()"  ["f = undefined"] "import Control.Applicative"-    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(empty))"-    , test True []          "f = empty"                   []                "import Control.Applicative (empty)"-    , test True []          "f = empty"                   []                "import Control.Applicative"-    , test True []          "f = (&)"                     []                "import Data.Function ((&))"-    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"-    , test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"-    , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"-    , test True []          "f = pack"                    []                "import Data.Text (pack)"-    , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"-    , test True []          "f = [] & id"                 []                "import Data.Function ((&))"-    , test True []          "f = (&) [] id"               []                "import Data.Function ((&))"-    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"-    , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"-    , test True []          "f :: a ~~ b"                 []                "import Data.Type.Equality (type (~~))"-    , test True-      ["qualified Data.Text as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True-      [ "qualified Data.Text as T"-      , "qualified Data.Function as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True-      [ "qualified Data.Text as T"-      , "qualified Data.Function as T"-      , "qualified Data.Functor as T"-      , "qualified Data.Data as T"-      ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"-    , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits(..))"-    , test True []          "f = empty"                   []                "import Control.Applicative (Alternative(..))"-    ]-  , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"-  ]-  where-    test = test' False-    wantWait = test' True True--    test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do-      configureCheckProject waitForCheckProject-      let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other-          after  = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other-          cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"-      liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle-      liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]-      doc <- createDoc "Test.hs" "haskell" before-      waitForProgressDone-      _ <- waitForDiagnostics-      -- there isn't a good way to wait until the whole project is checked atm-      when waitForCheckProject $ liftIO $ sleep 0.5-      let defLine = fromIntegral $ length imps + 1-          range = Range (Position defLine 0) (Position defLine maxBound)-      actions <- getCodeActions doc range-      if wanted-         then do-             action <- liftIO $ pickActionWithTitle newImp actions-             executeCodeAction action-             contentAfterAction <- documentContents doc-             liftIO $ after @=? contentAfterAction-          else-              liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= []--suggestImportDisambiguationTests :: TestTree-suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions"-  [ testGroup "Hiding strategy works"-    [ testGroup "fromList"-        [ testCase "AVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use AVec for fromList, hiding other imports"-                "HideFunction.expected.fromList.A.hs"-        , testCase "BVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use BVec for fromList, hiding other imports"-                "HideFunction.expected.fromList.B.hs"-        ]-    , testGroup "(++)"-        [ testCase "EVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use EVec for ++, hiding other imports"-                "HideFunction.expected.append.E.hs"-        , testCase "Hide functions without local" $-            compareTwo-                "HideFunctionWithoutLocal.hs" [(8,8)]-                "Use local definition for ++, hiding other imports"-                "HideFunctionWithoutLocal.expected.hs"-        , testCase "Prelude" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Use Prelude for ++, hiding other imports"-                "HideFunction.expected.append.Prelude.hs"-        , testCase "Prelude and local definition, infix" $-            compareTwo-                "HidePreludeLocalInfix.hs" [(2,19)]-                "Use local definition for ++, hiding other imports"-                "HidePreludeLocalInfix.expected.hs"-        , testCase "AVec, indented" $-            compareTwo "HidePreludeIndented.hs" [(3,8)]-            "Use AVec for ++, hiding other imports"-            "HidePreludeIndented.expected.hs"--        ]-    , testGroup "Vec (type)"-        [ testCase "AVec" $-            compareTwo-                "HideType.hs" [(8,15)]-                "Use AVec for Vec, hiding other imports"-                "HideType.expected.A.hs"-        , testCase "EVec" $-            compareTwo-                "HideType.hs" [(8,15)]-                "Use EVec for Vec, hiding other imports"-                "HideType.expected.E.hs"-        ]-    ]-  , testGroup "Qualify strategy"-    [ testCase "won't suggest full name for qualified module" $-      withHideFunction [(8,9),(10,8)] $ \_ actions -> do-        liftIO $-            assertBool "EVec.fromList must not be suggested" $-                "Replace with qualified: EVec.fromList" `notElem`-                [ actionTitle-                | InR CodeAction { _title = actionTitle } <- actions-                ]-        liftIO $-            assertBool "EVec.++ must not be suggested" $-                "Replace with qualified: EVec.++" `notElem`-                [ actionTitle-                | InR CodeAction { _title = actionTitle } <- actions-                ]-    , testGroup "fromList"-        [ testCase "EVec" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Replace with qualified: E.fromList"-                "HideFunction.expected.qualified.fromList.E.hs"-        , testCase "Hide DuplicateRecordFields" $-            compareTwo-                "HideQualifyDuplicateRecordFields.hs" [(9, 9)]-                "Replace with qualified: AVec.fromList"-                "HideQualifyDuplicateRecordFields.expected.hs"-        , testCase "Duplicate record fields should not be imported" $ do-          withTarget ("HideQualifyDuplicateRecordFields" <.> ".hs") [(9, 9)] $-            \_ actions -> do-              liftIO $-                assertBool "Hidings should not be presented while DuplicateRecordFields exists" $-                  all not [ actionTitle =~ T.pack "Use ([A-Za-z][A-Za-z0-9]*) for fromList, hiding other imports"-                      | InR CodeAction { _title = actionTitle } <- actions]-          withTarget ("HideQualifyDuplicateRecordFieldsSelf" <.> ".hs") [(4, 4)] $-            \_ actions -> do-              liftIO $-                assertBool "ambiguity from DuplicateRecordFields should not be imported" $-                  null actions-        ]-    , testGroup "(++)"-        [ testCase "Prelude, parensed" $-            compareHideFunctionTo [(8,9),(10,8)]-                "Replace with qualified: Prelude.++"-                "HideFunction.expected.qualified.append.Prelude.hs"-        , testCase "Prelude, infix" $-            compareTwo-                "HideQualifyInfix.hs" [(4,19)]-                "Replace with qualified: Prelude.++"-                "HideQualifyInfix.expected.hs"-        , testCase "Prelude, left section" $-            compareTwo-                "HideQualifySectionLeft.hs" [(4,15)]-                "Replace with qualified: Prelude.++"-                "HideQualifySectionLeft.expected.hs"-        , testCase "Prelude, right section" $-            compareTwo-                "HideQualifySectionRight.hs" [(4,18)]-                "Replace with qualified: Prelude.++"-                "HideQualifySectionRight.expected.hs"-        ]-    ]-  ]-  where-    hidingDir = "test/data/hiding"-    compareTwo original locs cmd expected =-        withTarget original locs $ \doc actions -> do-            expected <- liftIO $-                readFileUtf8 (hidingDir </> expected)-            action <- liftIO $ pickActionWithTitle cmd actions-            executeCodeAction action-            contentAfterAction <- documentContents doc-            liftIO $ T.replace "\r\n" "\n" expected @=? contentAfterAction-    compareHideFunctionTo = compareTwo "HideFunction.hs"-    auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"]-    withTarget file locs k = withTempDir $ \dir -> runInDir dir $ do-        liftIO $ mapM_ (\fp -> copyFile (hidingDir </> fp) $ dir </> fp)-            $ file : auxFiles-        doc <- openDoc file "haskell"-        waitForProgressDone-        void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])]-        actions <- getAllCodeActions doc-        k doc actions-    withHideFunction = withTarget ("HideFunction" <.> "hs")--suggestHideShadowTests :: TestTree-suggestHideShadowTests =-  testGroup-    "suggest hide shadow"-    [ testGroup-        "single"-        [ testOneCodeAction-            "hide unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function"-            , "f on = on"-            , "g on = on"-            ]-            [ "import Data.Function hiding (on)"-            , "f on = on"-            , "g on = on"-            ]-        , testOneCodeAction-            "extend hiding unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function hiding ((&))"-            , "f on = on"-            ]-            [ "import Data.Function hiding (on, (&))"-            , "f on = on"-            ]-        , testOneCodeAction-            "delete unsued"-            "Hide on from Data.Function"-            (1, 2)-            (1, 4)-            [ "import Data.Function ((&), on)"-            , "f on = on"-            ]-            [ "import Data.Function ((&))"-            , "f on = on"-            ]-        , testOneCodeAction-            "hide operator"-            "Hide & from Data.Function"-            (1, 2)-            (1, 5)-            [ "import Data.Function"-            , "f (&) = (&)"-            ]-            [ "import Data.Function hiding ((&))"-            , "f (&) = (&)"-            ]-        , testOneCodeAction-            "remove operator"-            "Hide & from Data.Function"-            (1, 2)-            (1, 5)-            [ "import Data.Function ((&), on)"-            , "f (&) = (&)"-            ]-            [ "import Data.Function ( on)"-            , "f (&) = (&)"-            ]-        , noCodeAction-            "don't remove already used"-            (2, 2)-            (2, 4)-            [ "import Data.Function"-            , "g = on"-            , "f on = on"-            ]-        ]-    , testGroup-        "multi"-        [ testOneCodeAction-            "hide from B"-            "Hide ++ from B"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "hide from C"-            "Hide ++ from C"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B"-            , "import C hiding ((++))"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "hide from Prelude"-            "Hide ++ from Prelude"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B"-            , "import C"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        , testMultiCodeActions-            "manual hide all"-            [ "Hide ++ from Prelude"-            , "Hide ++ from C"-            , "Hide ++ from B"-            ]-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C hiding ((++))"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        , testOneCodeAction-            "auto hide all"-            "Hide ++ from all occurence imports"-            (2, 2)-            (2, 6)-            [ "import B"-            , "import C"-            , "f (++) = (++)"-            ]-            [ "import B hiding ((++))"-            , "import C hiding ((++))"-            , "import Prelude hiding ((++))"-            , "f (++) = (++)"-            ]-        ]-    ]- where-  testOneCodeAction testName actionName start end origin expected =-    helper testName start end origin expected $ \cas -> do-      action <- liftIO $ pickActionWithTitle actionName cas-      executeCodeAction action-  noCodeAction testName start end origin =-    helper testName start end origin origin $ \cas -> do-      liftIO $ cas @?= []-  testMultiCodeActions testName actionNames start end origin expected =-    helper testName start end origin expected $ \cas -> do-      let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames]-      liftIO $-        (length r == length actionNames)-          @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset"-      forM_ r executeCodeAction-  helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do-    void $ createDoc "B.hs" "haskell" $ T.unlines docB-    void $ createDoc "C.hs" "haskell" $ T.unlines docC-    doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin)-    void waitForDiagnostics-    waitForProgressDone-    cas <- getCodeActions doc (Range (Position (fromIntegral $ line1 + length header) col1) (Position (fromIntegral $ line2 + length header) col2))-    void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)]-    contentAfter <- documentContents doc-    liftIO $ contentAfter @?= T.unlines (header <> expected)-  header =-    [ "{-# OPTIONS_GHC -Wname-shadowing #-}"-    , "module A where"-    , ""-    ]-  -- for multi group-  docB =-    [ "module B where"-    , "(++) = id"-    ]-  docC =-    [ "module C where"-    , "(++) = id"-    ]--insertNewDefinitionTests :: TestTree-insertNewDefinitionTests = testGroup "insert new definition actions"-  [ testSession "insert new function definition" $ do-      let txtB =-            ["foo True = select [True]"-            , ""-            ,"foo False = False"-            ]-          txtB' =-            [""-            ,"someOtherCode = ()"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')-      _ <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB (R 0 0 0 50)-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ contentAfterAction @?= T.unlines (txtB ++-        [ ""-        , "select :: [Bool] -> Bool"-        , "select = _"-        ]-        ++ txtB')-  , testSession "define a hole" $ do-      let txtB =-            ["foo True = _select [True]"-            , ""-            ,"foo False = False"-            ]-          txtB' =-            [""-            ,"someOtherCode = ()"-            ]-      docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')-      _ <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB (R 0 0 0 50)-      liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ contentAfterAction @?= T.unlines (-        ["foo True = select [True]"-        , ""-        ,"foo False = False"-        , ""-        , "select :: [Bool] -> Bool"-        , "select = _"-        ]-        ++ txtB')-  , testSession "insert new function definition - Haddock comments" $ do-    let start =  ["foo :: Int -> Bool"-                 , "foo x = select (x + 1)"-                 , ""-                 , "-- | This is a haddock comment"-                 , "haddock :: Int -> Int"-                 , "haddock = undefined"-                 ]-    let expected =  ["foo :: Int -> Bool"-             , "foo x = select (x + 1)"-             , ""-             , "select :: Int -> Bool"-             , "select = _"-             , ""-             , "-- | This is a haddock comment"-             , "haddock :: Int -> Int"-             , "haddock = undefined"]-    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)-    _ <- waitForDiagnostics-    InR action@CodeAction { _title = actionTitle } : _-                <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                    getCodeActions docB (R 1 0 0 50)-    liftIO $ actionTitle @?= "Define select :: Int -> Bool"-    executeCodeAction action-    contentAfterAction <- documentContents docB-    liftIO $ contentAfterAction @?= T.unlines expected-  , testSession "insert new function definition - normal comments" $ do-    let start =  ["foo :: Int -> Bool"-                 , "foo x = select (x + 1)"-                 , ""-                 , "-- This is a normal comment"-                 , "normal :: Int -> Int"-                 , "normal = undefined"-                 ]-    let expected =  ["foo :: Int -> Bool"-             , "foo x = select (x + 1)"-             , ""-             , "select :: Int -> Bool"-             , "select = _"-             , ""-             , "-- This is a normal comment"-             , "normal :: Int -> Int"-             , "normal = undefined"]-    docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start)-    _ <- waitForDiagnostics-    InR action@CodeAction { _title = actionTitle } : _-                <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                    getCodeActions docB (R 1 0 0 50)-    liftIO $ actionTitle @?= "Define select :: Int -> Bool"-    executeCodeAction action-    contentAfterAction <- documentContents docB-    liftIO $ contentAfterAction @?= T.unlines expected-  ]---deleteUnusedDefinitionTests :: TestTree-deleteUnusedDefinitionTests = testGroup "delete unused definition action"-  [ testSession "delete unused top level binding" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-               , "module A (some) where"-               , ""-               , "f :: Int -> Int"-               , "f 1 = let a = 1"-               , "      in a"-               , "f 2 = 2"-               , ""-               , "some = ()"-               ])-    (4, 0)-    "Delete ‘f’"-    (T.unlines [-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"-        , "module A (some) where"-        , ""-        , "some = ()"-        ])--  , testSession "delete unused top level binding defined in infix form" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-               , "module A (some) where"-               , ""-               , "myPlus :: Int -> Int -> Int"-               , "a `myPlus` b = a + b"-               , ""-               , "some = ()"-               ])-    (4, 2)-    "Delete ‘myPlus’"-    (T.unlines [-        "{-# OPTIONS_GHC -Wunused-top-binds #-}"-        , "module A (some) where"-        , ""-        , "some = ()"-      ])-  , testSession "delete unused binding in where clause" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (h, g) where"-               , ""-               , "h :: Int"-               , "h = 3"-               , ""-               , "g :: Int"-               , "g = 6"-               , "  where"-               , "    h :: Int"-               , "    h = 4"-               , ""-               ])-    (10, 4)-    "Delete ‘h’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (h, g) where"-               , ""-               , "h :: Int"-               , "h = 3"-               , ""-               , "g :: Int"-               , "g = 6"-               , "  where"-               , ""-               ])-  , testSession "delete unused binding with multi-oneline signatures front" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (b, c) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (4, 0)-    "Delete ‘a’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (b, c) where"-               , ""-               , "b, c :: Int"-               , "b = 4"-               , "c = 5"-               ])-  , testSession "delete unused binding with multi-oneline signatures mid" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, c) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (5, 0)-    "Delete ‘b’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, c) where"-               , ""-               , "a, c :: Int"-               , "a = 3"-               , "c = 5"-               ])-  , testSession "delete unused binding with multi-oneline signatures end" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, b) where"-               , ""-               , "a, b, c :: Int"-               , "a = 3"-               , "b = 4"-               , "c = 5"-               ])-    (6, 0)-    "Delete ‘c’"-    (T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}"-               , "module A (a, b) where"-               , ""-               , "a, b :: Int"-               , "a = 3"-               , "b = 4"-               ])-  ]-  where-    testFor source pos expectedTitle expectedResult = do-      docId <- createDoc "A.hs" "haskell" source-      expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ]--      (action, title) <- extractCodeAction docId "Delete" pos--      liftIO $ title @?= expectedTitle-      executeCodeAction action-      contentAfterAction <- documentContents docId-      liftIO $ contentAfterAction @?= expectedResult--    extractCodeAction docId actionPrefix (l, c) = do-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R l c l c) [actionPrefix]-      return (action, actionTitle)--addTypeAnnotationsToLiteralsTest :: TestTree-addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals to satisfy constraints"-  [-    testSession "add default type to satisfy one constraint" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A (f) where"-               , ""-               , "f = 1"-               ])-    [ (DsWarning, (3, 4), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘1’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A (f) where"-               , ""-               , "f = (1 :: Integer)"-               ])--  , testSession "add default type to satisfy one constraint in nested expressions" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = 3"-               , "    in x"-               ])-    [ (DsWarning, (4, 12), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘3’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = (3 :: Integer)"-               , "    in x"-               ])-  , testSession "add default type to satisfy one constraint in more nested expressions" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = let y = 5 in y"-               , "    in x"-               ])-    [ (DsWarning, (4, 20), "Defaulting the following constraint") ]-    "Add type annotation ‘Integer’ to ‘5’"-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "module A where"-               , ""-               , "f ="-               , "    let x = let y = (5 :: Integer) in y"-               , "    in x"-               ])-  , testSession "add default type to satisfy one constraint with duplicate literals" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq \"debug\" traceShow \"debug\""-               ])-    [ (DsWarning, (6, 8), "Defaulting the following constraint")-    , (DsWarning, (6, 16), "Defaulting the following constraint")-    ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\""-               ])-  , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $-    testSession "add default type to satisfy two constraints" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f a = traceShow \"debug\" a"-               ])-    [ (DsWarning, (6, 6), "Defaulting the following constraint") ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a"-               ])-  , knownBrokenForGhcVersions [GHC92] "GHC 9.2 only has 'traceShow' in error span" $-    testSession "add default type to satisfy two constraints with duplicate literals" $-    testFor-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))"-               ])-    [ (DsWarning, (6, 54), "Defaulting the following constraint") ]-    ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’")-    (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}"-               , "{-# LANGUAGE OverloadedStrings #-}"-               , "module A (f) where"-               , ""-               , "import Debug.Trace"-               , ""-               , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))"-               ])-  ]-  where-    testFor source diag expectedTitle expectedResult = do-      docId <- createDoc "A.hs" "haskell" source-      expectDiagnostics [ ("A.hs", diag) ]--      let cursors = map snd3 diag-      (action, title) <- extractCodeAction docId "Add type annotation" (minimum cursors) (maximum cursors)--      liftIO $ title @?= expectedTitle-      executeCodeAction action-      contentAfterAction <- documentContents docId-      liftIO $ contentAfterAction @?= expectedResult--    extractCodeAction docId actionPrefix (l,c) (l', c')= do-      [action@CodeAction { _title = actionTitle }]  <- findCodeActionsByPrefix docId (R l c l' c') [actionPrefix]-      return (action, actionTitle)---fixConstructorImportTests :: TestTree-fixConstructorImportTests = testGroup "fix import actions"-  [ testSession "fix constructor import" $ template-      (T.unlines-            [ "module ModuleA where"-            , "data A = Constructor"-            ])-      (T.unlines-            [ "module ModuleB where"-            , "import ModuleA(Constructor)"-            ])-      (Range (Position 1 10) (Position 1 11))-      "Fix import of A(Constructor)"-      (T.unlines-            [ "module ModuleB where"-            , "import ModuleA(A(Constructor))"-            ])-  ]-  where-    template contentA contentB range expectedAction expectedContentB = do-      _docA <- createDoc "ModuleA.hs" "haskell" contentA-      docB  <- createDoc "ModuleB.hs" "haskell" contentB-      _diags <- waitForDiagnostics-      InR action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>-                     getCodeActions docB range-      liftIO $ expectedAction @=? actionTitle-      executeCodeAction action-      contentAfterAction <- documentContents docB-      liftIO $ expectedContentB @=? contentAfterAction--importRenameActionTests :: TestTree-importRenameActionTests = testGroup "import rename actions"-  [ testSession "Data.Mape -> Data.Map"   $ check "Map"-  , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where-  check modname = do-      let content = T.unlines-            [ "module Testing where"-            , "import Data.Mape"-            ]-      doc <- createDoc "Testing.hs" "haskell" content-      _ <- waitForDiagnostics-      actionsOrCommands <- getCodeActions doc (Range (Position 1 8) (Position 1 16))-      let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]-      executeCodeAction changeToMap-      contentAfterAction <- documentContents doc-      let expectedContentAfterAction = T.unlines-            [ "module Testing where"-            , "import Data." <> modname-            ]-      liftIO $ expectedContentAfterAction @=? contentAfterAction--fillTypedHoleTests :: TestTree-fillTypedHoleTests = let--  sourceCode :: T.Text -> T.Text -> T.Text -> T.Text-  sourceCode a b c = T.unlines-    [ "module Testing where"-      , ""-      , "globalConvert :: Int -> String"-      , "globalConvert = undefined"-      , ""-      , "globalInt :: Int"-      , "globalInt = 3"-      , ""-      , "bar :: Int -> Int -> String"-      , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ")  where"-      , "  localConvert = (flip replicate) 'x'"-      , ""-      , "foo :: () -> Int -> String"-      , "foo = undefined"--    ]--  check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle-        oldA oldB oldC-        newA newB newC = testSession (T.unpack actionTitle) $ do-    let originalCode = sourceCode oldA oldB oldC-    let expectedCode = sourceCode newA newB newC-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode-  in-  testGroup "fill typed holes"-  [ check "replace _ with show"-          "_"    "n" "n"-          "show" "n" "n"--  , check "replace _ with globalConvert"-          "_"             "n" "n"-          "globalConvert" "n" "n"--  , check "replace _convertme with localConvert"-          "_convertme"   "n" "n"-          "localConvert" "n" "n"--  , check "replace _b with globalInt"-          "_a" "_b"        "_c"-          "_a" "globalInt" "_c"--  , check "replace _c with globalInt"-          "_a" "_b"        "_c"-          "_a" "_b" "globalInt"--  , check "replace _c with parameterInt"-          "_a" "_b" "_c"-          "_a" "_b"  "parameterInt"-  , check "replace _ with foo _"-          "_" "n" "n"-          "(foo _)" "n" "n"-  , testSession "replace _toException with E.toException" $ do-      let mkDoc x = T.unlines-            [ "module Testing where"-            , "import qualified Control.Exception as E"-            , "ioToSome :: E.IOException -> E.SomeException"-            , "ioToSome = " <> x ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound))-      chosen <- liftIO $ pickActionWithTitle "replace _toException with E.toException" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "E.toException" @=? modifiedCode-  , testSession "filling infix type hole uses prefix notation" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "data A = A"-              , "foo :: A -> A -> A"-              , "foo A A = A"-              , "test :: A -> A -> A"-              , "test a1 a2 = a1 " <> x <> " a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19))-      chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "`foo`" @=? modifiedCode-  , testSession "postfix hole uses postfix notation of infix operator" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = " <> x <> " a1 a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "_"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14))-      chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "(+)" @=? modifiedCode-  , testSession "filling infix type hole uses infix operator" $ do-      let mkDoc x = T.unlines-              [ "module Testing where"-              , "test :: Int -> Int -> Int"-              , "test a1 a2 = a1 " <> x <> " a2"-              ]-      doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`"-      _ <- waitForDiagnostics-      actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19))-      chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions-      executeCodeAction chosen-      modifiedCode <- documentContents doc-      liftIO $ mkDoc "+" @=? modifiedCode-  ]--addInstanceConstraintTests :: TestTree-addInstanceConstraintTests = let-  missingConstraintSourceCode :: Maybe T.Text -> T.Text-  missingConstraintSourceCode mConstraint =-    let constraint = maybe "" (<> " => ") mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Wrap a = Wrap a"-    , ""-    , "instance " <> constraint <> "Eq (Wrap a) where"-    , "  (Wrap x) == (Wrap y) = x == y"-    ]--  incompleteConstraintSourceCode :: Maybe T.Text -> T.Text-  incompleteConstraintSourceCode mConstraint =-    let constraint = maybe "Eq a" (\c -> "(Eq a, " <> c <> ")")  mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "instance " <> constraint <> " => Eq (Pair a b) where"-    , "  (Pair x y) == (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode2 :: Maybe T.Text -> T.Text-  incompleteConstraintSourceCode2 mConstraint =-    let constraint = maybe "(Eq a, Eq b)" (\c -> "(Eq a, Eq b, " <> c <> ")")  mConstraint-     in T.unlines-    [ "module Testing where"-    , ""-    , "data Three a b c = Three a b c"-    , ""-    , "instance " <> constraint <> " => Eq (Three a b c) where"-    , "  (Three x y z) == (Three x' y' z') = x == x' && y == y' && z == z'"-    ]--  check :: T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getAllCodeActions doc-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode--  in testGroup "add instance constraint"-  [ check-    "Add `Eq a` to the context of the instance declaration"-    (missingConstraintSourceCode Nothing)-    (missingConstraintSourceCode $ Just "Eq a")-  , check-    "Add `Eq b` to the context of the instance declaration"-    (incompleteConstraintSourceCode Nothing)-    (incompleteConstraintSourceCode $ Just "Eq b")-  , check-    "Add `Eq c` to the context of the instance declaration"-    (incompleteConstraintSourceCode2 Nothing)-    (incompleteConstraintSourceCode2 $ Just "Eq c")-  ]--addFunctionConstraintTests :: TestTree-addFunctionConstraintTests = let-  missingConstraintSourceCode :: T.Text -> T.Text-  missingConstraintSourceCode constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "eq :: " <> constraint <> "a -> a -> Bool"-    , "eq x y = x == y"-    ]--  missingConstraintWithForAllSourceCode :: T.Text -> T.Text-  missingConstraintWithForAllSourceCode constraint =-    T.unlines-    [ "{-# LANGUAGE ExplicitForAll #-}"-    , "module Testing where"-    , ""-    , "eq :: forall a. " <> constraint <> "a -> a -> Bool"-    , "eq x y = x == y"-    ]--  incompleteConstraintWithForAllSourceCode :: T.Text -> T.Text-  incompleteConstraintWithForAllSourceCode constraint =-    T.unlines-    [ "{-# LANGUAGE ExplicitForAll #-}"-    , "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode :: T.Text -> T.Text-  incompleteConstraintSourceCode constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: " <> constraint <> " => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCode2 :: T.Text -> T.Text-  incompleteConstraintSourceCode2 constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Three a b c = Three a b c"-    , ""-    , "eq :: " <> constraint <> " => Three a b c -> Three a b c -> Bool"-    , "eq (Three x y z) (Three x' y' z') = x == x' && y == y' && z == z'"-    ]--  incompleteConstraintSourceCodeWithExtraCharsInContext :: T.Text -> T.Text-  incompleteConstraintSourceCodeWithExtraCharsInContext constraint =-    T.unlines-    [ "module Testing where"-    , ""-    , "data Pair a b = Pair a b"-    , ""-    , "eq :: ( " <> constraint <> " ) => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  incompleteConstraintSourceCodeWithNewlinesInTypeSignature :: T.Text -> T.Text-  incompleteConstraintSourceCodeWithNewlinesInTypeSignature constraint =-    T.unlines-    [ "module Testing where"-    , "data Pair a b = Pair a b"-    , "eq "-    , "    :: (" <> constraint <> ")"-    , "    => Pair a b -> Pair a b -> Bool"-    , "eq (Pair x y) (Pair x' y') = x == x' && y == y'"-    ]--  missingMonadConstraint constraint = T.unlines-    [ "module Testing where"-    , "f :: " <> constraint <> "m ()"-    , "f = do "-    , "  return ()"-    ]--  in testGroup "add function constraint"-  [ checkCodeAction-    "no preexisting constraint"-    "Add `Eq a` to the context of the type signature for `eq`"-    (missingConstraintSourceCode "")-    (missingConstraintSourceCode "Eq a => ")-  , checkCodeAction-    "no preexisting constraint, with forall"-    "Add `Eq a` to the context of the type signature for `eq`"-    (missingConstraintWithForAllSourceCode "")-    (missingConstraintWithForAllSourceCode "Eq a => ")-  , checkCodeAction-    "preexisting constraint, no parenthesis"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCode "Eq a")-    (incompleteConstraintSourceCode "(Eq a, Eq b)")-  , checkCodeAction-    "preexisting constraints in parenthesis"-    "Add `Eq c` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCode2 "(Eq a, Eq b)")-    (incompleteConstraintSourceCode2 "(Eq a, Eq b, Eq c)")-  , checkCodeAction-    "preexisting constraints with forall"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintWithForAllSourceCode "Eq a")-    (incompleteConstraintWithForAllSourceCode "(Eq a, Eq b)")-  , checkCodeAction-    "preexisting constraint, with extra spaces in context"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a")-    (incompleteConstraintSourceCodeWithExtraCharsInContext "Eq a, Eq b")-  , checkCodeAction-    "preexisting constraint, with newlines in type signature"-    "Add `Eq b` to the context of the type signature for `eq`"-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a")-    (incompleteConstraintSourceCodeWithNewlinesInTypeSignature "Eq a, Eq b")-  , checkCodeAction-    "missing Monad constraint"-    "Add `Monad m` to the context of the type signature for `f`"-    (missingMonadConstraint "")-    (missingMonadConstraint "Monad m => ")-  ]--checkCodeAction :: String -> T.Text -> T.Text -> T.Text -> TestTree-checkCodeAction testName actionTitle originalCode expectedCode = testSession testName $ do-  doc <- createDoc "Testing.hs" "haskell" originalCode-  _ <- waitForDiagnostics-  actionsOrCommands <- getAllCodeActions doc-  chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-  executeCodeAction chosenAction-  modifiedCode <- documentContents doc-  liftIO $ expectedCode @=? modifiedCode--addImplicitParamsConstraintTests :: TestTree-addImplicitParamsConstraintTests =-  testGroup-    "add missing implicit params constraints"-    [ testGroup-        "introduced"-        [ let ex ctxtA = exampleCode "?a" ctxtA ""-           in checkCodeAction "at top level" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()"),-          let ex ctxA = exampleCode "x where x = ?a" ctxA ""-           in checkCodeAction "in nested def" "Add ?a::() to the context of fBase" (ex "") (ex "?a::()")-        ],-      testGroup-        "inherited"-        [ let ex = exampleCode "()" "?a::()"-           in checkCodeAction-                "with preexisting context"-                "Add `?a::()` to the context of the type signature for `fCaller`"-                (ex "Eq ()")-                (ex "Eq (), ?a::()"),-          let ex = exampleCode "()" "?a::()"-           in checkCodeAction "without preexisting context" "Add ?a::() to the context of fCaller" (ex "") (ex "?a::()")-        ]-    ]-  where-    mkContext ""       = ""-    mkContext contents = "(" <> contents <> ") => "--    exampleCode bodyBase contextBase contextCaller =-      T.unlines-        [ "{-# LANGUAGE FlexibleContexts, ImplicitParams #-}",-          "module Testing where",-          "fBase :: " <> mkContext contextBase <> "()",-          "fBase = " <> bodyBase,-          "fCaller :: " <> mkContext contextCaller <> "()",-          "fCaller = fBase"-        ]--removeRedundantConstraintsTests :: TestTree-removeRedundantConstraintsTests = let-  header =-    [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"-    , "module Testing where"-    , ""-    ]--  headerExt :: [T.Text] -> [T.Text]-  headerExt exts =-    redunt : extTxt ++ ["module Testing where"]-    where-      redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}"-      extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts--  redundantConstraintsCode :: Maybe T.Text -> T.Text-  redundantConstraintsCode mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "foo :: " <> constraint <> "a -> a"-        , "foo = id"-        ]--  redundantMixedConstraintsCode :: Maybe T.Text -> T.Text-  redundantMixedConstraintsCode mConstraint =-    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint-      in T.unlines $ header <>-        [ "foo :: " <> constraint <> " => a -> Bool"-        , "foo x = x == 1"-        ]--  typeSignatureSpaces :: Maybe T.Text -> T.Text-  typeSignatureSpaces mConstraint =-    let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint-      in T.unlines $ header <>-        [ "foo ::  " <> constraint <> " => a -> Bool"-        , "foo x = x == 1"-        ]--  redundantConstraintsForall :: Maybe T.Text -> T.Text-  redundantConstraintsForall mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ headerExt ["RankNTypes"] <>-        [ "foo :: forall a. " <> constraint <> "a -> a"-        , "foo = id"-        ]--  typeSignatureDo :: Maybe T.Text -> T.Text-  typeSignatureDo mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> IO ()"-        , "f n = do"-        , "  let foo :: " <> constraint <> "a -> IO ()"-        , "      foo _ = return ()"-        , "  r n"-        ]--  typeSignatureNested :: Maybe T.Text -> T.Text-  typeSignatureNested mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f = g"-        , "  where"-        , "    g :: " <> constraint <> "a -> ()"-        , "    g _ = ()"-        ]--  typeSignatureNested' :: Maybe T.Text -> T.Text-  typeSignatureNested' mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f ="-        , "  let"-        , "    g :: Int -> ()"-        , "    g = h"-        , "      where"-        , "        h :: " <> constraint <> "a -> ()"-        , "        h _ = ()"-        , "  in g"-        ]--  typeSignatureNested'' :: Maybe T.Text -> T.Text-  typeSignatureNested'' mConstraint =-    let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint-      in T.unlines $ header <>-        [ "f :: Int -> ()"-        , "f = g"-        , "  where"-        , "    g :: Int -> ()"-        , "    g = "-        , "      let"-        , "        h :: " <> constraint <> "a -> ()"-        , "        h _ = ()"-        , "      in h"-        ]--  typeSignatureLined1 = T.unlines $ header <>-    [ "foo :: Eq a =>"-    , "  a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureLined2 = T.unlines $ header <>-    [ "foo :: (Eq a, Show a)"-    , "  => a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureOneLine = T.unlines $ header <>-    [ "foo :: a -> Bool"-    , "foo _ = True"-    ]--  typeSignatureLined3 = T.unlines $ header <>-    [ "foo :: ( Eq a"-    , "       , Show a"-    , "       )"-    , "    => a -> Bool"-    , "foo x = x == x"-    ]--  typeSignatureLined3' = T.unlines $ header <>-    [ "foo :: ( Eq a"-    , "       )"-    , "    => a -> Bool"-    , "foo x = x == x"-    ]---  check :: T.Text -> T.Text -> T.Text -> TestTree-  check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do-    doc <- createDoc "Testing.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getAllCodeActions doc-    chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode--  in testGroup "remove redundant function constraints"-  [ check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (redundantConstraintsCode $ Just "Eq a")-    (redundantConstraintsCode Nothing)-  , check-    "Remove redundant constraints `(Eq a, Monoid a)` from the context of the type signature for `foo`"-    (redundantConstraintsCode $ Just "(Eq a, Monoid a)")-    (redundantConstraintsCode Nothing)-  , check-    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"-    (redundantMixedConstraintsCode $ Just "Monoid a, Show a")-    (redundantMixedConstraintsCode Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `g`"-    (typeSignatureNested $ Just "Eq a")-    (typeSignatureNested Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"-    (typeSignatureNested' $ Just "Eq a")-    (typeSignatureNested' Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `h`"-    (typeSignatureNested'' $ Just "Eq a")-    (typeSignatureNested'' Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (redundantConstraintsForall $ Just "Eq a")-    (redundantConstraintsForall Nothing)-  , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    (typeSignatureDo $ Just "Eq a")-    (typeSignatureDo Nothing)-  , check-    "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`"-    (typeSignatureSpaces $ Just "Monoid a, Show a")-    (typeSignatureSpaces Nothing)-    , check-    "Remove redundant constraint `Eq a` from the context of the type signature for `foo`"-    typeSignatureLined1-    typeSignatureOneLine-    , check-    "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`"-    typeSignatureLined2-    typeSignatureOneLine-    , check-    "Remove redundant constraint `Show a` from the context of the type signature for `foo`"-    typeSignatureLined3-    typeSignatureLined3'-  ]--addSigActionTests :: TestTree-addSigActionTests = let-  header = [ "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"-           , "{-# LANGUAGE PatternSynonyms,BangPatterns,GADTs #-}"-           , "module Sigs where"-           , "data T1 a where"-           , "  MkT1 :: (Show b) => a -> b -> T1 a"-           ]-  before def     = T.unlines $ header ++ [def]-  after' def sig = T.unlines $ header ++ [sig, def]--  def >:: sig = testSession (T.unpack $ T.replace "\n" "\\n" def) $ do-    let originalCode = before def-    let expectedCode = after' def sig-    doc <- createDoc "Sigs.hs" "haskell" originalCode-    _ <- waitForDiagnostics-    actionsOrCommands <- getCodeActions doc (Range (Position 5 1) (Position 5 maxBound))-    chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands-    executeCodeAction chosenAction-    modifiedCode <- documentContents doc-    liftIO $ expectedCode @=? modifiedCode-  in-  testGroup "add signature"-    [ "abc = True"              >:: "abc :: Bool"-    , "foo a b = a + b"         >:: "foo :: Num a => a -> a -> a"-    , "bar a b = show $ a + b"  >:: "bar :: (Show a, Num a) => a -> a -> String"-    , "(!!!) a b = a > b"       >:: "(!!!) :: Ord a => a -> a -> Bool"-    , "a >>>> b = a + b"        >:: "(>>>>) :: Num a => a -> a -> a"-    , "a `haha` b = a b"        >:: "haha :: (t1 -> t2) -> t1 -> t2"-    , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"-    , "pattern Some a <- Just a" >:: "pattern Some :: a -> Maybe a"-    , "pattern Some a <- Just a\n  where Some a = Just a" >:: "pattern Some :: a -> Maybe a"-    , "pattern Some a <- Just !a\n  where Some !a = Just a" >:: "pattern Some :: a -> Maybe a"-    , "pattern Point{x, y} = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"-    , "pattern Point{x, y} <- (x, y)" >:: "pattern Point :: a -> b -> (a, b)"-    , "pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)" >:: "pattern Point :: a -> b -> (a, b)"-    , "pattern MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"-    , "pattern MkT1' b <- MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"-    , "pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b" >:: "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a"-    ]--exportUnusedTests :: TestTree-exportUnusedTests = testGroup "export unused actions"-  [ testGroup "don't want suggestion"-    [ testSession "implicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# OPTIONS_GHC -Wmissing-signatures #-}"-              , "module A where"-              , "foo = id"])-        (R 3 0 3 3)-        "Export ‘foo’"-        Nothing -- codeaction should not be available-    , testSession "not top-level" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# OPTIONS_GHC -Wunused-binds #-}"-              , "module A (foo,bar) where"-              , "foo = ()"-              , "  where bar = ()"-              , "bar = ()"])-        (R 2 0 2 11)-        "Export ‘bar’"-        Nothing-    , ignoreForGHC92 "Diagnostic message has no suggestions" $-      testSession "type is exported but not the constructor of same name" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo) where"-              , "data Foo = Foo"])-        (R 2 0 2 8)-        "Export ‘Foo’"-        Nothing -- codeaction should not be available-    , testSession "unused data field" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(Foo)) where"-              , "data Foo = Foo {foo :: ()}"])-        (R 2 0 2 20)-        "Export ‘foo’"-        Nothing -- codeaction should not be available-    ]-  , testGroup "want suggestion"-    [ testSession "empty exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ("-              , ") where"-              , "foo = id"])-        (R 3 0 3 3)-        "Export ‘foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ("-              , "foo) where"-              , "foo = id"])-    , testSession "single line explicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (foo) where"-              , "foo = id"-              , "bar = foo"])-        (R 3 0 3 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (foo, bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "multi line explicit exports" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  ("-              , "    foo) where"-              , "foo = id"-              , "bar = foo"])-        (R 5 0 5 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  ("-              , "    foo, bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "export list ends in comma" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  (foo,"-              , "  ) where"-              , "foo = id"-              , "bar = foo"])-        (R 5 0 5 3)-        "Export ‘bar’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A"-              , "  (foo,"-              , "  bar) where"-              , "foo = id"-              , "bar = foo"])-    , testSession "unused pattern synonym" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE PatternSynonyms #-}"-              , "module A () where"-              , "pattern Foo a <- (a, _)"])-        (R 3 0 3 10)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE PatternSynonyms #-}"-              , "module A (pattern Foo) where"-              , "pattern Foo a <- (a, _)"])-    , testSession "unused data type" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "data Foo = Foo"])-        (R 2 0 2 7)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "data Foo = Foo"])-    , testSession "unused newtype" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "newtype Foo = Foo ()"])-        (R 2 0 2 10)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "newtype Foo = Foo ()"])-    , testSession "unused type synonym" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "type Foo = ()"])-        (R 2 0 2 7)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo) where"-              , "type Foo = ()"])-    , testSession "unused type family" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "module A () where"-              , "type family Foo p"])-        (R 3 0 3 15)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "module A (Foo) where"-              , "type family Foo p"])-    , testSession "unused typeclass" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "class Foo a"])-        (R 2 0 2 8)-        "Export ‘Foo’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (Foo(..)) where"-              , "class Foo a"])-    , testSession "infix" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "a `f` b = ()"])-        (R 2 0 2 11)-        "Export ‘f’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A (f) where"-              , "a `f` b = ()"])-    , testSession "function operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A () where"-              , "(<|) = ($)"])-        (R 2 0 2 9)-        "Export ‘<|’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "module A ((<|)) where"-              , "(<|) = ($)"])-    , testSession "type synonym operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "type (:<) = ()"])-        (R 3 0 3 13)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A ((:<)) where"-              , "type (:<) = ()"])-    , testSession "type family operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "type family (:<)"])-        (R 4 0 4 15)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeFamilies #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)) where"-              , "type family (:<)"])-    , testSession "typeclass operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "class (:<) a"])-        (R 3 0 3 11)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "class (:<) a"])-    , testSession "newtype operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "newtype (:<) = Foo ()"])-        (R 3 0 3 20)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "newtype (:<) = Foo ()"])-    , testSession "data type operator" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A () where"-              , "data (:<) = Foo ()"])-        (R 3 0 3 17)-        "Export ‘:<’"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wunused-top-binds #-}"-              , "{-# LANGUAGE TypeOperators #-}"-              , "module A (type (:<)(..)) where"-              , "data (:<) = Foo ()"])-    ]-  ]-  where-    template doc range = exportTemplate (Just range) doc--exportTemplate :: Maybe Range -> T.Text -> T.Text -> Maybe T.Text -> Session ()-exportTemplate mRange initialContent expectedAction expectedContents = do-  doc <- createDoc "A.hs" "haskell" initialContent-  _ <- waitForDiagnostics-  actions <- case mRange of-    Nothing    -> getAllCodeActions doc-    Just range -> getCodeActions doc range-  case expectedContents of-    Just content -> do-      action <- liftIO $ pickActionWithTitle expectedAction actions-      executeCodeAction action-      contentAfterAction <- documentContents doc-      liftIO $ content @=? contentAfterAction-    Nothing ->-      liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= []--removeExportTests :: TestTree-removeExportTests = testGroup "remove export actions"-    [ testSession "single export" $ template-        (T.unlines-              [ "module A (  a   ) where"-              , "b :: ()"-              , "b = ()"])-        "Remove ‘a’ from export"-        (Just $ T.unlines-              [ "module A (     ) where"-              , "b :: ()"-              , "b = ()"])-    , testSession "ending comma" $ template-        (T.unlines-              [ "module A (  a,   ) where"-              , "b :: ()"-              , "b = ()"])-        "Remove ‘a’ from export"-        (Just $ T.unlines-              [ "module A (  ) where"-              , "b :: ()"-              , "b = ()"])-    , testSession "multiple exports" $ template-        (T.unlines-              [ "module A (a  ,   c,    b ) where"-              , "a, c :: ()"-              , "a = ()"-              , "c = ()"])-        "Remove ‘b’ from export"-        (Just $ T.unlines-              [ "module A (a  ,   c ) where"-              , "a, c :: ()"-              , "a = ()"-              , "c = ()"])-    , testSession "not in scope constructor" $ template-        (T.unlines-              [ "module A (A (X,Y,Z,(:<)), ab) where"-              , "data A = X Int | Y | (:<) Int"-              , "ab :: ()"-              , "ab = ()"-              ])-        "Remove ‘Z’ from export"-        (Just $ T.unlines-              [ "module A (A (X,Y,(:<)), ab) where"-              , "data A = X Int | Y | (:<) Int"-              , "ab :: ()"-              , "ab = ()"])-    , testSession "multiline export" $ template-        (T.unlines-              [ "module A (a"-              , " ,  b"-              , " , (:*:)"-              , " , ) where"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-        "Remove ‘:*:’ from export"-        (Just $ T.unlines-              [ "module A (a"-              , " ,  b"-              , " "-              , " , ) where"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-    , testSession "qualified re-export" $ template-        (T.unlines-              [ "module A (M.x,a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘M.x’ from export"-        (Just $ T.unlines-              [ "module A (a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-    , testSession "qualified re-export ending in '.'" $ template-        (T.unlines-              [ "module A ((M.@.),a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘M.@.’ from export"-        (Just $ T.unlines-              [ "module A (a) where"-              , "import qualified Data.List as M"-              , "a :: ()"-              , "a = ()"])-    , testSession "export module" $ template-        (T.unlines-              [ "module A (module B) where"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘module B’ from export"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "dodgy export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (A (..)) where"-              , "data X = X"-              , "type A = X"])-        "Remove ‘A(..)’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A () where"-              , "data X = X"-              , "type A = X"])-    , testSession "dodgy export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (A (..)) where"-              , "data X = X"-              , "type A = X"])-        "Remove ‘A(..)’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A () where"-              , "data X = X"-              , "type A = X"])-    , testSession "duplicate module export" $ template-        (T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (module L,module L) where"-              , "import Data.List as L"-              , "a :: ()"-              , "a = ()"])-        "Remove ‘Module L’ from export"-        (Just $ T.unlines-              [ "{-# OPTIONS_GHC -Wall #-}"-              , "module A (module L) where"-              , "import Data.List as L"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports single" $ template-        (T.unlines-              [ "module A (x) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports two" $ template-        (T.unlines-              [ "module A (x,y) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A () where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports three" $ template-        (T.unlines-              [ "module A (a,x,y) where"-              , "a :: ()"-              , "a = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A (a) where"-              , "a :: ()"-              , "a = ()"])-    , testSession "remove all exports composite" $ template-        (T.unlines-              [ "module A (x,y,b, module Ls, a, A(X,getW, Y, Z,(:-),getV), (-+), B(B)) where"-              , "data A = X {getV :: Int} | Y {getV :: Int}"-              , "data B = B"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-        "Remove all redundant exports"-        (Just $ T.unlines-              [ "module A (b, a, A(X, Y,getV), B(B)) where"-              , "data A = X {getV :: Int} | Y {getV :: Int}"-              , "data B = B"-              , "a,b :: ()"-              , "a = ()"-              , "b = ()"])-    ]-  where-    template = exportTemplate Nothing--addSigLensesTests :: TestTree-addSigLensesTests =-  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"-      moduleH exported =-        T.unlines-          [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"-          , "module Sigs(" <> exported <> ") where"-          , "import qualified Data.Complex as C"-          , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"-          , "data T1 a where"-          , "  MkT1 :: (Show b) => a -> b -> T1 a"-          ]-      before enableGHCWarnings exported (def, _) others =-        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others-      after' enableGHCWarnings exported (def, sig) others =-        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others-      createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]]-      sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do-        let originalCode = before enableGHCWarnings exported def others-        let expectedCode = after' enableGHCWarnings exported def others-        sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode-        doc <- createDoc "Sigs.hs" "haskell" originalCode-        waitForProgressDone-        codeLenses <- getCodeLenses doc-        if not $ null $ snd def-          then do-            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses-            executeCommand $ fromJust $ head codeLenses ^. L.command-            modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)-            liftIO $ expectedCode @=? modifiedCode-          else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses-      cases =-        [ ("abc = True", "abc :: Bool")-        , ("foo a b = a + b", "foo :: Num a => a -> a -> a")-        , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String")-        , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool")-        , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")-        , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")-        , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just a\n  where Some a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Some a <- Just !a\n  where Some !a = Just a", "pattern Some :: a -> Maybe a")-        , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")-        , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")-        , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")-        , ("head = 233", "head :: Integer")-        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")-        , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")-        , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing")-        , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a")-        , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")-        ]-   in testGroup-        "add signature"-        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]-        , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)-        , testGroup-            "diagnostics mode works"-            [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []-            , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []-            ]-        ]--linkToLocation :: [LocationLink] -> [Location]-linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange)--checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session ()-checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where-  check (ExpectRange expectedRange) = do-    assertNDefinitionsFound 1 defs-    assertRangeCorrect (head defs) expectedRange-  check (ExpectLocation expectedLocation) = do-    assertNDefinitionsFound 1 defs-    liftIO $ do-      canonActualLoc <- canonicalizeLocation (head defs)-      canonExpectedLoc <- canonicalizeLocation expectedLocation-      canonActualLoc @?= canonExpectedLoc-  check ExpectNoDefinitions = do-    assertNDefinitionsFound 0 defs-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"-  check _ = pure () -- all other expectations not relevant to getDefinition--  assertNDefinitionsFound :: Int -> [a] -> Session ()-  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)--  assertRangeCorrect Location{_range = foundRange} expectedRange =-    liftIO $ expectedRange @=? foundRange--canonicalizeLocation :: Location -> IO Location-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range--findDefinitionAndHoverTests :: TestTree-findDefinitionAndHoverTests = let--  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree-  tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do--    -- Dirty the cache to check that definitions work even in the presence of iface files-    liftIO $ runInDir dir $ do-      let fooPath = dir </> "Foo.hs"-      fooSource <- liftIO $ readFileUtf8 fooPath-      fooDoc <- createDoc fooPath "haskell" fooSource-      _ <- getHover fooDoc $ Position 4 3-      closeDoc fooDoc--    doc <- openTestDataDoc (dir </> sourceFilePath)-    waitForProgressDone-    found <- get doc pos-    check found targetRange----  checkHover :: Maybe Hover -> Session [Expect] -> Session ()-  checkHover hover expectations = traverse_ check =<< expectations where--    check expected =-      case hover of-        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"-        Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg})-                  ,_range    = rangeInHover } ->-          case expected of-            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg-            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets-            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover-            _ -> pure () -- all other expectations not relevant to hover-        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover--  extractLineColFromHoverMsg :: T.Text -> [T.Text]-  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")--  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()-  checkHoverRange expectedRange rangeInHover msg =-    let-      lineCol = extractLineColFromHoverMsg msg-      -- looks like hovers use 1-based numbering while definitions use 0-based-      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.-      adjust Position{_line = l, _character = c} =-        Position{_line = l + 1, _character = c + 1}-    in-    case map (read . T.unpack) lineCol of-      [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c-      _     -> liftIO $ assertFailure $-        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>-        "\n but got: " <> show (msg, rangeInHover)--  assertFoundIn :: T.Text -> T.Text -> Assertion-  assertFoundIn part whole = assertBool-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)-    (part `T.isInfixOf` whole)--  sourceFilePath = T.unpack sourceFileName-  sourceFileName = "GotoHover.hs"--  mkFindTests tests = testGroup "get"-    [ testGroup "definition" $ mapMaybe fst tests-    , testGroup "hover"      $ mapMaybe snd tests-    , checkFileCompiles sourceFilePath $-        expectDiagnostics-          [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")])-          , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")])-          ]-    , testGroup "type-definition" typeDefinitionTests ]--  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"-                        , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"]--  test runDef runHover look expect = testM runDef runHover look (return expect)--  testM runDef runHover look expect title =-    ( runDef   $ tst def   look expect title-    , runHover $ tst hover look expect title ) where-      def   = (getDefinitions, checkDefs)-      hover = (getHover      , checkHover)--  -- search locations            expectations on results-  fffL4  = _start fffR     ;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]-  fffL8  = Position 12  4  ;-  fffL14 = Position 18  7  ;-  aL20   = Position 19 15-  aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]-  dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]-  dcL12  = Position 16 11  ;-  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]-  tcL6   = Position 10 11  ;  tcData = [mkR   7  0    9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]-  vvL16  = Position 20 12  ;  vv     = [mkR  20  4   20  6]-  opL16  = Position 20 15  ;  op     = [mkR  21  2   21  4]-  opL18  = Position 22 22  ;  opp    = [mkR  22 13   22 17]-  aL18   = Position 22 20  ;  apmp   = [mkR  22 10   22 11]-  b'L19  = Position 23 13  ;  bp     = [mkR  23  6   23  7]-  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]-  clL23  = Position 27 11  ;  cls    = [mkR  25  0   26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]-  clL25  = Position 29  9-  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]]-  dnbL29 = Position 33 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  33 12   33 21]-  dnbL30 = Position 34 23-  lcbL33 = Position 37 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  37 26   37 27]-  lclL33 = Position 37 22-  mclL36 = Position 40  1  ;  mcl    = [mkR  40  0   40 14]-  mclL37 = Position 41  1-  spaceL37 = Position 41  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]-  docL41 = Position 45  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]-                           ;  constr = [ExpectHoverText ["Monad m"]]-  eitL40 = Position 44 28  ;  kindE  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]]-  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]]-  tvrL40 = Position 44 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]-  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["7518"]]-  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["'f'"]]-  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]-  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]-  outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5]-  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]-  holeL60 = Position 62 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]-  holeL65 = Position 65 8  ;  hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]-  cccL17 = Position 17 16  ;  docLink = [ExpectHoverText ["[Documentation](file:///"]]-  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]-  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]-  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]-  in-  mkFindTests-  --      def    hover  look       expect-  [-    if ghcVersion >= GHC90 then-        -- It suggests either going to the constructor or to the field-        test  broken yes    fffL4      fff           "field in record definition"-    else-        test  yes    yes    fffL4      fff           "field in record definition"-  , test  yes    yes    fffL8      fff           "field in record construction    #1102"-  , test  yes    yes    fffL14     fff           "field name used as accessor"           -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs-  , test  yes    yes    aaaL14     aaa           "top-level name"                        -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    dcL7       tcDC          "data constructor record         #1029"-  , test  yes    yes    dcL12      tcDC          "data constructor plain"                -- https://github.com/haskell/ghcide/pull/121-  , test  yes    yes    tcL6       tcData        "type constructor                #1028" -- https://github.com/haskell/ghcide/pull/147-  , test  broken yes    xtcL5      xtc           "type constructor external   #717,1028"-  , test  broken yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    vvL16      vv            "plain parameter"                       -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    aL18       apmp          "pattern match name"                    -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    opL16      op            "top-level operator               #713" -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    opL18      opp           "parameter operator"                    -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    b'L19      bp            "name in backticks"                     -- https://github.com/haskell/ghcide/pull/120-  , test  yes    yes    clL23      cls           "class in instance declaration   #1027"-  , test  yes    yes    clL25      cls           "class in signature              #1027" -- https://github.com/haskell/ghcide/pull/147-  , test  broken yes    eclL15     ecls          "external class in signature #717,1027"-  , test  yes    yes    dnbL29     dnb           "do-notation   bind              #1073"-  , test  yes    yes    dnbL30     dnb           "do-notation lookup"-  , test  yes    yes    lcbL33     lcb           "listcomp   bind                 #1073"-  , test  yes    yes    lclL33     lcb           "listcomp lookup"-  , test  yes    yes    mclL36     mcl           "top-level fn 1st clause"-  , test  yes    yes    mclL37     mcl           "top-level fn 2nd clause         #1030"-  , if ghcVersion >= GHC810 then-        test  yes    yes    spaceL37   space         "top-level fn on space           #1002"-    else-        test  yes    broken spaceL37   space         "top-level fn on space           #1002"-  , test  no     yes    docL41     doc           "documentation                   #1129"-  , test  no     yes    eitL40     kindE         "kind of Either                  #1017"-  , test  no     yes    intL40     kindI         "kind of Int                     #1017"-  , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #1017"-  , test  no     broken intL41     litI          "literal Int  in hover info      #1016"-  , test  no     broken chrL36     litC          "literal Char in hover info      #1016"-  , test  no     broken txtL8      litT          "literal Text in hover info      #1016"-  , test  no     broken lstL43     litL          "literal List in hover info      #1016"-  , if ghcVersion >= GHC90 then-        test  no     yes    docL41     constr        "type constraint in hover info   #1012"-    else-        test  no     broken docL41     constr        "type constraint in hover info   #1012"-  , test  no     yes    outL45     outSig        "top-level signature              #767"-  , test  broken broken innL48     innSig        "inner     signature              #767"-  , test  no     yes    holeL60    hleInfo       "hole without internal name       #831"-  , test  no     yes    holeL65    hleInfo2      "hole with variable"-  , test  no     skip   cccL17     docLink       "Haddock html links"-  , testM yes    yes    imported   importedSig   "Imported symbol"-  , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"-  , if | ghcVersion == GHC90 && isWindows ->-        test  no     broken    thLocL57   thLoc         "TH Splice Hover"-       | ghcVersion == GHC92 && (isWindows || isMac) ->-           -- Some GHC 9.2 distributions ship without .hi docs-           -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-        test  no     broken   thLocL57   thLoc         "TH Splice Hover"-       | otherwise ->-        test  no     yes       thLocL57   thLoc         "TH Splice Hover"-  ]-  where yes, broken :: (TestTree -> Maybe TestTree)-        yes    = Just -- test should run and pass-        broken = Just . (`xfail` "known broken")-        no = const Nothing -- don't run this test at all-        skip = const Nothing -- unreliable, don't run--checkFileCompiles :: FilePath -> Session () -> TestTree-checkFileCompiles fp diag =-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do-    void (openTestDataDoc (dir </> fp))-    diag--pluginSimpleTests :: TestTree-pluginSimpleTests =-  ignoreInWindowsForGHC88And810 $-  ignoreForGHC92 "blocked on ghc-typelits-natnormalise" $-  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do-    _ <- openDoc (dir </> "KnownNat.hs") "haskell"-    liftIO $ writeFile (dir</>"hie.yaml")-      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"--    expectDiagnostics-      [ ( "KnownNat.hs",-          [(DsError, (9, 15), "Variable not in scope: c")]-          )-      ]--pluginParsedResultTests :: TestTree-pluginParsedResultTests =-  ignoreInWindowsForGHC88And810 $-  ignoreForGHC92 "No need for this plugin anymore!" $-  testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do-    _ <- openDoc (dir</> "RecordDot.hs") "haskell"-    expectNoMoreDiagnostics 2--cppTests :: TestTree-cppTests =-  testGroup "cpp"-    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do-        let content =-              T.unlines-                [ "{-# LANGUAGE CPP #-}",-                  "module Testing where",-                  "#ifdef FOO",-                  "foo = 42"-                ]-        -- The error locations differ depending on which C-preprocessor is used.-        -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either-        -- of them.-        (run $ expectError content (2, maxBound))-          `catch` ( \e -> do-                      let _ = e :: HUnitFailure-                      run $ expectError content (2, 1)-                  )-    , testSessionWait "cpp-ghcide" $ do-        _ <- createDoc "A.hs" "haskell" $ T.unlines-          ["{-# LANGUAGE CPP #-}"-          ,"main ="-          ,"#ifdef __GHCIDE__"-          ,"  worked"-          ,"#else"-          ,"  failed"-          ,"#endif"-          ]-        expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]-    ]-  where-    expectError :: T.Text -> Cursor -> Session ()-    expectError content cursor = do-      _ <- createDoc "Testing.hs" "haskell" content-      expectDiagnostics-        [ ( "Testing.hs",-            [(DsError, cursor, "error: unterminated")]-          )-        ]-      expectNoMoreDiagnostics 0.5--preprocessorTests :: TestTree-preprocessorTests = testSessionWait "preprocessor" $ do-  let content =-        T.unlines-          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"-          , "module Testing where"-          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic-          ]-  _ <- createDoc "Testing.hs" "haskell" content-  expectDiagnostics-    [ ( "Testing.hs",-        [(DsError, (2, 8), "Variable not in scope: z")]-      )-    ]---safeTests :: TestTree-safeTests =-  testGroup-    "SafeHaskell"-    [ -- Test for https://github.com/haskell/ghcide/issues/424-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                ["{-# LANGUAGE Trustworthy #-}"-                ,"module A where"-                ,"import System.IO.Unsafe"-                ,"import System.IO ()"-                ,"trustWorthyId :: a -> a"-                ,"trustWorthyId i = unsafePerformIO $ do"-                ,"  putStrLn \"I'm safe\""-                ,"  return i"]-            sourceB =-              T.unlines-                ["{-# LANGUAGE Safe #-}"-                ,"module B where"-                ,"import A"-                ,"safeId :: a -> a"-                ,"safeId = trustWorthyId"-                ]--        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectNoMoreDiagnostics 1 ]--thTests :: TestTree-thTests =-  testGroup-    "TemplateHaskell"-    [ -- Test for https://github.com/haskell/ghcide/pull/212-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module A where",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "a :: Integer",-                  "a = $(litE $ IntegerL 3)"-                ]-            sourceB =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module B where",-                  "import A",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "b :: Integer",-                  "b = $(litE $ IntegerL $ a) + n"-                ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]-    , testSessionWait "newtype-closure" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE DeriveDataTypeable #-}"-                  ,"{-# LANGUAGE TemplateHaskell #-}"-                  ,"module A (a) where"-                  ,"import Data.Data"-                  ,"import Language.Haskell.TH"-                  ,"newtype A = A () deriving (Data)"-                  ,"a :: ExpQ"-                  ,"a = [| 0 |]"]-        let sourceB =-              T.unlines-                [ "{-# LANGUAGE TemplateHaskell #-}"-                ,"module B where"-                ,"import A"-                ,"b :: Int"-                ,"b = $( a )" ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        return ()-    , thReloadingTest False-    , thLoadingTest-    , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True-    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891-    , thLinkingTest False-    , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True-    , testSessionWait "findsTHIdentifiers" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE TemplateHaskell #-}"-                , "module A (a) where"-                , "import Language.Haskell.TH (ExpQ)"-                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic-                , "a = [| glorifiedID |]"-                , "glorifiedID :: a -> a"-                , "glorifiedID = id" ]-        let sourceB =-              T.unlines-                [ "{-# OPTIONS_GHC -Wall #-}"-                , "{-# LANGUAGE TemplateHaskell #-}"-                , "module B where"-                , "import A"-                , "main = $a (putStrLn \"success!\")"]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]-    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do--    -- This test defines a TH value with the meaning "data A = A" in A.hs-    -- Loads and export the template in B.hs-    -- And checks wether the constructor A can be loaded in C.hs-    -- This test does not fail when either A and B get manually loaded before C.hs-    -- or when we remove the seemingly unnecessary TH pragma from C.hs--    let cPath = dir </> "C.hs"-    _ <- openDoc cPath "haskell"-    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]-    ]---- | Tests for projects that use symbolic links one way or another-symlinkTests :: TestTree-symlinkTests =-  testGroup "Projects using Symlinks"-    [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do-        liftIO $ createFileLink (dir </> "some_loc" </> "Sym.hs") (dir </> "other_loc" </> "Sym.hs")-        let fooPath = dir </> "src" </> "Foo.hs"-        _ <- openDoc fooPath "haskell"-        expectDiagnosticsWithTags  [("src" </> "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])]-        pure ()-    ]---- | Test that all modules have linkables-thLoadingTest :: TestTree-thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do-    let thb = dir </> "THB.hs"-    _ <- openDoc thb "haskell"-    expectNoMoreDiagnostics 1---- | test that TH is reevaluated on typecheck-thReloadingTest :: Bool -> TestTree-thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do--    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]-    bSource <- liftIO $ readFileUtf8 bPath --  $th-    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()--    adoc <- createDoc aPath "haskell" aSource-    bdoc <- createDoc bPath "haskell" bSource-    cdoc <- createDoc cPath "haskell" cSource--    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]--    -- Change th from () to Bool-    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']-    -- generate an artificial warning to avoid timing out if the TH change does not propagate-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]--    -- Check that the change propagates to C-    expectDiagnostics-        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])-        ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")])-        ]--    closeDoc adoc-    closeDoc bdoc-    closeDoc cdoc-  where-    name = "reloading-th-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"--thLinkingTest :: Bool -> TestTree-thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do--    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"--    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]-    bSource <- liftIO $ readFileUtf8 bPath --  $th_a--    adoc <- createDoc aPath "haskell" aSource-    bdoc <- createDoc bPath "haskell" bSource--    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]--    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']--    -- modify b too-    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']-    waitForProgressBegin-    waitForAllProgressDone--    expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")]--    closeDoc adoc-    closeDoc bdoc-  where-    name = "th-linking-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"--completionTests :: TestTree-completionTests-  = testGroup "completion"-    [-    testGroup "non local" nonLocalCompletionTests-    , testGroup "topLevel" topLevelCompletionTests-    , testGroup "local" localCompletionTests-    , testGroup "package" packageCompletionTests-    , testGroup "project" projectCompletionTests-    , testGroup "other" otherCompletionTests-    , testGroup "doc" completionDocTests-    ]--completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree-completionTest name src pos expected = testSessionWait name $ do-    docId <- createDoc "A.hs" "haskell" (T.unlines src)-    _ <- waitForDiagnostics-    compls <- getCompletions docId pos-    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]-    liftIO $ do-        let emptyToMaybe x = if T.null x then Nothing else Just x-        sortOn (Lens.view Lens._1) (take (length expected) compls') @?=-            sortOn (Lens.view Lens._1)-              [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected]-        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do-            when expectedSig $-                assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)-            when expectedDocs $-                assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)--completionCommandTest ::-  String ->-  [T.Text] ->-  Position ->-  T.Text ->-  [T.Text] ->-  TestTree-completionCommandTest name src pos wanted expected = testSession name $ do-  docId <- createDoc "A.hs" "haskell" (T.unlines src)-  _ <- waitForDiagnostics-  compls <- skipManyTill anyMessage (getCompletions docId pos)-  let wantedC = find ( \case-            CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x-            _                                     -> False-            ) compls-  case wantedC of-    Nothing ->-      liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]-    Just CompletionItem {..} -> do-      c <- assertJust "Expected a command" _command-      executeCommand c-      if src /= expected-          then do-            void $ skipManyTill anyMessage loggingNotification-            modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId)-            liftIO $ modifiedCode @?= T.unlines expected-          else do-            expectMessages SWorkspaceApplyEdit 1 $ \edit ->-              liftIO $ assertFailure $ "Expected no edit but got: " <> show edit--completionNoCommandTest ::-  String ->-  [T.Text] ->-  Position ->-  T.Text ->-  TestTree-completionNoCommandTest name src pos wanted = testSession name $ do-  docId <- createDoc "A.hs" "haskell" (T.unlines src)-  _ <- waitForDiagnostics-  compls <- getCompletions docId pos-  let wantedC = find ( \case-            CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x-            _                                     -> False-            ) compls-  case wantedC of-    Nothing ->-      liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]-    Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command---topLevelCompletionTests :: [TestTree]-topLevelCompletionTests = [-    completionTest-        "variable"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)-        ],-    completionTest-        "constructor"-        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)-        ],-    completionTest-        "class method"-        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]-        (Position 0 8)-        [("xxx", CiFunction, "xxx", True, True, Nothing)],-    completionTest-        "type"-        ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]-        (Position 0 9)-        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],-    completionTest-        "class"-        ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]-        (Position 0 9)-        [("Xxx", CiInterface, "Xxx", False, True, Nothing)],-    completionTest-        "records"-        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]-        (Position 1 19)-        [("_personName", CiFunction, "_personName", False, True, Nothing),-         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],-    completionTest-        "recordsConstructor"-        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]-        (Position 1 19)-        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),-         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]-    ]--localCompletionTests :: [TestTree]-localCompletionTests = [-    completionTest-        "argument"-        ["bar (Just abcdef) abcdefg = abcd"]-        (Position 0 32)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "let"-        ["bar = let (Just abcdef) = undefined"-        ,"          abcdefg = let abcd = undefined in undefined"-        ,"        in abcd"-        ]-        (Position 2 15)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "where"-        ["bar = abcd"-        ,"  where (Just abcdef) = undefined"-        ,"        abcdefg = let abcd = undefined in undefined"-        ]-        (Position 0 10)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing),-         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)-        ],-    completionTest-        "do/1"-        ["bar = do"-        ,"  Just abcdef <- undefined"-        ,"  abcd"-        ,"  abcdefg <- undefined"-        ,"  pure ()"-        ]-        (Position 2 6)-        [("abcdef", CiFunction, "abcdef", True, False, Nothing)-        ],-    completionTest-        "do/2"-        ["bar abcde = do"-        ,"    Just [(abcdef,_)] <- undefined"-        ,"    abcdefg <- undefined"-        ,"    let abcdefgh = undefined"-        ,"        (Just [abcdefghi]) = undefined"-        ,"    abcd"-        ,"  where"-        ,"    abcdefghij = undefined"-        ]-        (Position 5 8)-        [("abcde", CiFunction, "abcde", True, False, Nothing)-        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)-        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)-        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)-        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)-        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)-        ],-    completionTest-        "type family"-        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"-        ,"type family Bar a"-        ,"a :: Ba"-        ]-        (Position 2 7)-        [("Bar", CiStruct, "Bar", True, False, Nothing)-        ],-    completionTest-        "class method"-        [-          "class Test a where"-        , "    abcd :: a -> ()"-        , "    abcde :: a -> Int"-        , "instance Test Int where"-        , "    abcd = abc"-        ]-        (Position 4 14)-        [("abcd", CiFunction, "abcd", True, False, Nothing)-        ,("abcde", CiFunction, "abcde", True, False, Nothing)-        ],-    testSessionWait "incomplete entries" $ do-        let src a = "data Data = " <> a-        doc <- createDoc "A.hs" "haskell" $ src "AAA"-        void $ waitForTypecheck doc-        let editA rhs =-                changeDoc doc [TextDocumentContentChangeEvent-                    { _range=Nothing-                    , _rangeLength=Nothing-                    , _text=src rhs}]--        editA "AAAA"-        void $ waitForTypecheck doc-        editA "AAAAA"-        void $ waitForTypecheck doc--        compls <- getCompletions doc (Position 0 15)-        liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]-        pure ()-    ]--nonLocalCompletionTests :: [TestTree]-nonLocalCompletionTests =-  [ completionTest-      "variable"-      ["module A where", "f = hea"]-      (Position 1 7)-      [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)],-    completionTest-      "constructor"-      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]-      (Position 2 8)-      [ ("True", CiConstructor, "True", True, True, Nothing)-      ],-    completionTest-      "type"-      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]-      (Position 2 8)-      [ ("Bool", CiStruct, "Bool", True, True, Nothing)-      ],-    completionTest-      "qualified"-      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]-      (Position 2 15)-      [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing)-      ],-    completionTest-      "duplicate import"-      ["module A where", "import Data.List", "import Data.List", "f = permu"]-      (Position 3 9)-      [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing)-      ],-    completionTest-       "dont show hidden items"-       [ "{-# LANGUAGE NoImplicitPrelude #-}",-         "module A where",-         "import Control.Monad hiding (join)",-         "f = joi"-       ]-       (Position 3 6)-       [],-    testGroup "ordering"-      [completionTest "qualified has priority"-        ["module A where"-        ,"import qualified Data.ByteString as BS"-        ,"f = BS.read"-        ]-        (Position 2 10)-        [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)]-        ],-    testGroup "auto import snippets"-      [ completionCommandTest-        "show imports not in list - simple"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (msum)", "f = joi"]-        (Position 3 6)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (msum, join)", "f = joi"]-      , completionCommandTest-        "show imports not in list - multi-line"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (\n    msum)", "f = joi"]-        (Position 4 6)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad (\n    msum, join)", "f = joi"]-      , completionCommandTest-        "show imports not in list - names with _"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (msum)", "f = M.mapM_"]-        (Position 3 11)-        "mapM_"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (msum, mapM_)", "f = M.mapM_"]-      , completionCommandTest-        "show imports not in list - initial empty list"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M ()", "f = M.joi"]-        (Position 3 10)-        "join"-        ["{-# LANGUAGE NoImplicitPrelude #-}",-        "module A where", "import Control.Monad as M (join)", "f = M.joi"]-      , testGroup "qualified imports"-        [ completionCommandTest-            "single"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad ()", "f = Control.Monad.joi"]-            (Position 3 22)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad (join)", "f = Control.Monad.joi"]-        , completionCommandTest-            "as"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "f = M.joi"]-            (Position 3 10)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M (join)", "f = M.joi"]-        , completionCommandTest-            "multiple"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "import Control.Monad as N ()", "f = N.joi"]-            (Position 4 10)-            "join"-            ["{-# LANGUAGE NoImplicitPrelude #-}",-            "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"]-        ]-      , testGroup "Data constructor"-        [ completionCommandTest-            "not imported"-            ["module A where", "import Text.Printf ()", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-        , completionCommandTest-            "parent imported abs"-            ["module A where", "import Text.Printf (FormatAdjustment)", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-        , completionNoCommandTest-            "parent imported all"-            ["module A where", "import Text.Printf (FormatAdjustment (..))", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-        , completionNoCommandTest-            "already imported"-            ["module A where", "import Text.Printf (FormatAdjustment (ZeroPad))", "ZeroPad"]-            (Position 2 4)-            "ZeroPad"-        , completionNoCommandTest-            "function from Prelude"-            ["module A where", "import Data.Maybe ()", "Nothing"]-            (Position 2 4)-            "Nothing"-        , completionCommandTest-            "type operator parent"-            ["module A where", "import Data.Type.Equality ()", "f = Ref"]-            (Position 2 8)-            "Refl"-            ["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"]-        ]-      , testGroup "Record completion"-        [ completionCommandTest-            "not imported"-            ["module A where", "import Text.Printf ()", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-        , completionCommandTest-            "parent imported"-            ["module A where", "import Text.Printf (FormatParse)", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-        , completionNoCommandTest-            "already imported"-            ["module A where", "import Text.Printf (FormatParse (FormatParse))", "FormatParse"]-            (Position 2 10)-            "FormatParse {"-        ]-      ],-      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls-     completionTest-      "do not show pragma completions"-      [ "{-# LANGUAGE  ",-        "{module A where}",-        "main = return ()"-      ]-      (Position 0 13)-      []-  ]--otherCompletionTests :: [TestTree]-otherCompletionTests = [-    completionTest-      "keyword"-      ["module A where", "f = newty"]-      (Position 1 9)-      [("newtype", CiKeyword, "", False, False, Nothing)],-    completionTest-      "type context"-      [ "{-# OPTIONS_GHC -Wunused-binds #-}",-        "module A () where",-        "f = f",-        "g :: Intege"-      ]-      -- At this point the module parses but does not typecheck.-      -- This should be sufficient to detect that we are in a-      -- type context and only show the completion to the type.-      (Position 3 11)-      [("Integer", CiStruct, "Integer", True, True, Nothing)],--    testSession "duplicate record fields" $ do-      void $-        createDoc "B.hs" "haskell" $-          T.unlines-            [ "{-# LANGUAGE DuplicateRecordFields #-}",-              "module B where",-              "newtype Foo = Foo { member :: () }",-              "newtype Bar = Bar { member :: () }"-            ]-      docA <--        createDoc "A.hs" "haskell" $-          T.unlines-            [ "module A where",-              "import B",-              "memb"-            ]-      _ <- waitForDiagnostics-      compls <- getCompletions docA $ Position 2 4-      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]-      liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"],--    testSessionWait "maxCompletions" $ do-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "a = Prelude."-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions  doc (Position 3 13)-        liftIO $ length compls @?= maxCompletions def-  ]--packageCompletionTests :: [TestTree]-packageCompletionTests =-  [ testSession' "fromList" $ \dir -> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 2 12)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}-                <- compls-              , _label == "fromList"-              ]-        liftIO $ take 3 (sort compls') @?=-          map ("Defined in "<>)-              [ "'Data.List.NonEmpty"-              , "'GHC.Exts"-              ]--  , testSessionWait "Map" $ do-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "a :: Map"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 2 7)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}-                <- compls-              , _label == "Map"-              ]-        liftIO $ take 3 (sort compls') @?=-          map ("Defined in "<>)-              [ "'Data.Map"-              , "'Data.Map.Lazy"-              , "'Data.Map.Strict"-              ]-  , testSessionWait "no duplicates" $ do-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "import GHC.Exts(fromList)",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 3 13)-        let duplicate =-              find-                (\case-                  CompletionItem-                    { _insertText = Just "fromList"-                    , _documentation =-                      Just (CompletionDocMarkup (MarkupContent MkMarkdown d))-                    } ->-                    "GHC.Exts" `T.isInfixOf` d-                  _ -> False-                ) compls-        liftIO $ duplicate @?= Nothing--  , testSessionWait "non-local before global" $ do-    -- non local completions are more specific-        doc <- createDoc "A.hs" "haskell" $ T.unlines-            [ "{-# OPTIONS_GHC -Wunused-binds #-}",-                "module A () where",-                "import GHC.Exts(fromList)",-                "a = fromList"-            ]-        _ <- waitForDiagnostics-        compls <- getCompletions doc (Position 3 13)-        let compls' =-              [_insertText-              | CompletionItem {_label, _insertText} <- compls-              , _label == "fromList"-              ]-        liftIO $ take 3 compls' @?=-          map Just ["fromList ${1:([Item l])}"]-  , testGroup "auto import snippets"-    [ completionCommandTest-            "import Data.Sequence"-            ["module A where", "foo :: Seq"]-            (Position 1 9)-            "Seq"-            ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"]--    , completionCommandTest-            "qualified import"-            ["module A where", "foo :: Seq.Seq"]-            (Position 1 13)-            "Seq"-            ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"]-    ]-  ]--projectCompletionTests :: [TestTree]-projectCompletionTests =-    [ testSession' "from hiedb" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        -- Note that B does not import A-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "b = anidenti"-            ]-        compls <- getCompletions doc (Position 1 10)-        let compls' =-              [T.drop 1 $ T.dropEnd 3 d-              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}-                <- compls-              , _label == "anidentifier"-              ]-        liftIO $ compls' @?= ["Defined in 'A"],-      testSession' "auto complete project imports" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"-        _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines-            [  "module ALocalModule (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        -- Note that B does not import A-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import ALocal"-            ]-        compls <- getCompletions doc (Position 1 13)-        let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls-        liftIO $ do-          item ^. Lens.label @?= "ALocalModule",-      testSession' "auto complete functions from qualified imports without alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import qualified A",-              "A."-            ]-        compls <- getCompletions doc (Position 2 2)-        let item = head compls-        liftIO $ do-          item ^. L.label @?= "anidentifier",-      testSession' "auto complete functions from qualified imports with alias" $ \dir-> do-        liftIO $ writeFile (dir </> "hie.yaml")-            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"-        _ <- createDoc "A.hs" "haskell" $ T.unlines-            [  "module A (anidentifier) where",-               "anidentifier = ()"-            ]-        _ <- waitForDiagnostics-        doc <- createDoc "B.hs" "haskell" $ T.unlines-            [ "module B where",-              "import qualified A as Alias",-              "foo = Alias."-            ]-        compls <- getCompletions doc (Position 2 12)-        let item = head compls-        liftIO $ do-          item ^. L.label @?= "anidentifier"-    ]--completionDocTests :: [TestTree]-completionDocTests =-  [ testSession "local define" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = ()"-        , "bar = fo"-        ]-      let expected = "*Defined at line 2, column 1 in this module*\n"-      test doc (Position 2 8) "foo" Nothing [expected]-  , testSession "local empty doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]-  , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- |docdoc"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"]-  , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- | abcabc"-        , "--"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"]-  , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "-- |     abcabc"-        , "--"-        , "--def"-        , "foo = ()"-        , "bar = fo"-        ]-      test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n     abcabc\n\ndef\n"]-  , testSession "extern empty doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = od"-        ]-      let expected = "*Imported from 'Prelude'*\n"-      test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = no"-        ]-      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"-      test doc (Position 1 8) "not" (Just $ T.length expected) [expected]-  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = i"-        ]-      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"-      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]-  , testSession "extern defined doc" $ do-      doc <- createDoc "A.hs" "haskell" $ T.unlines-        [ "module A where"-        , "foo = i"-        ]-      let expected = "*Imported from 'Prelude'*\n"-      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]-  ]-  where-    brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9"-    brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"-    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903-    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9"-    test doc pos label mn expected = do-      _ <- waitForDiagnostics-      compls <- getCompletions doc pos-      let compls' = [-            -- We ignore doc uris since it points to the local path which determined by specific machines-            case mn of-                Nothing -> txt-                Just n -> T.take n txt-            | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls-            , _label == label-            ]-      liftIO $ compls' @?= expected--highlightTests :: TestTree-highlightTests = testGroup "highlight"-  [ testSessionWait "value" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 3 2)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)-            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)-            , DocumentHighlight (R 4 6 4 9) (Just HkRead)-            , DocumentHighlight (R 5 22 5 25) (Just HkRead)-            ]-  , testSessionWait "type" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 2 8)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)-            , DocumentHighlight (R 3 11 3 14) (Just HkRead)-            ]-  , testSessionWait "local" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 6 5)-    liftIO $ highlights @?= List-            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)-            , DocumentHighlight (R 6 10 6 13) (Just HkRead)-            , DocumentHighlight (R 7 12 7 15) (Just HkRead)-            ]-  , knownBrokenForGhcVersions [GHC90, GHC92] "Ghc9 highlights the constructor and not just this field" $-        testSessionWait "record" $ do-        doc <- createDoc "A.hs" "haskell" recsource-        _ <- waitForDiagnostics-        highlights <- getHighlights doc (Position 4 15)-        liftIO $ highlights @?= List-          -- Span is just the .. on 8.10, but Rec{..} before-          [ if ghcVersion >= GHC810-              then DocumentHighlight (R 4 8 4 10) (Just HkWrite)-              else DocumentHighlight (R 4 4 4 11) (Just HkWrite)-          , DocumentHighlight (R 4 14 4 20) (Just HkRead)-          ]-        highlights <- getHighlights doc (Position 3 17)-        liftIO $ highlights @?= List-          [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)-          -- Span is just the .. on 8.10, but Rec{..} before-          , if ghcVersion >= GHC810-              then DocumentHighlight (R 4 8 4 10) (Just HkRead)-              else DocumentHighlight (R 4 4 4 11) (Just HkRead)-          ]-  ]-  where-    source = T.unlines-      ["{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"foo :: Int"-      ,"foo = 3 :: Int"-      ,"bar = foo"-      ,"  where baz = let x = foo in x"-      ,"baz arg = arg + x"-      ,"  where x = arg"-      ]-    recsource = T.unlines-      ["{-# LANGUAGE RecordWildCards #-}"-      ,"{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"-      ,"foo Rec{..} = field2 + field1"-      ]--outlineTests :: TestTree-outlineTests = testGroup-  "outline"-  [ testSessionWait "type class" $ do-    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ moduleSymbol-          "A"-          (R 0 7 0 8)-          [ classSymbol "A a"-                        (R 1 0 1 30)-                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]-          ]-      ]-  , testSessionWait "type class instance " $ do-    let source = T.unlines ["class A a where", "instance A () where"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ classSymbol "A a" (R 0 0 0 15) []-      , docSymbol "A ()" SkInterface (R 1 0 1 19)-      ]-  , testSessionWait "type family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)]-  , testSessionWait "type family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "type family A a"-          , "type instance A () = ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolD "A a"   "type family" SkFunction     (R 1 0 1 15)-      , docSymbol "A ()" SkInterface (R 2 0 2 23)-      ]-  , testSessionWait "data family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)]-  , testSessionWait "data family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "data family A a"-          , "data instance A () = A ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolD "A a"   "data family" SkFunction     (R 1 0 1 11)-      , docSymbol "A ()" SkInterface (R 2 0 2 25)-      ]-  , testSessionWait "constant" $ do-    let source = T.unlines ["a = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "a" SkFunction (R 0 0 0 6)]-  , testSessionWait "pattern" $ do-    let source = T.unlines ["Just foo = Just 21"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]-  , testSessionWait "pattern with type signature" $ do-    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]-  , testSessionWait "function" $ do-    let source = T.unlines ["a _x = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)]-  , testSessionWait "type synonym" $ do-    let source = T.unlines ["type A = Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]-  , testSessionWait "datatype" $ do-    let source = T.unlines ["data A = C"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolWithChildren "A"-                              SkStruct-                              (R 0 0 0 10)-                              [docSymbol "C" SkConstructor (R 0 9 0 10)]-      ]-  , testSessionWait "record fields" $ do-    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)-          [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)-            [ docSymbol "x" SkField (R 1 2 1 3)-            , docSymbol "y" SkField (R 2 4 2 5)-            ]-          ]-      ]-  , testSessionWait "import" $ do-    let source = T.unlines ["import Data.Maybe ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbolWithChildren "imports"-                             SkModule-                             (R 0 0 0 20)-                             [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20)-                             ]-      ]-  , testSessionWait "multiple import" $ do-    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left-      [docSymbolWithChildren "imports"-                             SkModule-                             (R 1 0 3 27)-                             [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20)-                             , docSymbol "import Control.Exception" SkModule (R 3 0 3 27)-                             ]-      ]-  , testSessionWait "foreign import" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign import ccall \"a\" a :: Int"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]-  , testSessionWait "foreign export" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign export ccall odd :: Int -> Bool"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]-  ]- where-  docSymbol name kind loc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing-  docSymbol' name kind loc selectionLoc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing-  docSymbolD name detail kind loc =-    DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing-  docSymbolWithChildren name kind loc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc)-  docSymbolWithChildren' name kind loc selectionLoc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc)-  moduleSymbol name loc cc = DocumentSymbol name-                                            Nothing-                                            SkFile-                                            Nothing-                                            Nothing-                                            (R 0 0 maxBound 0)-                                            loc-                                            (Just $ List cc)-  classSymbol name loc cc = DocumentSymbol name-                                           (Just "class")-                                           SkInterface-                                           Nothing-                                           Nothing-                                           loc-                                           loc-                                           (Just $ List cc)--pattern R :: UInt -> UInt -> UInt -> UInt -> Range-pattern R x y x' y' = Range (Position x y) (Position x' y')--xfail :: TestTree -> String -> TestTree-xfail = flip expectFailBecause--ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)--ignoreInWindowsForGHC88And810 :: TestTree -> TestTree-ignoreInWindowsForGHC88And810 =-    ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"--ignoreForGHC92 :: String -> TestTree -> TestTree-ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92])--ignoreInWindowsForGHC88 :: TestTree -> TestTree-ignoreInWindowsForGHC88 =-    ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8"--knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree-knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)--data BrokenOS = Linux | MacOS | Windows deriving (Show)--data IssueSolution = Broken | Ignore deriving (Show)--data BrokenTarget =-    BrokenSpecific BrokenOS [GhcVersion]-    -- ^Broken for `BrokenOS` with `GhcVersion`-    | BrokenForOS BrokenOS-    -- ^Broken for `BrokenOS`-    | BrokenForGHC [GhcVersion]-    -- ^Broken for `GhcVersion`-    deriving (Show)---- | Ignore test for specific os and ghc with reason.-ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree-ignoreFor = knownIssueFor Ignore---- | Known broken for specific os and ghc with reason.-knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree-knownBrokenFor = knownIssueFor Broken---- | Deal with `IssueSolution` for specific OS and GHC.-knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree-knownIssueFor solution = go . \case-    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers-    BrokenForOS bos -> isTargetOS bos-    BrokenForGHC vers -> isTargetGhc vers-    where-        isTargetOS = \case-            Windows -> isWindows-            MacOS -> isMac-            Linux -> not isWindows && not isMac--        isTargetGhc = elem ghcVersion--        go True = case solution of-            Broken -> expectFailBecause-            Ignore -> ignoreTestBecause-        go False = \_ -> id--data Expect-  = ExpectRange Range -- Both gotoDef and hover should report this range-  | ExpectLocation Location---  | ExpectDefRange Range -- Only gotoDef should report this range-  | ExpectHoverRange Range -- Only hover should report this range-  | ExpectHoverText [T.Text] -- the hover message must contain these snippets-  | ExpectExternFail -- definition lookup in other file expected to fail-  | ExpectNoDefinitions-  | ExpectNoHover---  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples-  deriving Eq--mkR :: UInt -> UInt -> UInt -> UInt -> Expect-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn--mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn--haddockTests :: TestTree-haddockTests-  = testGroup "haddock"-      [ testCase "Num" $ checkHaddock-          (unlines-             [ "However, '(+)' and '(*)' are"-             , "customarily expected to define a ring and have the following properties:"-             , ""-             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"-             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"-             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"-             ]-          )-          (unlines-             [ ""-             , ""-             , "However,  `(+)`  and  `(*)`  are"-             , "customarily expected to define a ring and have the following properties: "-             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"-             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"-             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"-             ]-          )-      , testCase "unsafePerformIO" $ checkHaddock-          (unlines-             [ "may require"-             , "different precautions:"-             , ""-             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"-             , "        that calls 'unsafePerformIO'.  If the call is inlined,"-             , "        the I\\/O may be performed more than once."-             , ""-             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"-             , "        elimination being performed on the module."-             , ""-             ]-          )-          (unlines-             [ ""-             , ""-             , "may require"-             , "different precautions: "-             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "-             , "  that calls  `unsafePerformIO` .  If the call is inlined,"-             , "  the I/O may be performed more than once."-             , ""-             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"-             , "  elimination being performed on the module."-             , ""-             ]-          )-      ]-  where-    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt--cradleTests :: TestTree-cradleTests = testGroup "cradle"-    [testGroup "dependencies" [sessionDepsArePickedUp]-    ,testGroup "ignore-fatal" [ignoreFatalWarning]-    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest]-    ,testGroup "sub-directory"   [simpleSubDirectoryTest]-    ]--loadCradleOnlyonce :: TestTree-loadCradleOnlyonce = testGroup "load cradle only once"-    [ testSession' "implicit" implicit-    , testSession' "direct"   direct-    ]-    where-        direct dir = do-            liftIO $ writeFileUTF8 (dir </> "hie.yaml")-                "cradle: {direct: {arguments: []}}"-            test dir-        implicit dir = test dir-        test _dir = do-            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"-            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 1-            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 0-            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))-            liftIO $ length msgs @?= 0--retryFailedCradle :: TestTree-retryFailedCradle = testSession' "retry failed" $ \dir -> do-  -- The false cradle always fails-  let hieContents = "cradle: {bios: {shell: \"false\"}}"-      hiePath = dir </> "hie.yaml"-  liftIO $ writeFile hiePath hieContents-  let aPath = dir </> "A.hs"-  doc <- createDoc aPath "haskell" "main = return ()"-  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc-  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess--  -- Fix the cradle and typecheck again-  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"-  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle-  sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]--  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc-  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess---dependentFileTest :: TestTree-dependentFileTest = testGroup "addDependentFile"-    [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test]-    ]-    where-      test dir = do-        -- If the file contains B then no type error-        -- otherwise type error-        let depFilePath = dir </> "dep-file.txt"-        liftIO $ writeFile depFilePath "A"-        let fooContent = T.unlines-              [ "{-# LANGUAGE TemplateHaskell #-}"-              , "module Foo where"-              , "import Language.Haskell.TH.Syntax"-              , "foo :: Int"-              , "foo = 1 + $(do"-              , "               qAddDependentFile \"dep-file.txt\""-              , "               f <- qRunIO (readFile \"dep-file.txt\")"-              , "               if f == \"B\" then [| 1 |] else lift f)"-              ]-        let bazContent = T.unlines ["module Baz where", "import Foo ()"]-        _ <- createDoc "Foo.hs" "haskell" fooContent-        doc <- createDoc "Baz.hs" "haskell" bazContent-        expectDiagnostics $-            if ghcVersion >= GHC90-                -- String vs [Char] causes this change in error message-                then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])]-                else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]-        -- Now modify the dependent file-        liftIO $ writeFile depFilePath "B"-        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri "dep-file.txt") FcChanged ]--        -- Modifying Baz will now trigger Foo to be rebuilt as well-        let change = TextDocumentContentChangeEvent-              { _range = Just (Range (Position 2 0) (Position 2 6))-              , _rangeLength = Nothing-              , _text = "f = ()"-              }-        changeDoc doc [change]-        expectDiagnostics [("Foo.hs", [])]---cradleLoadedMessage :: Session FromServerMessage-cradleLoadedMessage = satisfy $ \case-        FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod-        _                                            -> False--cradleLoadedMethod :: T.Text-cradleLoadedMethod = "ghcide/cradle/loaded"--ignoreFatalWarning :: TestTree-ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do-    let srcPath = dir </> "IgnoreFatal.hs"-    src <- liftIO $ readFileUtf8 srcPath-    _ <- createDoc srcPath "haskell" src-    expectNoMoreDiagnostics 5--simpleSubDirectoryTest :: TestTree-simpleSubDirectoryTest =-  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do-    let mainPath = dir </> "a/src/Main.hs"-    mainSource <- liftIO $ readFileUtf8 mainPath-    _mdoc <- createDoc mainPath "haskell" mainSource-    expectDiagnosticsWithTags-      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded-      ]-    expectNoMoreDiagnostics 0.5--simpleMultiTest :: TestTree-simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-    adoc <- openDoc aPath "haskell"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc-    liftIO $ assertBool "A should typecheck" ideResultSuccess-    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc-    liftIO $ assertBool "B should typecheck" ideResultSuccess-    locs <- getDefinitions bdoc (Position 2 7)-    let fooL = mkL (adoc ^. L.uri) 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5---- Like simpleMultiTest but open the files in the other order-simpleMultiTest2 :: TestTree-simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc-    TextDocumentIdentifier auri <- openDoc aPath "haskell"-    skipManyTill anyMessage $ isReferenceReady aPath-    locs <- getDefinitions bdoc (Position 2 7)-    let fooL = mkL auri 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5---- Now with 3 components-simpleMultiTest3 :: TestTree-simpleMultiTest3 =-  testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-        cPath = dir </> "c/C.hs"-    bdoc <- openDoc bPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc-    TextDocumentIdentifier auri <- openDoc aPath "haskell"-    skipManyTill anyMessage $ isReferenceReady aPath-    cdoc <- openDoc cPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc-    locs <- getDefinitions cdoc (Position 2 7)-    let fooL = mkL auri 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5---- Like simpleMultiTest but open the files in component 'a' in a seperate session-simpleMultiDefTest :: TestTree-simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do-    let aPath = dir </> "a/A.hs"-        bPath = dir </> "b/B.hs"-    adoc <- liftIO $ runInDir dir $ do-      aSource <- liftIO $ readFileUtf8 aPath-      adoc <- createDoc aPath "haskell" aSource-      skipManyTill anyMessage $ isReferenceReady aPath-      closeDoc adoc-      pure adoc-    bSource <- liftIO $ readFileUtf8 bPath-    bdoc <- createDoc bPath "haskell" bSource-    locs <- getDefinitions bdoc (Position 2 7)-    let fooL = mkL (adoc ^. L.uri) 2 0 2 3-    checkDefs locs (pure [fooL])-    expectNoMoreDiagnostics 0.5--ifaceTests :: TestTree-ifaceTests = testGroup "Interface loading tests"-    [ -- https://github.com/haskell/ghcide/pull/645/-      ifaceErrorTest-    , ifaceErrorTest2-    , ifaceErrorTest3-    , ifaceTHTest-    ]--bootTests :: TestTree-bootTests = testGroup "boot"-  [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do-        let cPath = dir </> "C.hs"-        cSource <- liftIO $ readFileUtf8 cPath-        -- Dirty the cache-        liftIO $ runInDir dir $ do-            cDoc <- createDoc cPath "haskell" cSource-            -- We send a hover request then wait for either the hover response or-            -- `ghcide/reference/ready` notification.-            -- Once we receive one of the above, we wait for the other that we-            -- haven't received yet.-            -- If we don't wait for the `ready` notification it is possible-            -- that the `getDefinitions` request/response in the outer ghcide-            -- session will find no definitions.-            let hoverParams = HoverParams cDoc (Position 4 3) Nothing-            hoverRequestId <- sendRequest STextDocumentHover hoverParams-            let parseReadyMessage = isReferenceReady cPath-            let parseHoverResponse = responseForId STextDocumentHover hoverRequestId-            hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))-            _ <- skipManyTill anyMessage $-              case hoverResponseOrReadyMessage of-                Left _  -> void parseReadyMessage-                Right _ -> void parseHoverResponse-            closeDoc cDoc-        cdoc <- createDoc cPath "haskell" cSource-        locs <- getDefinitions cdoc (Position 7 4)-        let floc = mkR 9 0 9 1-        checkDefs locs (pure [floc])-  , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do-      _ <- openDoc (dir </> "A.hs") "haskell"-      expectNoMoreDiagnostics 2-  ]---- | test that TH reevaluates across interfaces-ifaceTHTest :: TestTree-ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do-    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()-    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()-    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()--    cdoc <- createDoc cPath "haskell" cSource--    -- Change [TH]a from () to Bool-    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])--    -- Check that the change propogates to C-    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]-    expectDiagnostics-      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-      ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]-    closeDoc cdoc--ifaceErrorTest :: TestTree-ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do-    configureCheckProject True-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    -- save so that we can that the error propogates to A-    sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)--    -- Check that the error propogates to A-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]---    -- Check that we wrote the interfaces for B when we saved-    hidir <- getInterfaceFilesDir bdoc-    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"-    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists--    pdoc <- createDoc pPath "haskell" pSource-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    -- This is clearly inconsistent, and the expected outcome a bit surprising:-    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics-    --   - P is being typechecked with the last successful artifacts for A.-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])-      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2--ifaceErrorTest2 :: TestTree-ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource-    pdoc <- createDoc pPath "haskell" pSource-    expectDiagnostics-      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- Add a new definition to P-    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    expectDiagnostics-    -- As in the other test, P is being typechecked with the last successful artifacts for A-    -- (ot thanks to -fdeferred-type-errors)-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])-      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])-      ]--    expectNoMoreDiagnostics 2--ifaceErrorTest3 :: TestTree-ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- P should not typecheck, as there are no last valid artifacts for A-    _pdoc <- createDoc pPath "haskell" pSource--    -- In this example the interface file for A should not exist (modulo the cache folder)-    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors-    expectDiagnostics-      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2--sessionDepsArePickedUp :: TestTree-sessionDepsArePickedUp = testSession'-  "session-deps-are-picked-up"-  $ \dir -> do-    liftIO $-      writeFileUTF8-        (dir </> "hie.yaml")-        "cradle: {direct: {arguments: []}}"-    -- Open without OverloadedStrings and expect an error.-    doc <- createDoc "Foo.hs" "haskell" fooContent-    expectDiagnostics $-        if ghcVersion >= GHC90-            -- String vs [Char] causes this change in error message-            then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]-            else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]-    -- Update hie.yaml to enable OverloadedStrings.-    liftIO $-      writeFileUTF8-        (dir </> "hie.yaml")-        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"-    sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]-    -- Send change event.-    let change =-          TextDocumentContentChangeEvent-            { _range = Just (Range (Position 4 0) (Position 4 0)),-              _rangeLength = Nothing,-              _text = "\n"-            }-    changeDoc doc [change]-    -- Now no errors.-    expectDiagnostics [("Foo.hs", [])]-  where-    fooContent =-      T.unlines-        [ "module Foo where",-          "import Data.Text",-          "foo :: Text",-          "foo = \"hello\""-        ]---- A test to ensure that the command line ghcide workflow stays working-nonLspCommandLine :: TestTree-nonLspCommandLine = testGroup "ghcide command line"-  [ testCase "works" $ withTempDir $ \dir -> do-        ghcide <- locateGhcideExecutable-        copyTestDataFiles dir "multi"-        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}--        setEnv "HOME" "/homeless-shelter" False--        (ec, _, _) <- readCreateProcessWithExitCode cmd ""--        ec @?= ExitSuccess-  ]--benchmarkTests :: TestTree-benchmarkTests =-    let ?config = Bench.defConfig-            { Bench.verbosity = Bench.Quiet-            , Bench.repetitions = Just 3-            , Bench.buildTool = Bench.Cabal-            } in-    withResource Bench.setup Bench.cleanUp $ \getResource -> testGroup "benchmark experiments"-    [ testCase (Bench.name e) $ do-        Bench.SetupResult{Bench.benchDir} <- getResource-        res <- Bench.runBench (runInDir benchDir) e-        assertBool "did not successfully complete 5 repetitions" $ Bench.success res-        | e <- Bench.experiments-        , Bench.name e /= "edit" -- the edit experiment does not ever fail-        , Bench.name e /= "hole fit suggestions" -- is too slow!-        -- the cradle experiments are way too slow-        , not ("cradle" `isInfixOf` Bench.name e)-    ]---- | checks if we use InitializeParams.rootUri for loading session-rootUriTests :: TestTree-rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do-  let bPath = dir </> "dirB/Foo.hs"-  liftIO $ copyTestDataFiles dir "rootUri"-  bSource <- liftIO $ readFileUtf8 bPath-  _ <- createDoc "Foo.hs" "haskell" bSource-  expectNoMoreDiagnostics 0.5-  where-    -- similar to run' except we can configure where to start ghcide and session-    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()-    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)---- | Test if ghcide asynchronously handles Commands and user Requests-asyncTests :: TestTree-asyncTests = testGroup "async"-    [-      testSession "command" $ do-            -- Execute a command that will block forever-            let req = ExecuteCommandParams Nothing blockCommandId Nothing-            void $ sendRequest SWorkspaceExecuteCommand req-            -- Load a file and check for code actions. Will only work if the command is run asynchronously-            doc <- createDoc "A.hs" "haskell" $ T.unlines-              [ "{-# OPTIONS -Wmissing-signatures #-}"-              , "foo = id"-              ]-            void waitForDiagnostics-            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))-            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?-              [ "add signature: foo :: a -> a" ]-    , testSession "request" $ do-            -- Execute a custom request that will block for 1000 seconds-            void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000-            -- Load a file and check for code actions. Will only work if the request is run asynchronously-            doc <- createDoc "A.hs" "haskell" $ T.unlines-              [ "{-# OPTIONS -Wmissing-signatures #-}"-              , "foo = id"-              ]-            void waitForDiagnostics-            actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))-            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?-              [ "add signature: foo :: a -> a" ]-    ]---clientSettingsTest :: TestTree-clientSettingsTest = testGroup "client settings handling"-    [ testSession "ghcide restarts shake session on config changes" $ do-            void $ skipManyTill anyMessage $ message SClientRegisterCapability-            void $ createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))-            skipManyTill anyMessage restartingBuildSession--    ]-  where-    restartingBuildSession :: Session ()-    restartingBuildSession = do-        FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification-        guard $ "Restarting build session" `T.isInfixOf` _message--referenceTests :: TestTree-referenceTests = testGroup "references"-    [ testGroup "can get references to FOIs"-          [ referenceTest "can get references to symbols"-                          ("References.hs", 4, 7)-                          YesIncludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "can get references to data constructor"-                          ("References.hs", 13, 2)-                          YesIncludeDeclaration-                          [ ("References.hs", 13, 2)-                          , ("References.hs", 16, 14)-                          , ("References.hs", 19, 21)-                          ]--          , referenceTest "getting references works in the other module"-                          ("OtherModule.hs", 6, 0)-                          YesIncludeDeclaration-                          [ ("OtherModule.hs", 6, 0)-                          , ("OtherModule.hs", 8, 16)-                          ]--          , referenceTest "getting references works in the Main module"-                          ("Main.hs", 9, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 10, 4)-                          ]--          , referenceTest "getting references to main works"-                          ("Main.hs", 5, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 4, 0)-                          , ("Main.hs", 5, 0)-                          ]--          , referenceTest "can get type references"-                          ("Main.hs", 9, 9)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 9, 9)-                          , ("Main.hs", 10, 0)-                          ]--          , expectFailBecause "references provider does not respect includeDeclaration parameter" $- referenceTest "works when we ask to exclude declarations"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]-          ]--    , testGroup "can get references to non FOIs"-          [ referenceTest "can get references to symbol defined in a module we import"-                          ("References.hs", 22, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references in modules that import us to symbols we define"-                          ("OtherModule.hs", 4, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references to symbol defined in a module we import transitively"-                          ("References.hs", 24, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get references in modules that import us transitively to symbols we define"-                          ("OtherOtherModule.hs", 2, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get type references to other modules"-                          ("Main.hs", 12, 10)-                          YesIncludeDeclaration-                          [ ("Main.hs", 12, 7)-                          , ("Main.hs", 13, 0)-                          , ("References.hs", 12, 5)-                          , ("References.hs", 16, 0)-                          ]-          ]-    ]---- | When we ask for all references to symbol "foo", should the declaration "foo--- = 2" be among the references returned?-data IncludeDeclaration =-    YesIncludeDeclaration-    | NoExcludeDeclaration--getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location)-getReferences' (file, l, c) includeDeclaration = do-    doc <- openDoc file "haskell"-    getReferences doc (Position l c) $ toBool includeDeclaration-    where toBool YesIncludeDeclaration = True-          toBool NoExcludeDeclaration  = False--referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree-referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do-  -- needed to build whole project indexing-  configureCheckProject True-  let docs = map (dir </>) $ delete thisDoc $ nubOrd docs'-  -- Initial Index-  docid <- openDoc thisDoc "haskell"-  let-    loop :: [FilePath] -> Session ()-    loop [] = pure ()-    loop docs = do-      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)-      loop (delete doc docs)-  loop docs-  f dir-  closeDoc docid---- | Given a location, lookup the symbol and all references to it. Make sure--- they are the ones we expect.-referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree-referenceTest name loc includeDeclaration expected =-    referenceTestSession name (fst3 loc) docs $ \dir -> do-        List actual <- getReferences' loc includeDeclaration-        liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected-  where-    docs = map fst3 expected--type SymbolLocation = (FilePath, UInt, UInt)--expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion-expectSameLocations actual expected = do-    let actual' =-            Set.map (\location -> (location ^. L.uri-                                   , location ^. L.range . L.start . L.line . to fromIntegral-                                   , location ^. L.range . L.start . L.character . to fromIntegral))-            $ Set.fromList actual-    expected' <- Set.fromList <$>-        (forM expected $ \(file, l, c) -> do-                              fp <- canonicalizePath file-                              return (filePathToUri fp, l, c))-    actual' @?= expected'--------------------------------------------------------------------------- Utils-------------------------------------------------------------------------testSession :: String -> Session () -> TestTree-testSession name = testCase name . run--testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix--testSession' :: String -> (FilePath -> Session ()) -> TestTree-testSession' name = testCase name . run'--testSessionWait :: HasCallStack => String -> Session () -> TestTree-testSessionWait name = testSession name .-      -- Check that any diagnostics produced were already consumed by the test case.-      ---      -- If in future we add test cases where we don't care about checking the diagnostics,-      -- this could move elsewhere.-      ---      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.-      ( >> expectNoMoreDiagnostics 0.5)--pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction-pickActionWithTitle title actions = do-  assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)-  return $ head matches-  where-    titles =-        [ actionTitle-        | InR CodeAction { _title = actionTitle } <- actions-        ]-    matches =-        [ action-        | InR action@CodeAction { _title = actionTitle } <- actions-        , title == actionTitle-        ]--mkRange :: UInt -> UInt -> UInt -> UInt -> Range-mkRange a b c d = Range (Position a b) (Position c d)--run :: Session a -> IO a-run s = run' (const s)--runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a-runWithExtraFiles prefix s = withTempDir $ \dir -> do-  copyTestDataFiles dir prefix-  runInDir dir (s dir)--copyTestDataFiles :: FilePath -> FilePath -> IO ()-copyTestDataFiles dir prefix = do-  -- Copy all the test data files to the temporary workspace-  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]-  for_ testDataFiles $ \f -> do-    createDirectoryIfMissing True $ dir </> takeDirectory f-    copyFile ("test/data" </> prefix </> f) (dir </> f)--run' :: (FilePath -> Session a) -> IO a-run' s = withTempDir $ \dir -> runInDir dir (s dir)--runInDir :: FilePath -> Session a -> IO a-runInDir dir = runInDir' dir "." "." []--withLongTimeout :: IO a -> IO a-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")---- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.-runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a-runInDir' = runInDir'' lspTestCaps--runInDir''-    :: ClientCapabilities-    -> FilePath-    -> FilePath-    -> FilePath-    -> [String]-    -> Session b-    -> IO b-runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do--  ghcideExe <- locateGhcideExecutable-  let startDir = dir </> startExeIn-  let projDir = dir </> startSessionIn--  createDirectoryIfMissing True startDir-  createDirectoryIfMissing True projDir-  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56-  -- since the package import test creates "Data/List.hs", which otherwise has no physical home-  createDirectoryIfMissing True $ projDir ++ "/Data"--  shakeProfiling <- getEnv "SHAKE_PROFILING"-  let cmd = unwords $-       [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir-       ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]-       ] ++ extraOptions-  -- HIE calls getXgdDirectory which assumes that HOME is set.-  -- Only sets HOME if it wasn't already set.-  setEnv "HOME" "/homeless-shelter" False-  conf <- getConfigFromEnv-  runSessionWithConfig conf cmd lspCaps projDir $ do-      configureCheckProject False-      s---getConfigFromEnv :: IO SessionConfig-getConfigFromEnv = do-  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"-  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"-  return defaultConfig-    { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride-    , logColor-    }-  where-    checkEnv :: String -> IO (Maybe Bool)-    checkEnv s = fmap convertVal <$> getEnv s-    convertVal "0" = False-    convertVal _   = True--lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }--lspTestCapsNoFileWatches :: ClientCapabilities-lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing--openTestDataDoc :: FilePath -> Session TextDocumentIdentifier-openTestDataDoc path = do-  source <- liftIO $ readFileUtf8 $ "test/data" </> path-  createDoc path "haskell" source--findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActions = findCodeActions' (==) "is not a superset of"--findCodeActionsByPrefix :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActionsByPrefix = findCodeActions' T.isPrefixOf "is not prefix of"--findCodeActions' :: (T.Text -> T.Text -> Bool) -> String -> TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]-findCodeActions' op errMsg doc range expectedTitles = do-  actions <- getCodeActions doc range-  let matches = sequence-        [ listToMaybe-          [ action-          | InR action@CodeAction { _title = actionTitle } <- actions-          , expectedTitle `op` actionTitle]-        | expectedTitle <- expectedTitles]-  let msg = show-            [ actionTitle-            | InR CodeAction { _title = actionTitle } <- actions-            ]-            ++ " " <> errMsg <> " "-            ++ show expectedTitles-  liftIO $ case matches of-    Nothing -> assertFailure msg-    Just _  -> pure ()-  return (fromJust matches)--findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction-findCodeAction doc range t = head <$> findCodeActions doc range [t]--unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree-unitTests recorder logger = do-  testGroup "Unit"-     [ testCase "empty file path does NOT work with the empty String literal" $-         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."-     , testCase "empty file path works using toNormalizedFilePath'" $-         uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""-     , testCase "empty path URI" $ do-         Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)-         uriScheme @?= "file:"-         uriPath @?= ""-     , testCase "from empty path URI" $ do-         let uri = Uri "file://"-         uriToFilePath' uri @?= Just ""-     , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do-         let diag = ("", Diagnostics.ShowDiag, Diagnostic-               { _range = Range-                   { _start = Position{_line = 0, _character = 1}-                   , _end = Position{_line = 2, _character = 3}-                   }-               , _severity = Nothing-               , _code = Nothing-               , _source = Nothing-               , _message = ""-               , _relatedInformation = Nothing-               , _tags = Nothing-               })-         let shown = T.unpack (Diagnostics.showDiagnostics [diag])-         let expected = "1:2-3:4"-         assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $-             expected `isInfixOf` shown-     , testCase "notification handlers run sequentially" $ do-        orderRef <- newIORef []-        let plugins = pluginDescToIdePlugins $-                [ (defaultPluginDescriptor $ fromString $ show i)-                    { pluginNotificationHandlers = mconcat-                        [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ ->-                            liftIO $ atomicModifyIORef_ orderRef (i:)-                        ]-                    }-                    | i <- [(1::Int)..20]-                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)--        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do-            _ <- createDoc "haskell" "A.hs" "module A where"-            waitForProgressDone-            actualOrder <- liftIO $ readIORef orderRef--            liftIO $ actualOrder @?= reverse [(1::Int)..20]-     , ignoreTestBecause "The test fails sometimes showing 10000us" $-         testCase "timestamps have millisecond resolution" $ do-           resolution_us <- findResolution_us 1-           let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us-           assertBool msg (resolution_us <= 1000)-     , Progress.tests-     , FuzzySearch.tests-     ]--garbageCollectionTests :: TestTree-garbageCollectionTests = testGroup "garbage collection"-  [ testGroup "dirty keys"-        [ testSession' "are collected" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            doc <- generateGarbage "A" dir-            closeDoc doc-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage--        , testSession' "are deleted from the state" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            keys0 <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keys1 <- getStoredKeys-            liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)--        , testSession' "are not regenerated unless needed" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"-            docA <- generateGarbage "A" dir-            _docB <- generateGarbage "B" dir--            -- garbage collect A keys-            keysBeforeGC <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keysAfterGC <- getStoredKeys-            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"-                (length keysAfterGC < length keysBeforeGC)--            -- re-typecheck B and check that the keys for A have not materialized back-            _docB <- generateGarbage "B" dir-            keysB <- getStoredKeys-            let regeneratedKeys = Set.filter (not . isExpected) $-                    Set.intersection (Set.fromList garbage) (Set.fromList keysB)-            liftIO $ regeneratedKeys @?= mempty--        , testSession' "regenerate successfully" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage-            let edit = T.unlines-                        [ "module A where"-                        , "a :: Bool"-                        , "a = ()"-                        ]-            doc <- generateGarbage "A" dir-            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit]-            builds <- waitForTypecheck doc-            liftIO $ assertBool "it still builds" builds-            expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")]-        ]-  ]-  where-    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]--    generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier-    generateGarbage modName dir = do-        let fp = modName <> ".hs"-            body = printf "module %s where" modName-        doc <- createDoc fp "haskell" (T.pack body)-        liftIO $ writeFile (dir </> fp) body-        builds <- waitForTypecheck doc-        liftIO $ assertBool "something is wrong with this test" builds-        return doc--findResolution_us :: Int -> IO Int-findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"-findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do-    performGC-    writeFile f ""-    threadDelay delay_us-    writeFile f' ""-    t <- getModTime f-    t' <- getModTime f'-    if t /= t' then return delay_us else findResolution_us (delay_us * 10)---testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()-testIde recorder arguments session = do-    config <- getConfigFromEnv-    cwd <- getCurrentDirectory-    (hInRead, hInWrite) <- createPipe-    (hOutRead, hOutWrite) <- createPipe-    let projDir = "."-    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments-            { IDE.argsHandleIn = pure hInRead-            , IDE.argsHandleOut = pure hOutWrite-            }--    flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->-        runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session----positionMappingTests :: TestTree-positionMappingTests =-    testGroup "position mapping"-        [ testGroup "toCurrent"-              [ testCase "before" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 3) @?= PositionExact (Position 0 4)-              , testCase "after, same line, decreased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 3) @?= PositionExact (Position 0 2)-              , testCase "after, next line, no newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 1 0) @?= PositionExact (Position 2 0)-              , testCase "after, same line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 0 4) @?= PositionExact (Position 1 2)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 0 4) @?= PositionExact (Position 2 1)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 1) @?= PositionExact (Position 0 4)-              ]-        , testGroup "fromCurrent"-              [ testCase "before" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 3)-              , testCase "after, same line, decreased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 2) @?= PositionExact (Position 0 3)-              , testCase "after, next line, no newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 2 0) @?= PositionExact (Position 1 0)-              , testCase "after, same line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 1 2) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 2 1) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 1)-              ]-        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"-              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do-                -- Note that it is important to use suchThatMap on all values at once-                -- instead of only using it on the position. Otherwise you can get-                -- into situations where there is no position that can be mapped back-                -- for the edit which will result in QuickCheck looping forever.-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        oldPos <- genPosition rope-                        pure (range, replacement, oldPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $-                    \(range, replacement, oldPos, newPos) ->-                    fromCurrent range replacement newPos === PositionExact oldPos-              , testProperty "toCurrent r t <=< fromCurrent r t" $ do-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)-                        newPos <- genPosition newRope-                        pure (range, replacement, newPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $-                    \(range, replacement, newPos, oldPos) ->-                    toCurrent range replacement oldPos === PositionExact newPos-              ]-        ]--newtype PrintableText = PrintableText { getPrintableText :: T.Text }-    deriving Show--instance Arbitrary PrintableText where-    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary---genRope :: Gen Rope-genRope = Rope.fromText . getPrintableText <$> arbitrary--genPosition :: Rope -> Gen Position-genPosition r = do-    let rows = Rope.rows r-    row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt-    let columns = Rope.columns (nthLine row r)-    column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt-    pure $ Position (fromIntegral row) (fromIntegral column)--genRange :: Rope -> Gen Range-genRange r = do-    let rows = Rope.rows r-    startPos@(Position startLine startColumn) <- genPosition r-    let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine-    endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt-    let columns = Rope.columns (nthLine (fromIntegral endLine) r)-    endColumn <--        if fromIntegral startLine == endLine-            then choose (fromIntegral startColumn, columns)-            else choose (0, max 0 $ columns - 1)-        `suchThat` inBounds @UInt-    pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn))--inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool-inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b)---- | Get the ith line of a rope, starting from 0. Trailing newline not included.-nthLine :: Int -> Rope -> Rope-nthLine i r-    | i < 0 = error $ "Negative line number: " <> show i-    | i == 0 && Rope.rows r == 0 = r-    | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)-    | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r--getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]-getWatchedFilesSubscriptionsUntil m = do-      msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m)-      return-            [ args-            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs-            , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs-            ]---- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path--- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or--- @/var@-withTempDir :: (FilePath -> IO a) -> IO a-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do-  dir' <- canonicalizePath dir-  f dir'---- | Assert that a value is not 'Nothing', and extract the value.-assertJust :: MonadIO m => String -> Maybe a -> m a-assertJust s = \case-  Nothing -> liftIO $ assertFailure s-  Just x  -> pure x+import           Data.Aeson                               (toJSON)+import qualified Data.Aeson                               as A+import           Data.Default+import           Data.Foldable+import           Data.List.Extra+import           Data.Maybe+import qualified Data.Set                                 as Set+import qualified Data.Text                                as T+import           Data.Text.Utf16.Rope                     (Rope)+import qualified Data.Text.Utf16.Rope                     as Rope+import           Development.IDE.Core.PositionMapping     (PositionResult (..),+                                                           fromCurrent,+                                                           positionResultToMaybe,+                                                           toCurrent)+import           Development.IDE.GHC.Compat               (GhcVersion (..),+                                                           ghcVersion)+import           Development.IDE.GHC.Util+import qualified Development.IDE.Main                     as IDE+import           Development.IDE.Plugin.TypeLenses        (typeLensCommandId)+import           Development.IDE.Spans.Common+import           Development.IDE.Test                     (Cursor,+                                                           canonicalizeUri,+                                                           configureCheckProject,+                                                           diagnostic,+                                                           expectCurrentDiagnostics,+                                                           expectDiagnostics,+                                                           expectDiagnosticsWithTags,+                                                           expectNoMoreDiagnostics,+                                                           flushMessages,+                                                           getInterfaceFilesDir,+                                                           getStoredKeys,+                                                           isReferenceReady,+                                                           referenceReady,+                                                           standardizeQuotes,+                                                           waitForAction,+                                                           waitForGC,+                                                           waitForTypecheck)+import           Development.IDE.Test.Runfiles+import qualified Development.IDE.Types.Diagnostics        as Diagnostics+import           Development.IDE.Types.Location+import           Development.Shake                        (getDirectoryFilesIO)+import           Ide.Plugin.Config+import           Language.LSP.Test+import           Language.LSP.Types                       hiding+                                                          (SemanticTokenAbsolute (length, line),+                                                           SemanticTokenRelative (length),+                                                           SemanticTokensEdit (_start),+                                                           mkRange)+import           Language.LSP.Types.Capabilities+import qualified Language.LSP.Types.Lens                  as Lens (label)+import qualified Language.LSP.Types.Lens                  as Lsp (diagnostics,+                                                                  message,+                                                                  params)+import           Language.LSP.VFS                         (VfsLog, applyChange)+import           Network.URI+import           System.Directory+import           System.Environment.Blank                 (getEnv, setEnv,+                                                           unsetEnv)+import           System.Exit                              (ExitCode (ExitSuccess))+import           System.FilePath+import           System.Info.Extra                        (isMac, isWindows)+import qualified System.IO.Extra+import           System.IO.Extra                          hiding (withTempDir)+import           System.Mem                               (performGC)+import           System.Process.Extra                     (CreateProcess (cwd),+                                                           createPipe, proc,+                                                           readCreateProcessWithExitCode)+import           Test.QuickCheck+-- import Test.QuickCheck.Instances ()+import           Control.Concurrent.Async+import           Control.Lens                             (to, (.~), (^.))+import           Control.Monad.Extra                      (whenJust)+import           Data.Function                            ((&))+import           Data.Functor.Identity                    (runIdentity)+import           Data.IORef+import           Data.IORef.Extra                         (atomicModifyIORef_)+import           Data.String                              (IsString (fromString))+import           Data.Tuple.Extra+import           Development.IDE.Core.FileStore           (getModTime)+import qualified Development.IDE.Plugin.HLS.GhcIde        as Ghcide+import           Development.IDE.Plugin.Test              (TestRequest (BlockSeconds),+                                                           WaitForIdeRuleResult (..),+                                                           blockCommandId)+import           Development.IDE.Types.Logger             (Logger (Logger),+                                                           LoggingColumn (DataColumn, PriorityColumn),+                                                           Pretty (pretty),+                                                           Priority (Debug),+                                                           Recorder (Recorder, logger_),+                                                           WithPriority (WithPriority, priority),+                                                           cfilter,+                                                           cmapWithPrio,+                                                           makeDefaultStderrRecorder,+                                                           toCologActionWithPrio)+import qualified FuzzySearch+import           GHC.Stack                                (emptyCallStack)+import qualified HieDbRetry+import           Ide.PluginUtils                          (pluginDescToIdePlugins)+import           Ide.Types+import qualified Language.LSP.Types                       as LSP+import           Language.LSP.Types.Lens                  (didChangeWatchedFiles,+                                                           workspace)+import qualified Language.LSP.Types.Lens                  as L+import qualified Progress+import           System.Time.Extra+import qualified Test.QuickCheck.Monadic                  as MonadicQuickCheck+import           Test.QuickCheck.Monadic                  (forAllM, monadicIO)+import           Test.Tasty+import           Test.Tasty.ExpectedFailure+import           Test.Tasty.HUnit+import           Test.Tasty.Ingredients.Rerun+import           Test.Tasty.QuickCheck+import           Text.Printf                              (printf)+import           Text.Regex.TDFA                          ((=~))++data Log+  = LogGhcIde Ghcide.Log+  | LogIDEMain IDE.Log+  | LogVfs VfsLog++instance Pretty Log where+  pretty = \case+    LogGhcIde log  -> pretty log+    LogIDEMain log -> pretty log+    LogVfs log     -> pretty log++-- | Wait for the next progress begin step+waitForProgressBegin :: Session ()+waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case+  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just ()+  _ -> Nothing++-- | Wait for the first progress end step+-- Also implemented in hls-test-utils Test.Hls+waitForProgressDone :: Session ()+waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case+  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+  _ -> Nothing++-- | Wait for all progress to be done+-- Needs at least one progress done notification to return+-- Also implemented in hls-test-utils Test.Hls+waitForAllProgressDone :: Session ()+waitForAllProgressDone = loop+  where+    loop = do+      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case+        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+        _ -> Nothing+      done <- null <$> getIncompleteProgressSessions+      unless done loop++main :: IO ()+main = do+  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug++  let docWithFilteredPriorityRecorder@Recorder{ logger_ } =+        docWithPriorityRecorder+        & cfilter (\WithPriority{ priority } -> priority >= Debug)++  -- exists so old-style logging works. intended to be phased out+  let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))++  let recorder = docWithFilteredPriorityRecorder+               & cmapWithPrio pretty++  -- We mess with env vars so run single-threaded.+  defaultMainWithRerun $ testGroup "ghcide"+    [ testSession "open close" $ do+        doc <- createDoc "Testing.hs" "haskell" ""+        void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate)+        waitForProgressBegin+        closeDoc doc+        waitForProgressDone+    , initializeResponseTests+    , completionTests+    , cppTests+    , diagnosticTests+    , codeLensesTests+    , outlineTests+    , highlightTests+    , findDefinitionAndHoverTests+    , pluginSimpleTests+    , pluginParsedResultTests+    , preprocessorTests+    , thTests+    , symlinkTests+    , safeTests+    , unitTests recorder logger+    , haddockTests+    , positionMappingTests recorder+    , watchedFilesTests+    , cradleTests+    , dependentFileTest+    , nonLspCommandLine+    , ifaceTests+    , bootTests+    , rootUriTests+    , asyncTests+    , clientSettingsTest+    , referenceTests+    , garbageCollectionTests+    , HieDbRetry.tests+    ]++initializeResponseTests :: TestTree+initializeResponseTests = withResource acquire release tests where++  -- these tests document and monitor the evolution of the+  -- capabilities announced by the server in the initialize+  -- response. Currently the server advertises almost no capabilities+  -- at all, in some cases failing to announce capabilities that it+  -- actually does provide! Hopefully this will change ...+  tests :: IO (ResponseMessage Initialize) -> TestTree+  tests getInitializeResponse =+    testGroup "initialize response capabilities"+    [ chk "   text doc sync"             _textDocumentSync  tds+    , chk "   hover"                         _hoverProvider (Just $ InL True)+    , chk "   completion"               _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False))+    , chk "NO signature help"        _signatureHelpProvider Nothing+    , chk "   goto definition"          _definitionProvider (Just $ InL True)+    , chk "   goto type definition" _typeDefinitionProvider (Just $ InL True)+    -- BUG in lsp-test, this test fails, just change the accepted response+    -- for now+    , chk "NO goto implementation"  _implementationProvider (Just $ InL False)+    , chk "   find references"          _referencesProvider (Just $ InL True)+    , chk "   doc highlight"     _documentHighlightProvider (Just $ InL True)+    , chk "   doc symbol"           _documentSymbolProvider (Just $ InL True)+    , chk "   workspace symbol"    _workspaceSymbolProvider (Just $ InL True)+    , chk "   code action"             _codeActionProvider  (Just $ InL False)+    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just False))+    , chk "NO doc formatting"   _documentFormattingProvider (Just $ InL False)+    , chk "NO doc range formatting"+                           _documentRangeFormattingProvider (Just $ InL False)+    , chk "NO doc formatting on typing"+                          _documentOnTypeFormattingProvider Nothing+    , chk "NO renaming"                     _renameProvider (Just $ InL False)+    , chk "NO doc link"               _documentLinkProvider Nothing+    , chk "NO color"                   (^. L.colorProvider) (Just $ InL False)+    , chk "NO folding range"          _foldingRangeProvider (Just $ InL False)+    , che "   execute command"      _executeCommandProvider [typeLensCommandId, blockCommandId]+    , chk "   workspace"                   (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))+    , chk "NO experimental"             (^. L.experimental) Nothing+    ] where++      tds = Just (InL (TextDocumentSyncOptions+                              { _openClose = Just True+                              , _change    = Just TdSyncIncremental+                              , _willSave  = Nothing+                              , _willSaveWaitUntil = Nothing+                              , _save = Just (InR $ SaveOptions {_includeText = Nothing})}))++      chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree+      chk title getActual expected =+        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir++      che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree+      che title getActual expected = testCase title doTest+        where+            doTest = do+                ir <- getInitializeResponse+                let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir+                    commandNames = (!! 2) . T.splitOn ":" <$> commands+                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)++  innerCaps :: ResponseMessage Initialize -> ServerCapabilities+  innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c+  innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error"++  acquire :: IO (ResponseMessage Initialize)+  acquire = run initializeResponse++  release :: ResponseMessage Initialize -> IO ()+  release = const $ pure ()+++diagnosticTests :: TestTree+diagnosticTests = testGroup "diagnostics"+  [ testSessionWait "fix syntax error" $ do+      let content = T.unlines [ "module Testing wher" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 19))+            , _rangeLength = Nothing+            , _text = "where"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [])]+  , testSessionWait "introduce syntax error" $ do+      let content = T.unlines [ "module Testing where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate)+      waitForProgressBegin+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 18))+            , _rangeLength = Nothing+            , _text = "wher"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]+  , testSessionWait "update syntax error" $ do+      let content = T.unlines [ "module Testing(missing) where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])]+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 15) (Position 0 16))+            , _rangeLength = Nothing+            , _text = "l"+            }+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])]+  , testSessionWait "variable not in scope" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> Int -> Int"+            , "foo a _b = a + ab"+            , "bar :: Int -> Int -> Int"+            , "bar _a b = cd + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [ (DsError, (2, 15), "Variable not in scope: ab")+            , (DsError, (4, 11), "Variable not in scope: cd")+            ]+          )+        ]+  , testSessionWait "type error" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String -> Int"+            , "foo a b = a + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]+          )+        ]+  , testSessionWait "typed hole" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String"+            , "foo a = _ a"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]+          )+        ]++  , testGroup "deferral" $+    let sourceA a = T.unlines+          [ "module A where"+          , "a :: Int"+          , "a = " <> a]+        sourceB = T.unlines+          [ "module B where"+          , "import A ()"+          , "b :: Float"+          , "b = True"]+        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"+        expectedDs aMessage =+          [ ("A.hs", [(DsError, (2,4), aMessage)])+          , ("B.hs", [(DsError, (3,4), bMessage)])]+        deferralTest title binding msg = testSessionWait title $ do+          _ <- createDoc "A.hs" "haskell" $ sourceA binding+          _ <- createDoc "B.hs" "haskell"   sourceB+          expectDiagnostics $ expectedDs msg+    in+    [ deferralTest "type error"          "True"    "Couldn't match expected type"+    , deferralTest "typed hole"          "_"       "Found hole"+    , deferralTest "out of scope var"    "unbound" "Variable not in scope"+    ]++  , testSessionWait "remove required module" $ do+      let contentA = T.unlines [ "module ModuleA where" ]+      docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      let change = TextDocumentContentChangeEvent+            { _range = Just (Range (Position 0 0) (Position 0 20))+            , _rangeLength = Nothing+            , _text = ""+            }+      changeDoc docA [change]+      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]+  , testSessionWait "add missing module" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      expectDiagnostics [("ModuleB.hs", [])]+  , testCase "add missing module (non workspace)" $+    -- By default lsp-test sends FileWatched notifications for all files, which we don't want+    -- as non workspace modules will not be watched by the LSP server.+    -- To work around this, we tell lsp-test that our client doesn't have the+    -- FileWatched capability, which is enough to disable the notifications+    withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]+  , testSessionWait "cyclic module dependency" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB"+            ]+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics+        [ ( "ModuleA.hs"+          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        , ( "ModuleB.hs"+          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        ]+  , testSession' "deeply nested cyclic module dependency" $ \path -> do+      let contentA = unlines+            [ "module ModuleA where" , "import ModuleB" ]+      let contentB = unlines+            [ "module ModuleB where" , "import ModuleA" ]+      let contentC = unlines+            [ "module ModuleC where" , "import ModuleB" ]+      let contentD = T.unlines+            [ "module ModuleD where" , "import ModuleC" ]+          cradle =+            "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"+      liftIO $ writeFile (path </> "ModuleA.hs") contentA+      liftIO $ writeFile (path </> "ModuleB.hs") contentB+      liftIO $ writeFile (path </> "ModuleC.hs") contentC+      liftIO $ writeFile (path </> "hie.yaml") cradle+      _ <- createDoc "ModuleD.hs" "haskell" contentD+      expectDiagnostics+        [ ( "ModuleB.hs"+          , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        ]+  , testSessionWait "cyclic module dependency with hs-boot" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import {-# SOURCE #-} ModuleB"+            ]+      let contentB = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures#-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial diagnostic+            , "foo = ()"+            ]+      let contentBboot = T.unlines+            [ "module ModuleB where"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "correct reference used with hs-boot" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import {-# SOURCE #-} ModuleA()"+            ]+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB()"+            , "x = 5"+            ]+      let contentAboot = T.unlines+            [ "module ModuleA where"+            ]+      let contentC = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures #-}"+            , "module ModuleC where"+            , "import ModuleA"+            -- this reference will fail if it gets incorrectly+            -- resolved to the hs-boot file+            , "y = x"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot+      _ <- createDoc "ModuleC.hs" "haskell" contentC+      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "redundant import" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnosticsWithTags+        [ ( "ModuleB.hs"+          , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)]+          )+        ]+  , testSessionWait "redundant import even without warning" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial warning for testing purposes+            , "foo = ()"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]+  , testSessionWait "package imports" $ do+      let thisDataListContent = T.unlines+            [ "module Data.List where"+            , "x :: Integer"+            , "x = 123"+            ]+      let mainContent = T.unlines+            [ "{-# LANGUAGE PackageImports #-}"+            , "module Main where"+            , "import qualified \"this\" Data.List as ThisList"+            , "import qualified \"base\" Data.List as BaseList"+            , "useThis = ThisList.x"+            , "useBase = BaseList.map"+            , "wrong1 = ThisList.map"+            , "wrong2 = BaseList.x"+            , "main = pure ()"+            ]+      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent+      _ <- createDoc "Main.hs" "haskell" mainContent+      expectDiagnostics+        [ ( "Main.hs"+          , [(DsError, (6, 9),+                if ghcVersion >= GHC94+                then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130+                else "Not in scope: \8216ThisList.map\8217")+            ,(DsError, (7, 9),+                if ghcVersion >= GHC94+                then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130+                else "Not in scope: \8216BaseList.x\8217")+            ]+          )+        ]+  , testSessionWait "unqualified warnings" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+            , "module Foo where"+            , "foo :: Ord a => a -> Int"+            , "foo _a = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+      -- The test is to make sure that warnings contain unqualified names+      -- where appropriate. The warning should use an unqualified name 'Ord', not+      -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to+      -- test this is fairly arbitrary.+          , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a")+            ]+          )+        ]+    , testSessionWait "lower-case drive" $ do+          let aContent = T.unlines+                [ "module A.A where"+                , "import A.B ()"+                ]+              bContent = T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "module A.B where"+                , "import Data.List"+                ]+          uriB <- getDocUri "A/B.hs"+          Just pathB <- pure $ uriToFilePath uriB+          uriB <- pure $+              let (drive, suffix) = splitDrive pathB+              in filePathToUri (joinDrive (lower drive) suffix)+          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)+          liftIO $ writeFileUTF8 pathB $ T.unpack bContent+          uriA <- getDocUri "A/A.hs"+          Just pathA <- pure $ uriToFilePath uriA+          uriA <- pure $+              let (drive, suffix) = splitDrive pathA+              in filePathToUri (joinDrive (lower drive) suffix)+          let itemA = TextDocumentItem uriA "haskell" 0 aContent+          let a = TextDocumentIdentifier uriA+          sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA)+          NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic+          -- Check that if we put a lower-case drive in for A.A+          -- the diagnostics for A.B will also be lower-case.+          liftIO $ fileUri @?= uriB+          let msg = head (toList diags) ^. L.message+          liftIO $ unless ("redundant" `T.isInfixOf` msg) $+              assertFailure ("Expected redundant import but got " <> T.unpack msg)+          closeDoc a+  , testSessionWait "haddock parse error" $ do+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo :: Int"+            , "foo = 1 {-|-}"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      if ghcVersion >= GHC90 then+          -- Haddock parse errors are ignored on ghc-9.0+            pure ()+      else+        expectDiagnostics+            [ ( "Foo.hs"+              , [(DsWarning, (2, 8), "Haddock parse error on input")]+              )+            ]+  , testSessionWait "strip file path" $ do+      let+          name = "Testing"+          content = T.unlines+            [ "module " <> name <> " where"+            , "value :: Maybe ()"+            , "value = [()]"+            ]+      _ <- createDoc (T.unpack name <> ".hs") "haskell" content+      notification <- skipManyTill anyMessage diagnostic+      let+          offenders =+            Lsp.params .+            Lsp.diagnostics .+            Lens.folded .+            Lsp.message .+            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))+          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg+      Lens.mapMOf_ offenders failure notification+  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do+      liftIO $ writeFile (sessionDir </> "hie.yaml")+        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo = ()"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (1, 0), "Top-level binding with no type signature:")+            ]+          )+        ]+  , testSessionWait "-Werror in pragma is ignored" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wall -Werror #-}"+            , "module Foo() where"+            , "foo :: Int"+            , "foo = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DsWarning, (3, 0), "Defined but not used:")+            ]+          )+        ]+  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"+        aPath = dir </> "A.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int+    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int++    bdoc <- createDoc bPath "haskell" bSource+    _pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded++    -- Change y from Int to B which introduces a type error in A (imported from P)+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $+                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ]++    -- Open A and edit to fix the type error+    adoc <- createDoc aPath "haskell" aSource+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $+                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]++    expectDiagnostics+      [ ( "P.hs",+          [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),+            (DsWarning, (4, 0), "Top-level binding")+          ]+        ),+        ("A.hs", [])+      ]+    expectNoMoreDiagnostics 1++  , testSessionWait "deduplicate missing module diagnostics" $  do+      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]+      doc <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]++      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]+      expectDiagnostics []++      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines+            [ "module Foo() where" , "import MissingModule" ] ]+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]++  , testGroup "Cancellation"+    [ cancellationTestGroup "edit header" editHeader yesSession noParse  noTc+    , cancellationTestGroup "edit import" editImport noSession  yesParse noTc+    , cancellationTestGroup "edit body"   editBody   yesSession yesParse yesTc+    ]+  ]+  where+      editPair x y = let p = Position x y ; p' = Position x (y+2) in+        (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}+        ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})+      editHeader = editPair 0 0+      editImport = editPair 2 10+      editBody   = editPair 3 10++      noParse = False+      yesParse = True++      noSession = False+      yesSession = True++      noTc = False+      yesTc = True++cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree+cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name+    [ cancellationTemplate edits Nothing+    , cancellationTemplate edits $ Just ("GetFileContents", True)+    , cancellationTemplate edits $ Just ("GhcSession", True)+      -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!)+    , cancellationTemplate edits $ Just ("GetModSummary", True)+    , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)+      -- getLocatedImports never fails+    , cancellationTemplate edits $ Just ("GetLocatedImports", True)+    , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)+    , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)+    , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)+    , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome)+    ]++cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree+cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do+      doc <- createDoc "Foo.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wall #-}"+            , "module Foo where"+            , "import Data.List()"+            , "f0 x = (x,x)"+            ]++      -- for the example above we expect one warning+      let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      -- Now we edit the document and wait for the given key (if any)+      changeDoc doc [edit]+      whenJust mbKey $ \(key, expectedResult) -> do+        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc+        liftIO $ ideResultSuccess @?= expectedResult++      -- The 2nd edit cancels the active session and unbreaks the file+      -- wait for typecheck and check that the current diagnostics are accurate+      changeDoc doc [undoEdit]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      expectNoMoreDiagnostics 0.5+    where+        -- similar to run except it disables kick+        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s++        typeCheck doc = do+            WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+            liftIO $ assertBool "The file should typecheck" ideResultSuccess+            -- wait for the debouncer to publish diagnostics if the rule runs+            liftIO $ sleep 0.2+            -- flush messages to ensure current diagnostics state is updated+            flushMessages++codeLensesTests :: TestTree+codeLensesTests = testGroup "code lenses"+  [ addSigLensesTests+  ]++watchedFilesTests :: TestTree+watchedFilesTests = testGroup "watched files"+  [ testGroup "Subscriptions"+    [ testSession' "workspace files" $ \sessionDir -> do+        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"+        _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"+        watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics++        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle+        liftIO $ length watchedFileRegs @?= 2++    , testSession' "non workspace file" $ \sessionDir -> do+        tmpDir <- liftIO getTemporaryDirectory+        let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"+        liftIO $ writeFile (sessionDir </> "hie.yaml") yaml+        _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"+        watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics++        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle+        liftIO $ length watchedFileRegs @?= 2++    -- TODO add a test for didChangeWorkspaceFolder+    ]+  , testGroup "Changes"+    [+      testSession' "workspace files" $ \sessionDir -> do+        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"+        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines+          ["module B where"+          ,"b :: Bool"+          ,"b = False"]+        _doc <- createDoc "A.hs" "haskell" $ T.unlines+          ["module A where"+          ,"import B"+          ,"a :: ()"+          ,"a = b"+          ]+        expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])]+        -- modify B off editor+        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines+          ["module B where"+          ,"b :: Int"+          ,"b = 0"]+        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+                List [FileEvent (filePathToUri $ sessionDir </> "B.hs") FcChanged ]+        expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])]+    ]+  ]++addSigLensesTests :: TestTree+addSigLensesTests =+  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"+      moduleH exported =+        T.unlines+          [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"+          , "module Sigs(" <> exported <> ") where"+          , "import qualified Data.Complex as C"+          , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"+          , "data T1 a where"+          , "  MkT1 :: (Show b) => a -> b -> T1 a"+          ]+      before enableGHCWarnings exported (def, _) others =+        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others+      after' enableGHCWarnings exported (def, sig) others =+        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others+      createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]]+      sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do+        let originalCode = before enableGHCWarnings exported def others+        let expectedCode = after' enableGHCWarnings exported def others+        sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode+        doc <- createDoc "Sigs.hs" "haskell" originalCode+        waitForProgressDone+        codeLenses <- getCodeLenses doc+        if not $ null $ snd def+          then do+            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses+            executeCommand $ fromJust $ head codeLenses ^. L.command+            modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)+            liftIO $ expectedCode @=? modifiedCode+          else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses+      cases =+        [ ("abc = True", "abc :: Bool")+        , ("foo a b = a + b", "foo :: Num a => a -> a -> a")+        , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String")+        , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool")+        , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")+        , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")+        , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just a\n  where Some a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just !a\n  where Some !a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")+        , ("head = 233", "head :: Integer")+        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")+        , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")+        , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing")+        , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a")+        , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")+        ]+   in testGroup+        "add signature"+        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]+        , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)+        , testGroup+            "diagnostics mode works"+            [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []+            , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []+            ]+        ]++linkToLocation :: [LocationLink] -> [Location]+linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange)++checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session ()+checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where+  check (ExpectRange expectedRange) = do+    assertNDefinitionsFound 1 defs+    assertRangeCorrect (head defs) expectedRange+  check (ExpectLocation expectedLocation) = do+    assertNDefinitionsFound 1 defs+    liftIO $ do+      canonActualLoc <- canonicalizeLocation (head defs)+      canonExpectedLoc <- canonicalizeLocation expectedLocation+      canonActualLoc @?= canonExpectedLoc+  check ExpectNoDefinitions = do+    assertNDefinitionsFound 0 defs+  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"+  check _ = pure () -- all other expectations not relevant to getDefinition++  assertNDefinitionsFound :: Int -> [a] -> Session ()+  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)++  assertRangeCorrect Location{_range = foundRange} expectedRange =+    liftIO $ expectedRange @=? foundRange++canonicalizeLocation :: Location -> IO Location+canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range++findDefinitionAndHoverTests :: TestTree+findDefinitionAndHoverTests = let++  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree+  tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do++    -- Dirty the cache to check that definitions work even in the presence of iface files+    liftIO $ runInDir dir $ do+      let fooPath = dir </> "Foo.hs"+      fooSource <- liftIO $ readFileUtf8 fooPath+      fooDoc <- createDoc fooPath "haskell" fooSource+      _ <- getHover fooDoc $ Position 4 3+      closeDoc fooDoc++    doc <- openTestDataDoc (dir </> sfp)+    waitForProgressDone+    found <- get doc pos+    check found targetRange++++  checkHover :: Maybe Hover -> Session [Expect] -> Session ()+  checkHover hover expectations = traverse_ check =<< expectations where++    check expected =+      case hover of+        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"+        Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg})+                  ,_range    = rangeInHover } ->+          case expected of+            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets+            ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover+            _ -> pure () -- all other expectations not relevant to hover+        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover++  extractLineColFromHoverMsg :: T.Text -> [T.Text]+  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")++  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()+  checkHoverRange expectedRange rangeInHover msg =+    let+      lineCol = extractLineColFromHoverMsg msg+      -- looks like hovers use 1-based numbering while definitions use 0-based+      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.+      adjust Position{_line = l, _character = c} =+        Position{_line = l + 1, _character = c + 1}+    in+    case map (read . T.unpack) lineCol of+      [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c+      _     -> liftIO $ assertFailure $+        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>+        "\n but got: " <> show (msg, rangeInHover)++  assertFoundIn :: T.Text -> T.Text -> Assertion+  assertFoundIn part whole = assertBool+    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)+    (part `T.isInfixOf` whole)++  sourceFilePath = T.unpack sourceFileName+  sourceFileName = "GotoHover.hs"++  mkFindTests tests = testGroup "get"+    [ testGroup "definition" $ mapMaybe fst tests+    , testGroup "hover"      $ mapMaybe snd tests+    , checkFileCompiles sourceFilePath $+        expectDiagnostics+          [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")])+          , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")])+          ]+    , testGroup "type-definition" typeDefinitionTests+    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]++  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con"+                        , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]++  recordDotSyntaxTests+    | ghcVersion >= GHC92 =+        [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"+        , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"+        , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"+        ]+    | otherwise = []++  test runDef runHover look expect = testM runDef runHover look (return expect)++  testM runDef runHover look expect title =+    ( runDef   $ tst def   look sourceFilePath expect title+    , runHover $ tst hover look sourceFilePath expect title ) where+      def   = (getDefinitions, checkDefs)+      hover = (getHover      , checkHover)++  -- search locations            expectations on results+  fffL4  = _start fffR     ;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]+  fffL8  = Position 12  4  ;+  fffL14 = Position 18  7  ;+  aL20   = Position 19 15+  aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]+  dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]+  dcL12  = Position 16 11  ;+  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]+  tcL6   = Position 10 11  ;  tcData = [mkR   7  0    9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]+  vvL16  = Position 20 12  ;  vv     = [mkR  20  4   20  6]+  opL16  = Position 20 15  ;  op     = [mkR  21  2   21  4]+  opL18  = Position 22 22  ;  opp    = [mkR  22 13   22 17]+  aL18   = Position 22 20  ;  apmp   = [mkR  22 10   22 11]+  b'L19  = Position 23 13  ;  bp     = [mkR  23  6   23  7]+  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]+  clL23  = Position 27 11  ;  cls    = [mkR  25  0   26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]+  clL25  = Position 29  9+  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]]+  dnbL29 = Position 33 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  33 12   33 21]+  dnbL30 = Position 34 23+  lcbL33 = Position 37 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  37 26   37 27]+  lclL33 = Position 37 22+  mclL36 = Position 40  1  ;  mcl    = [mkR  40  0   40 14]+  mclL37 = Position 41  1+  spaceL37 = Position 41  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]+  docL41 = Position 45  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]+                           ;  constr = [ExpectHoverText ["Monad m"]]+  eitL40 = Position 44 28  ;  kindE  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]]+  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]]+  tvrL40 = Position 44 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]+  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["7518"]]+  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["'f'"]]+  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]+  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]+  outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5]+  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]+  holeL60 = Position 62 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]+  holeL65 = Position 65 8  ;  hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]+  cccL17 = Position 17 16  ;  docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]+  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]+  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]+  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]+  in+  mkFindTests+  --      def    hover  look       expect+  [+    if ghcVersion >= GHC90 then+        -- It suggests either going to the constructor or to the field+        test  broken yes    fffL4      fff           "field in record definition"+    else+        test  yes    yes    fffL4      fff           "field in record definition"+  , test  yes    yes    fffL8      fff           "field in record construction    #1102"+  , test  yes    yes    fffL14     fff           "field name used as accessor"           -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs+  , test  yes    yes    aaaL14     aaa           "top-level name"                        -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    dcL7       tcDC          "data constructor record         #1029"+  , test  yes    yes    dcL12      tcDC          "data constructor plain"                -- https://github.com/haskell/ghcide/pull/121+  , test  yes    yes    tcL6       tcData        "type constructor                #1028" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    xtcL5      xtc           "type constructor external   #717,1028"+  , test  broken yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    vvL16      vv            "plain parameter"                       -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    aL18       apmp          "pattern match name"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL16      op            "top-level operator               #713" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL18      opp           "parameter operator"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    b'L19      bp            "name in backticks"                     -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    clL23      cls           "class in instance declaration   #1027"+  , test  yes    yes    clL25      cls           "class in signature              #1027" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    eclL15     ecls          "external class in signature #717,1027"+  , test  yes    yes    dnbL29     dnb           "do-notation   bind              #1073"+  , test  yes    yes    dnbL30     dnb           "do-notation lookup"+  , test  yes    yes    lcbL33     lcb           "listcomp   bind                 #1073"+  , test  yes    yes    lclL33     lcb           "listcomp lookup"+  , test  yes    yes    mclL36     mcl           "top-level fn 1st clause"+  , test  yes    yes    mclL37     mcl           "top-level fn 2nd clause         #1030"+  , if ghcVersion >= GHC810 then+        test  yes    yes    spaceL37   space         "top-level fn on space           #1002"+    else+        test  yes    broken spaceL37   space         "top-level fn on space           #1002"+  , test  no     yes    docL41     doc           "documentation                   #1129"+  , test  no     yes    eitL40     kindE         "kind of Either                  #1017"+  , test  no     yes    intL40     kindI         "kind of Int                     #1017"+  , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #1017"+  , test  no     broken intL41     litI          "literal Int  in hover info      #1016"+  , test  no     broken chrL36     litC          "literal Char in hover info      #1016"+  , test  no     broken txtL8      litT          "literal Text in hover info      #1016"+  , test  no     broken lstL43     litL          "literal List in hover info      #1016"+  , if ghcVersion >= GHC90 then+        test  no     yes    docL41     constr        "type constraint in hover info   #1012"+    else+        test  no     broken docL41     constr        "type constraint in hover info   #1012"+  , test  no     yes    outL45     outSig        "top-level signature              #767"+  , test  broken broken innL48     innSig        "inner     signature              #767"+  , test  no     yes    holeL60    hleInfo       "hole without internal name       #831"+  , test  no     yes    holeL65    hleInfo2      "hole with variable"+  , test  no     yes    cccL17     docLink       "Haddock html links"+  , testM yes    yes    imported   importedSig   "Imported symbol"+  , if | isWindows ->+        -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997+        testM no     yes    reexported reexportedSig "Imported symbol (reexported)"+       | otherwise ->+        testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"+  , if | ghcVersion == GHC90 && isWindows ->+        test  no     broken    thLocL57   thLoc         "TH Splice Hover"+       | ghcVersion == GHC92 && (isWindows || isMac) ->+           -- Some GHC 9.2 distributions ship without .hi docs+           -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903+        test  no     broken   thLocL57   thLoc         "TH Splice Hover"+       | otherwise ->+        test  no     yes       thLocL57   thLoc         "TH Splice Hover"+  ]+  where yes, broken :: (TestTree -> Maybe TestTree)+        yes    = Just -- test should run and pass+        broken = Just . (`xfail` "known broken")+        no = const Nothing -- don't run this test at all+        skip = const Nothing -- unreliable, don't run++checkFileCompiles :: FilePath -> Session () -> TestTree+checkFileCompiles fp diag =+  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do+    void (openTestDataDoc (dir </> fp))+    diag++pluginSimpleTests :: TestTree+pluginSimpleTests =+  ignoreInWindowsForGHC88And810 $+  ignoreForGHC92Plus "blocked on ghc-typelits-natnormalise" $+  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do+    _ <- openDoc (dir </> "KnownNat.hs") "haskell"+    liftIO $ writeFile (dir</>"hie.yaml")+      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"++    expectDiagnostics+      [ ( "KnownNat.hs",+          [(DsError, (9, 15), "Variable not in scope: c")]+          )+      ]++pluginParsedResultTests :: TestTree+pluginParsedResultTests =+  ignoreInWindowsForGHC88And810 $+  ignoreForGHC92Plus "No need for this plugin anymore!" $+  testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do+    _ <- openDoc (dir</> "RecordDot.hs") "haskell"+    expectNoMoreDiagnostics 2++cppTests :: TestTree+cppTests =+  testGroup "cpp"+    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do+        let content =+              T.unlines+                [ "{-# LANGUAGE CPP #-}",+                  "module Testing where",+                  "#ifdef FOO",+                  "foo = 42"+                ]+        -- The error locations differ depending on which C-preprocessor is used.+        -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either+        -- of them.+        (run $ expectError content (2, maxBound))+          `catch` ( \e -> do+                      let _ = e :: HUnitFailure+                      run $ expectError content (2, 1)+                  )+    , testSessionWait "cpp-ghcide" $ do+        _ <- createDoc "A.hs" "haskell" $ T.unlines+          ["{-# LANGUAGE CPP #-}"+          ,"main ="+          ,"#ifdef __GHCIDE__"+          ,"  worked"+          ,"#else"+          ,"  failed"+          ,"#endif"+          ]+        expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]+    ]+  where+    expectError :: T.Text -> Cursor -> Session ()+    expectError content cursor = do+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs",+            [(DsError, cursor, "error: unterminated")]+          )+        ]+      expectNoMoreDiagnostics 0.5++preprocessorTests :: TestTree+preprocessorTests = testSessionWait "preprocessor" $ do+  let content =+        T.unlines+          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"+          , "module Testing where"+          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic+          ]+  _ <- createDoc "Testing.hs" "haskell" content+  expectDiagnostics+    [ ( "Testing.hs",+        [(DsError, (2, 8), "Variable not in scope: z")]+      )+    ]+++safeTests :: TestTree+safeTests =+  testGroup+    "SafeHaskell"+    [ -- Test for https://github.com/haskell/ghcide/issues/424+      testSessionWait "load" $ do+        let sourceA =+              T.unlines+                ["{-# LANGUAGE Trustworthy #-}"+                ,"module A where"+                ,"import System.IO.Unsafe"+                ,"import System.IO ()"+                ,"trustWorthyId :: a -> a"+                ,"trustWorthyId i = unsafePerformIO $ do"+                ,"  putStrLn \"I'm safe\""+                ,"  return i"]+            sourceB =+              T.unlines+                ["{-# LANGUAGE Safe #-}"+                ,"module B where"+                ,"import A"+                ,"safeId :: a -> a"+                ,"safeId = trustWorthyId"+                ]++        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectNoMoreDiagnostics 1 ]++thTests :: TestTree+thTests =+  testGroup+    "TemplateHaskell"+    [ -- Test for https://github.com/haskell/ghcide/pull/212+      testSessionWait "load" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module A where",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "a :: Integer",+                  "a = $(litE $ IntegerL 3)"+                ]+            sourceB =+              T.unlines+                [ "{-# LANGUAGE PackageImports #-}",+                  "{-# LANGUAGE TemplateHaskell #-}",+                  "module B where",+                  "import A",+                  "import \"template-haskell\" Language.Haskell.TH",+                  "b :: Integer",+                  "b = $(litE $ IntegerL $ a) + n"+                ]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]+    , testSessionWait "newtype-closure" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE DeriveDataTypeable #-}"+                  ,"{-# LANGUAGE TemplateHaskell #-}"+                  ,"module A (a) where"+                  ,"import Data.Data"+                  ,"import Language.Haskell.TH"+                  ,"newtype A = A () deriving (Data)"+                  ,"a :: ExpQ"+                  ,"a = [| 0 |]"]+        let sourceB =+              T.unlines+                [ "{-# LANGUAGE TemplateHaskell #-}"+                ,"module B where"+                ,"import A"+                ,"b :: Int"+                ,"b = $( a )" ]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        return ()+    , thReloadingTest False+    , thLoadingTest+    , thCoreTest+    , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True+    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891+    , thLinkingTest False+    , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True+    , testSessionWait "findsTHIdentifiers" $ do+        let sourceA =+              T.unlines+                [ "{-# LANGUAGE TemplateHaskell #-}"+                , "module A (a) where"+                , "import Language.Haskell.TH (ExpQ)"+                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic+                , "a = [| glorifiedID |]"+                , "glorifiedID :: a -> a"+                , "glorifiedID = id" ]+        let sourceB =+              T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "{-# LANGUAGE TemplateHaskell #-}"+                , "module B where"+                , "import A"+                , "main = $a (putStrLn \"success!\")"]+        _ <- createDoc "A.hs" "haskell" sourceA+        _ <- createDoc "B.hs" "haskell" sourceB+        expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]+    , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do++    -- This test defines a TH value with the meaning "data A = A" in A.hs+    -- Loads and export the template in B.hs+    -- And checks wether the constructor A can be loaded in C.hs+    -- This test does not fail when either A and B get manually loaded before C.hs+    -- or when we remove the seemingly unnecessary TH pragma from C.hs++    let cPath = dir </> "C.hs"+    _ <- openDoc cPath "haskell"+    expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]+    ]++-- | Tests for projects that use symbolic links one way or another+symlinkTests :: TestTree+symlinkTests =+  testGroup "Projects using Symlinks"+    [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do+        liftIO $ createFileLink (dir </> "some_loc" </> "Sym.hs") (dir </> "other_loc" </> "Sym.hs")+        let fooPath = dir </> "src" </> "Foo.hs"+        _ <- openDoc fooPath "haskell"+        expectDiagnosticsWithTags  [("src" </> "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])]+        pure ()+    ]++-- | Test that all modules have linkables+thLoadingTest :: TestTree+thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do+    let thb = dir </> "THB.hs"+    _ <- openDoc thb "haskell"+    expectNoMoreDiagnostics 1++thCoreTest :: TestTree+thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do+    let thc = dir </> "THC.hs"+    _ <- openDoc thc "haskell"+    expectNoMoreDiagnostics 1++-- | test that TH is reevaluated on typecheck+thReloadingTest :: Bool -> TestTree+thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do++    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"+        cPath = dir </> "THC.hs"++    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]+    bSource <- liftIO $ readFileUtf8 bPath --  $th+    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()++    adoc <- createDoc aPath "haskell" aSource+    bdoc <- createDoc bPath "haskell" bSource+    cdoc <- createDoc cPath "haskell" cSource++    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]++    -- Change th from () to Bool+    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']+    -- generate an artificial warning to avoid timing out if the TH change does not propagate+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"]++    -- Check that the change propagates to C+    expectDiagnostics+        [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])+        ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")])+        ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")])+        ]++    closeDoc adoc+    closeDoc bdoc+    closeDoc cdoc+  where+    name = "reloading-th-test" <> if unboxed then "-unboxed" else ""+    dir | unboxed = "THUnboxed"+        | otherwise = "TH"++thLinkingTest :: Bool -> TestTree+thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do++    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"++    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]+    bSource <- liftIO $ readFileUtf8 bPath --  $th_a++    adoc <- createDoc aPath "haskell" aSource+    bdoc <- createDoc bPath "haskell" bSource++    expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]++    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]+    changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource']++    -- modify b too+    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']+    waitForProgressBegin+    waitForAllProgressDone++    expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")]++    closeDoc adoc+    closeDoc bdoc+  where+    name = "th-linking-test" <> if unboxed then "-unboxed" else ""+    dir | unboxed = "THUnboxed"+        | otherwise = "TH"++completionTests :: TestTree+completionTests+  = testGroup "completion"+    [+    testGroup "non local" nonLocalCompletionTests+    , testGroup "topLevel" topLevelCompletionTests+    , testGroup "local" localCompletionTests+    , testGroup "package" packageCompletionTests+    , testGroup "project" projectCompletionTests+    , testGroup "other" otherCompletionTests+    , testGroup "doc" completionDocTests+    ]++completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree+completionTest name src pos expected = testSessionWait name $ do+    docId <- createDoc "A.hs" "haskell" (T.unlines src)+    _ <- waitForDiagnostics+    compls <- getCompletions docId pos+    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]+    liftIO $ do+        let emptyToMaybe x = if T.null x then Nothing else Just x+        sortOn (Lens.view Lens._1) (take (length expected) compls') @?=+            sortOn (Lens.view Lens._1)+              [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected]+        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do+            when expectedSig $+                assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)+            when expectedDocs $+                assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)+++topLevelCompletionTests :: [TestTree]+topLevelCompletionTests = [+    completionTest+        "variable"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing)+        ],+    completionTest+        "constructor"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing)+        ],+    completionTest+        "class method"+        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]+        (Position 0 8)+        [("xxx", CiFunction, "xxx", True, True, Nothing)],+    completionTest+        "type"+        ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 9)+        [("Xxx", CiStruct, "Xxx", False, True, Nothing)],+    completionTest+        "class"+        ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]+        (Position 0 9)+        [("Xxx", CiInterface, "Xxx", False, True, Nothing)],+    completionTest+        "records"+        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]+        (Position 1 19)+        [("_personName", CiFunction, "_personName", False, True, Nothing),+         ("_personAge", CiFunction, "_personAge", False, True, Nothing)],+    completionTest+        "recordsConstructor"+        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]+        (Position 1 19)+        [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing),+         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]+    ]++localCompletionTests :: [TestTree]+localCompletionTests = [+    completionTest+        "argument"+        ["bar (Just abcdef) abcdefg = abcd"]+        (Position 0 32)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "let"+        ["bar = let (Just abcdef) = undefined"+        ,"          abcdefg = let abcd = undefined in undefined"+        ,"        in abcd"+        ]+        (Position 2 15)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "where"+        ["bar = abcd"+        ,"  where (Just abcdef) = undefined"+        ,"        abcdefg = let abcd = undefined in undefined"+        ]+        (Position 0 10)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing),+         ("abcdefg", CiFunction , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "do/1"+        ["bar = do"+        ,"  Just abcdef <- undefined"+        ,"  abcd"+        ,"  abcdefg <- undefined"+        ,"  pure ()"+        ]+        (Position 2 6)+        [("abcdef", CiFunction, "abcdef", True, False, Nothing)+        ],+    completionTest+        "do/2"+        ["bar abcde = do"+        ,"    Just [(abcdef,_)] <- undefined"+        ,"    abcdefg <- undefined"+        ,"    let abcdefgh = undefined"+        ,"        (Just [abcdefghi]) = undefined"+        ,"    abcd"+        ,"  where"+        ,"    abcdefghij = undefined"+        ]+        (Position 5 8)+        [("abcde", CiFunction, "abcde", True, False, Nothing)+        ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing)+        ,("abcdef", CiFunction, "abcdef", True, False, Nothing)+        ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing)+        ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing)+        ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing)+        ],+    completionTest+        "type family"+        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"+        ,"type family Bar a"+        ,"a :: Ba"+        ]+        (Position 2 7)+        [("Bar", CiStruct, "Bar", True, False, Nothing)+        ],+    completionTest+        "class method"+        [+          "class Test a where"+        , "    abcd :: a -> ()"+        , "    abcde :: a -> Int"+        , "instance Test Int where"+        , "    abcd = abc"+        ]+        (Position 4 14)+        [("abcd", CiFunction, "abcd", True, False, Nothing)+        ,("abcde", CiFunction, "abcde", True, False, Nothing)+        ],+    testSessionWait "incomplete entries" $ do+        let src a = "data Data = " <> a+        doc <- createDoc "A.hs" "haskell" $ src "AAA"+        void $ waitForTypecheck doc+        let editA rhs =+                changeDoc doc [TextDocumentContentChangeEvent+                    { _range=Nothing+                    , _rangeLength=Nothing+                    , _text=src rhs}]++        editA "AAAA"+        void $ waitForTypecheck doc+        editA "AAAAA"+        void $ waitForTypecheck doc++        compls <- getCompletions doc (Position 0 15)+        liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]+        pure ()+    ]++nonLocalCompletionTests :: [TestTree]+nonLocalCompletionTests =+  [ completionTest+      "variable"+      ["module A where", "f = hea"]+      (Position 1 7)+      [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)],+    completionTest+      "constructor"+      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]+      (Position 2 8)+      [ ("True", CiConstructor, "True", True, True, Nothing)+      ],+    completionTest+      "type"+      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]+      (Position 2 8)+      [ ("Bool", CiStruct, "Bool", True, True, Nothing)+      ],+    completionTest+      "qualified"+      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]+      (Position 2 15)+      [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing)+      ],+    completionTest+      "duplicate import"+      ["module A where", "import Data.List", "import Data.List", "f = permu"]+      (Position 3 9)+      [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing)+      ],+    completionTest+       "dont show hidden items"+       [ "{-# LANGUAGE NoImplicitPrelude #-}",+         "module A where",+         "import Control.Monad hiding (join)",+         "f = joi"+       ]+       (Position 3 6)+       [],+    testGroup "ordering"+      [completionTest "qualified has priority"+        ["module A where"+        ,"import qualified Data.ByteString as BS"+        ,"f = BS.read"+        ]+        (Position 2 10)+        [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)]+        ],+      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls+     completionTest+      "do not show pragma completions"+      [ "{-# LANGUAGE  ",+        "{module A where}",+        "main = return ()"+      ]+      (Position 0 13)+      []+  ]++otherCompletionTests :: [TestTree]+otherCompletionTests = [+    completionTest+      "keyword"+      ["module A where", "f = newty"]+      (Position 1 9)+      [("newtype", CiKeyword, "", False, False, Nothing)],+    completionTest+      "type context"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}",+        "module A () where",+        "f = f",+        "g :: Intege"+      ]+      -- At this point the module parses but does not typecheck.+      -- This should be sufficient to detect that we are in a+      -- type context and only show the completion to the type.+      (Position 3 11)+      [("Integer", CiStruct, "Integer", True, True, Nothing)],++    testSession "duplicate record fields" $ do+      void $+        createDoc "B.hs" "haskell" $+          T.unlines+            [ "{-# LANGUAGE DuplicateRecordFields #-}",+              "module B where",+              "newtype Foo = Foo { member :: () }",+              "newtype Bar = Bar { member :: () }"+            ]+      docA <-+        createDoc "A.hs" "haskell" $+          T.unlines+            [ "module A where",+              "import B",+              "memb"+            ]+      _ <- waitForDiagnostics+      compls <- getCompletions docA $ Position 2 4+      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]+      liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"],++    testSessionWait "maxCompletions" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a = Prelude."+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions  doc (Position 3 13)+        liftIO $ length compls @?= maxCompletions def+  ]++packageCompletionTests :: [TestTree]+packageCompletionTests =+  [ testSession' "fromList" $ \dir -> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 2 12)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+                <- compls+              , _label == "fromList"+              ]+        liftIO $ take 3 (sort compls') @?=+          map ("Defined in "<>) (+              [ "'Data.List.NonEmpty"+              , "'GHC.Exts"+              ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else [])++  , testSessionWait "Map" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a :: Map"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 2 7)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+                <- compls+              , _label == "Map"+              ]+        liftIO $ take 3 (sort compls') @?=+          map ("Defined in "<>)+              [ "'Data.Map"+              , "'Data.Map.Lazy"+              , "'Data.Map.Strict"+              ]+  , testSessionWait "no duplicates" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "import GHC.Exts(fromList)",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 3 13)+        let duplicate =+              find+                (\case+                  CompletionItem+                    { _insertText = Just "fromList"+                    , _documentation =+                      Just (CompletionDocMarkup (MarkupContent MkMarkdown d))+                    } ->+                    "GHC.Exts" `T.isInfixOf` d+                  _ -> False+                ) compls+        liftIO $ duplicate @?= Nothing++  , testSessionWait "non-local before global" $ do+    -- non local completions are more specific+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "import GHC.Exts(fromList)",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 3 13)+        let compls' =+              [_insertText+              | CompletionItem {_label, _insertText} <- compls+              , _label == "fromList"+              ]+        liftIO $ take 3 compls' @?=+          map Just ["fromList ${1:([Item l])}"]+  ]++projectCompletionTests :: [TestTree]+projectCompletionTests =+    [ testSession' "from hiedb" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        -- Note that B does not import A+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "b = anidenti"+            ]+        compls <- getCompletions doc (Position 1 10)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label}+                <- compls+              , _label == "anidentifier"+              ]+        liftIO $ compls' @?= ["Defined in 'A"],+      testSession' "auto complete project imports" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"+        _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines+            [  "module ALocalModule (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        -- Note that B does not import A+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import ALocal"+            ]+        compls <- getCompletions doc (Position 1 13)+        let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls+        liftIO $ do+          item ^. Lens.label @?= "ALocalModule",+      testSession' "auto complete functions from qualified imports without alias" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import qualified A",+              "A."+            ]+        compls <- getCompletions doc (Position 2 2)+        let item = head compls+        liftIO $ do+          item ^. L.label @?= "anidentifier",+      testSession' "auto complete functions from qualified imports with alias" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import qualified A as Alias",+              "foo = Alias."+            ]+        compls <- getCompletions doc (Position 2 12)+        let item = head compls+        liftIO $ do+          item ^. L.label @?= "anidentifier"+    ]++completionDocTests :: [TestTree]+completionDocTests =+  [ testSession "local define" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = ()"+        , "bar = fo"+        ]+      let expected = "*Defined at line 2, column 1 in this module*\n"+      test doc (Position 2 8) "foo" Nothing [expected]+  , testSession "local empty doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]+  , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- |docdoc"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"]+  , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- | abcabc"+        , "--"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"]+  , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- |     abcabc"+        , "--"+        , "--def"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n     abcabc\n\ndef\n"]+  , testSession "extern empty doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = od"+        ]+      let expected = "*Imported from 'Prelude'*\n"+      test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]+  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = no"+        ]+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"+      test doc (Position 1 8) "not" (Just $ T.length expected) [expected]+  , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = i"+        ]+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]+  , testSession "extern defined doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = i"+        ]+      let expected = "*Imported from 'Prelude'*\n"+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]+  ]+  where+    brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9"+    brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2"+    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903+    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9"+    test doc pos label mn expected = do+      _ <- waitForDiagnostics+      compls <- getCompletions doc pos+      let compls' = [+            -- We ignore doc uris since it points to the local path which determined by specific machines+            case mn of+                Nothing -> txt+                Just n  -> T.take n txt+            | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls+            , _label == label+            ]+      liftIO $ compls' @?= expected++highlightTests :: TestTree+highlightTests = testGroup "highlight"+  [ testSessionWait "value" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 3 2)+    liftIO $ highlights @?= List+            [ DocumentHighlight (R 2 0 2 3) (Just HkRead)+            , DocumentHighlight (R 3 0 3 3) (Just HkWrite)+            , DocumentHighlight (R 4 6 4 9) (Just HkRead)+            , DocumentHighlight (R 5 22 5 25) (Just HkRead)+            ]+  , testSessionWait "type" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 2 8)+    liftIO $ highlights @?= List+            [ DocumentHighlight (R 2 7 2 10) (Just HkRead)+            , DocumentHighlight (R 3 11 3 14) (Just HkRead)+            ]+  , testSessionWait "local" $ do+    doc <- createDoc "A.hs" "haskell" source+    _ <- waitForDiagnostics+    highlights <- getHighlights doc (Position 6 5)+    liftIO $ highlights @?= List+            [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)+            , DocumentHighlight (R 6 10 6 13) (Just HkRead)+            , DocumentHighlight (R 7 12 7 15) (Just HkRead)+            ]+  , knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $+        testSessionWait "record" $ do+        doc <- createDoc "A.hs" "haskell" recsource+        _ <- waitForDiagnostics+        highlights <- getHighlights doc (Position 4 15)+        liftIO $ highlights @?= List+          -- Span is just the .. on 8.10, but Rec{..} before+          [ if ghcVersion >= GHC810+            then DocumentHighlight (R 4 8 4 10) (Just HkWrite)+            else DocumentHighlight (R 4 4 4 11) (Just HkWrite)+          , DocumentHighlight (R 4 14 4 20) (Just HkRead)+          ]+        highlights <- getHighlights doc (Position 3 17)+        liftIO $ highlights @?= List+          [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)+          -- Span is just the .. on 8.10, but Rec{..} before+          , if ghcVersion >= GHC810+              then DocumentHighlight (R 4 8 4 10) (Just HkRead)+              else DocumentHighlight (R 4 4 4 11) (Just HkRead)+          ]+  ]+  where+    source = T.unlines+      ["{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"+      ,"foo :: Int"+      ,"foo = 3 :: Int"+      ,"bar = foo"+      ,"  where baz = let x = foo in x"+      ,"baz arg = arg + x"+      ,"  where x = arg"+      ]+    recsource = T.unlines+      ["{-# LANGUAGE RecordWildCards #-}"+      ,"{-# OPTIONS_GHC -Wunused-binds #-}"+      ,"module Highlight () where"+      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"+      ,"foo Rec{..} = field2 + field1"+      ]++outlineTests :: TestTree+outlineTests = testGroup+  "outline"+  [ testSessionWait "type class" $ do+    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ moduleSymbol+          "A"+          (R 0 7 0 8)+          [ classSymbol "A a"+                        (R 1 0 1 30)+                        [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]+          ]+      ]+  , testSessionWait "type class instance " $ do+    let source = T.unlines ["class A a where", "instance A () where"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ classSymbol "A a" (R 0 0 0 15) []+      , docSymbol "A ()" SkInterface (R 1 0 1 19)+      ]+  , testSessionWait "type family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)]+  , testSessionWait "type family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "type family A a"+          , "type instance A () = ()"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "type family" SkFunction     (R 1 0 1 15)+      , docSymbol "A ()" SkInterface (R 2 0 2 23)+      ]+  , testSessionWait "data family" $ do+    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)]+  , testSessionWait "data family instance " $ do+    let source = T.unlines+          [ "{-# language TypeFamilies #-}"+          , "data family A a"+          , "data instance A () = A ()"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolD "A a"   "data family" SkFunction     (R 1 0 1 11)+      , docSymbol "A ()" SkInterface (R 2 0 2 25)+      ]+  , testSessionWait "constant" $ do+    let source = T.unlines ["a = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a" SkFunction (R 0 0 0 6)]+  , testSessionWait "pattern" $ do+    let source = T.unlines ["Just foo = Just 21"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "Just foo" SkFunction (R 0 0 0 18)]+  , testSessionWait "pattern with type signature" $ do+    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]+  , testSessionWait "function" $ do+    let source = T.unlines ["a _x = ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)]+  , testSessionWait "type synonym" $ do+    let source = T.unlines ["type A = Bool"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]+  , testSessionWait "datatype" $ do+    let source = T.unlines ["data A = C"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolWithChildren "A"+                              SkStruct+                              (R 0 0 0 10)+                              [docSymbol "C" SkConstructor (R 0 9 0 10)]+      ]+  , testSessionWait "record fields" $ do+    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)+          [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)+            [ docSymbol "x" SkField (R 1 2 1 3)+            , docSymbol "y" SkField (R 2 4 2 5)+            ]+          ]+      ]+  , testSessionWait "import" $ do+    let source = T.unlines ["import Data.Maybe ()"]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbolWithChildren "imports"+                             SkModule+                             (R 0 0 0 20)+                             [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20)+                             ]+      ]+  , testSessionWait "multiple import" $ do+    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left+      [docSymbolWithChildren "imports"+                             SkModule+                             (R 1 0 3 27)+                             [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20)+                             , docSymbol "import Control.Exception" SkModule (R 3 0 3 27)+                             ]+      ]+  , testSessionWait "foreign import" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign import ccall \"a\" a :: Int"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]+  , testSessionWait "foreign export" $ do+    let source = T.unlines+          [ "{-# language ForeignFunctionInterface #-}"+          , "foreign export ccall odd :: Int -> Bool"+          ]+    docId   <- createDoc "A.hs" "haskell" source+    symbols <- getDocumentSymbols docId+    liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]+  ]+ where+  docSymbol name kind loc =+    DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing+  docSymbol' name kind loc selectionLoc =+    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing+  docSymbolD name detail kind loc =+    DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing+  docSymbolWithChildren name kind loc cc =+    DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc)+  docSymbolWithChildren' name kind loc selectionLoc cc =+    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc)+  moduleSymbol name loc cc = DocumentSymbol name+                                            Nothing+                                            SkFile+                                            Nothing+                                            Nothing+                                            (R 0 0 maxBound 0)+                                            loc+                                            (Just $ List cc)+  classSymbol name loc cc = DocumentSymbol name+                                           (Just "class")+                                           SkInterface+                                           Nothing+                                           Nothing+                                           loc+                                           loc+                                           (Just $ List cc)++pattern R :: UInt -> UInt -> UInt -> UInt -> Range+pattern R x y x' y' = Range (Position x y) (Position x' y')++xfail :: TestTree -> String -> TestTree+xfail = flip expectFailBecause++ignoreInWindowsBecause :: String -> TestTree -> TestTree+ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)++ignoreInWindowsForGHC88And810 :: TestTree -> TestTree+ignoreInWindowsForGHC88And810 =+    ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10"++ignoreForGHC92Plus :: String -> TestTree -> TestTree+ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94])++ignoreInWindowsForGHC88 :: TestTree -> TestTree+ignoreInWindowsForGHC88 =+    ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8"++knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree+knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)++data BrokenOS = Linux | MacOS | Windows deriving (Show)++data IssueSolution = Broken | Ignore deriving (Show)++data BrokenTarget =+    BrokenSpecific BrokenOS [GhcVersion]+    -- ^Broken for `BrokenOS` with `GhcVersion`+    | BrokenForOS BrokenOS+    -- ^Broken for `BrokenOS`+    | BrokenForGHC [GhcVersion]+    -- ^Broken for `GhcVersion`+    deriving (Show)++-- | Ignore test for specific os and ghc with reason.+ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree+ignoreFor = knownIssueFor Ignore++-- | Known broken for specific os and ghc with reason.+knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree+knownBrokenFor = knownIssueFor Broken++-- | Deal with `IssueSolution` for specific OS and GHC.+knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree+knownIssueFor solution = go . \case+    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers+    BrokenForOS bos         -> isTargetOS bos+    BrokenForGHC vers       -> isTargetGhc vers+    where+        isTargetOS = \case+            Windows -> isWindows+            MacOS   -> isMac+            Linux   -> not isWindows && not isMac++        isTargetGhc = elem ghcVersion++        go True = case solution of+            Broken -> expectFailBecause+            Ignore -> ignoreTestBecause+        go False = \_ -> id++data Expect+  = ExpectRange Range -- Both gotoDef and hover should report this range+  | ExpectLocation Location+--  | ExpectDefRange Range -- Only gotoDef should report this range+  | ExpectHoverRange Range -- Only hover should report this range+  | ExpectHoverText [T.Text] -- the hover message must contain these snippets+  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern+  | ExpectExternFail -- definition lookup in other file expected to fail+  | ExpectNoDefinitions+  | ExpectNoHover+--  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples+  deriving Eq++mkR :: UInt -> UInt -> UInt -> UInt -> Expect+mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn++mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn++haddockTests :: TestTree+haddockTests+  = testGroup "haddock"+      [ testCase "Num" $ checkHaddock+          (unlines+             [ "However, '(+)' and '(*)' are"+             , "customarily expected to define a ring and have the following properties:"+             , ""+             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"+             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"+             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"+             ]+          )+          (unlines+             [ ""+             , ""+             , "However,  `(+)`  and  `(*)`  are"+             , "customarily expected to define a ring and have the following properties: "+             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"+             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"+             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"+             ]+          )+      , testCase "unsafePerformIO" $ checkHaddock+          (unlines+             [ "may require"+             , "different precautions:"+             , ""+             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"+             , "        the I\\/O may be performed more than once."+             , ""+             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"+             , "        elimination being performed on the module."+             , ""+             ]+          )+          (unlines+             [ ""+             , ""+             , "may require"+             , "different precautions: "+             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"+             , "  the I/O may be performed more than once."+             , ""+             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"+             , "  elimination being performed on the module."+             , ""+             ]+          )+      ]+  where+    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt++cradleTests :: TestTree+cradleTests = testGroup "cradle"+    [testGroup "dependencies" [sessionDepsArePickedUp]+    ,testGroup "ignore-fatal" [ignoreFatalWarning]+    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest]+    ,testGroup "sub-directory"   [simpleSubDirectoryTest]+    ]++loadCradleOnlyonce :: TestTree+loadCradleOnlyonce = testGroup "load cradle only once"+    [ testSession' "implicit" implicit+    , testSession' "direct"   direct+    ]+    where+        direct dir = do+            liftIO $ writeFileUTF8 (dir </> "hie.yaml")+                "cradle: {direct: {arguments: []}}"+            test dir+        implicit dir = test dir+        test _dir = do+            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"+            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 1+            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 0+            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 0++retryFailedCradle :: TestTree+retryFailedCradle = testSession' "retry failed" $ \dir -> do+  -- The false cradle always fails+  let hieContents = "cradle: {bios: {shell: \"false\"}}"+      hiePath = dir </> "hie.yaml"+  liftIO $ writeFile hiePath hieContents+  let aPath = dir </> "A.hs"+  doc <- createDoc aPath "haskell" "main = return ()"+  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess++  -- Fix the cradle and typecheck again+  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"+  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle+  sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]++  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess+++dependentFileTest :: TestTree+dependentFileTest = testGroup "addDependentFile"+    [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test]+    ]+    where+      test dir = do+        -- If the file contains B then no type error+        -- otherwise type error+        let depFilePath = dir </> "dep-file.txt"+        liftIO $ writeFile depFilePath "A"+        let fooContent = T.unlines+              [ "{-# LANGUAGE TemplateHaskell #-}"+              , "module Foo where"+              , "import Language.Haskell.TH.Syntax"+              , "foo :: Int"+              , "foo = 1 + $(do"+              , "               qAddDependentFile \"dep-file.txt\""+              , "               f <- qRunIO (readFile \"dep-file.txt\")"+              , "               if f == \"B\" then [| 1 |] else lift f)"+              ]+        let bazContent = T.unlines ["module Baz where", "import Foo ()"]+        _ <- createDoc "Foo.hs" "haskell" fooContent+        doc <- createDoc "Baz.hs" "haskell" bazContent+        expectDiagnostics $+            if ghcVersion >= GHC90+                -- String vs [Char] causes this change in error message+                then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])]+                else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]+        -- Now modify the dependent file+        liftIO $ writeFile depFilePath "B"+        sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri "dep-file.txt") FcChanged ]++        -- Modifying Baz will now trigger Foo to be rebuilt as well+        let change = TextDocumentContentChangeEvent+              { _range = Just (Range (Position 2 0) (Position 2 6))+              , _rangeLength = Nothing+              , _text = "f = ()"+              }+        changeDoc doc [change]+        expectDiagnostics [("Foo.hs", [])]+++cradleLoadedMessage :: Session FromServerMessage+cradleLoadedMessage = satisfy $ \case+        FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod+        _                                            -> False++cradleLoadedMethod :: T.Text+cradleLoadedMethod = "ghcide/cradle/loaded"++ignoreFatalWarning :: TestTree+ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do+    let srcPath = dir </> "IgnoreFatal.hs"+    src <- liftIO $ readFileUtf8 srcPath+    _ <- createDoc srcPath "haskell" src+    expectNoMoreDiagnostics 5++simpleSubDirectoryTest :: TestTree+simpleSubDirectoryTest =+  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do+    let mainPath = dir </> "a/src/Main.hs"+    mainSource <- liftIO $ readFileUtf8 mainPath+    _mdoc <- createDoc mainPath "haskell" mainSource+    expectDiagnosticsWithTags+      [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded+      ]+    expectNoMoreDiagnostics 0.5++simpleMultiTest :: TestTree+simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    adoc <- openDoc aPath "haskell"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc+    liftIO $ assertBool "A should typecheck" ideResultSuccess+    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc+    liftIO $ assertBool "B should typecheck" ideResultSuccess+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Like simpleMultiTest but open the files in the other order+simpleMultiTest2 :: TestTree+simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc+    TextDocumentIdentifier auri <- openDoc aPath "haskell"+    skipManyTill anyMessage $ isReferenceReady aPath+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL auri 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Now with 3 components+simpleMultiTest3 :: TestTree+simpleMultiTest3 =+  testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+        cPath = dir </> "c/C.hs"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc+    TextDocumentIdentifier auri <- openDoc aPath "haskell"+    skipManyTill anyMessage $ isReferenceReady aPath+    cdoc <- openDoc cPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc+    locs <- getDefinitions cdoc (Position 2 7)+    let fooL = mkL auri 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Like simpleMultiTest but open the files in component 'a' in a seperate session+simpleMultiDefTest :: TestTree+simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    adoc <- liftIO $ runInDir dir $ do+      aSource <- liftIO $ readFileUtf8 aPath+      adoc <- createDoc aPath "haskell" aSource+      skipManyTill anyMessage $ isReferenceReady aPath+      closeDoc adoc+      pure adoc+    bSource <- liftIO $ readFileUtf8 bPath+    bdoc <- createDoc bPath "haskell" bSource+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++ifaceTests :: TestTree+ifaceTests = testGroup "Interface loading tests"+    [ -- https://github.com/haskell/ghcide/pull/645/+      ifaceErrorTest+    , ifaceErrorTest2+    , ifaceErrorTest3+    , ifaceTHTest+    ]++bootTests :: TestTree+bootTests = testGroup "boot"+  [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do+        let cPath = dir </> "C.hs"+        cSource <- liftIO $ readFileUtf8 cPath+        -- Dirty the cache+        liftIO $ runInDir dir $ do+            cDoc <- createDoc cPath "haskell" cSource+            -- We send a hover request then wait for either the hover response or+            -- `ghcide/reference/ready` notification.+            -- Once we receive one of the above, we wait for the other that we+            -- haven't received yet.+            -- If we don't wait for the `ready` notification it is possible+            -- that the `getDefinitions` request/response in the outer ghcide+            -- session will find no definitions.+            let hoverParams = HoverParams cDoc (Position 4 3) Nothing+            hoverRequestId <- sendRequest STextDocumentHover hoverParams+            let parseReadyMessage = isReferenceReady cPath+            let parseHoverResponse = responseForId STextDocumentHover hoverRequestId+            hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))+            _ <- skipManyTill anyMessage $+              case hoverResponseOrReadyMessage of+                Left _  -> void parseReadyMessage+                Right _ -> void parseHoverResponse+            closeDoc cDoc+        cdoc <- createDoc cPath "haskell" cSource+        locs <- getDefinitions cdoc (Position 7 4)+        let floc = mkR 9 0 9 1+        checkDefs locs (pure [floc])+  , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do+      _ <- openDoc (dir </> "A.hs") "haskell"+      expectNoMoreDiagnostics 2+  ]++-- | test that TH reevaluates across interfaces+ifaceTHTest :: TestTree+ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do+    let aPath = dir </> "THA.hs"+        bPath = dir </> "THB.hs"+        cPath = dir </> "THC.hs"++    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()+    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()+    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()++    cdoc <- createDoc cPath "haskell" cSource++    -- Change [TH]a from () to Bool+    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])++    -- Check that the change propogates to C+    changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource]+    expectDiagnostics+      [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])+      ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]+    closeDoc cdoc++ifaceErrorTest :: TestTree+ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do+    configureCheckProject True+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded++    waitForProgressDone++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    -- save so that we can that the error propogates to A+    sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)+++    -- Check that the error propogates to A+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]+++    -- Check that we wrote the interfaces for B when we saved+    hidir <- getInterfaceFilesDir bdoc+    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"+    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists++    pdoc <- openDoc pPath "haskell"+    waitForProgressDone+    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]+    -- Now in P we have+    -- bar = x :: Int+    -- foo = y :: Bool+    -- HOWEVER, in A...+    -- x = y  :: Int+    -- This is clearly inconsistent, and the expected outcome a bit surprising:+    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics+    --   - P is being typechecked with the last successful artifacts for A.+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])+      ,("P.hs", [(DsWarning,(6,0), "Top-level binding")])+      ]+    expectNoMoreDiagnostics 2++ifaceErrorTest2 :: TestTree+ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource+    pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics+      [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]++    -- Add a new definition to P+    changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ]+    -- Now in P we have+    -- bar = x :: Int+    -- foo = y :: Bool+    -- HOWEVER, in A...+    -- x = y  :: Int+    expectDiagnostics+    -- As in the other test, P is being typechecked with the last successful artifacts for A+    -- (ot thanks to -fdeferred-type-errors)+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")])+      ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")])+      ]++    expectNoMoreDiagnostics 2++ifaceErrorTest3 :: TestTree+ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int++    bdoc <- createDoc bPath "haskell" bSource++    -- Change y from Int to B+    changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]++    -- P should not typecheck, as there are no last valid artifacts for A+    _pdoc <- createDoc pPath "haskell" pSource++    -- In this example the interface file for A should not exist (modulo the cache folder)+    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors+    expectDiagnostics+      [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ,("P.hs", [(DsWarning,(4,0), "Top-level binding")])+      ]+    expectNoMoreDiagnostics 2++sessionDepsArePickedUp :: TestTree+sessionDepsArePickedUp = testSession'+  "session-deps-are-picked-up"+  $ \dir -> do+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: []}}"+    -- Open without OverloadedStrings and expect an error.+    doc <- createDoc "Foo.hs" "haskell" fooContent+    expectDiagnostics $+        if ghcVersion >= GHC90+            -- String vs [Char] causes this change in error message+            then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])]+            else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]+    -- Update hie.yaml to enable OverloadedStrings.+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"+    sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+          List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]+    -- Send change event.+    let change =+          TextDocumentContentChangeEvent+            { _range = Just (Range (Position 4 0) (Position 4 0)),+              _rangeLength = Nothing,+              _text = "\n"+            }+    changeDoc doc [change]+    -- Now no errors.+    expectDiagnostics [("Foo.hs", [])]+  where+    fooContent =+      T.unlines+        [ "module Foo where",+          "import Data.Text",+          "foo :: Text",+          "foo = \"hello\""+        ]++-- A test to ensure that the command line ghcide workflow stays working+nonLspCommandLine :: TestTree+nonLspCommandLine = testGroup "ghcide command line"+  [ testCase "works" $ withTempDir $ \dir -> do+        ghcide <- locateGhcideExecutable+        copyTestDataFiles dir "multi"+        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}++        setEnv "HOME" "/homeless-shelter" False++        (ec, _, _) <- readCreateProcessWithExitCode cmd ""++        ec @?= ExitSuccess+  ]++-- | checks if we use InitializeParams.rootUri for loading session+rootUriTests :: TestTree+rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do+  let bPath = dir </> "dirB/Foo.hs"+  liftIO $ copyTestDataFiles dir "rootUri"+  bSource <- liftIO $ readFileUtf8 bPath+  _ <- createDoc "Foo.hs" "haskell" bSource+  expectNoMoreDiagnostics 0.5+  where+    -- similar to run' except we can configure where to start ghcide and session+    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()+    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)++-- | Test if ghcide asynchronously handles Commands and user Requests+asyncTests :: TestTree+asyncTests = testGroup "async"+    [+      testSession "command" $ do+            -- Execute a command that will block forever+            let req = ExecuteCommandParams Nothing blockCommandId Nothing+            void $ sendRequest SWorkspaceExecuteCommand req+            -- Load a file and check for code actions. Will only work if the command is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            codeLenses <- getCodeLenses doc+            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?+              [ "foo :: a -> a" ]+    , testSession "request" $ do+            -- Execute a custom request that will block for 1000 seconds+            void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000+            -- Load a file and check for code actions. Will only work if the request is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            codeLenses <- getCodeLenses doc+            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?+              [ "foo :: a -> a" ]+    ]+++clientSettingsTest :: TestTree+clientSettingsTest = testGroup "client settings handling"+    [ testSession "ghcide restarts shake session on config changes" $ do+            void $ skipManyTill anyMessage $ message SClientRegisterCapability+            void $ createDoc "A.hs" "haskell" "module A where"+            waitForProgressDone+            sendNotification SWorkspaceDidChangeConfiguration+                (DidChangeConfigurationParams (toJSON (mempty :: A.Object)))+            skipManyTill anyMessage restartingBuildSession++    ]+  where+    restartingBuildSession :: Session ()+    restartingBuildSession = do+        FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification+        guard $ "Restarting build session" `T.isInfixOf` _message++referenceTests :: TestTree+referenceTests = testGroup "references"+    [ testGroup "can get references to FOIs"+          [ referenceTest "can get references to symbols"+                          ("References.hs", 4, 7)+                          YesIncludeDeclaration+                          [ ("References.hs", 4, 6)+                          , ("References.hs", 6, 0)+                          , ("References.hs", 6, 14)+                          , ("References.hs", 9, 7)+                          , ("References.hs", 10, 11)+                          ]++          , referenceTest "can get references to data constructor"+                          ("References.hs", 13, 2)+                          YesIncludeDeclaration+                          [ ("References.hs", 13, 2)+                          , ("References.hs", 16, 14)+                          , ("References.hs", 19, 21)+                          ]++          , referenceTest "getting references works in the other module"+                          ("OtherModule.hs", 6, 0)+                          YesIncludeDeclaration+                          [ ("OtherModule.hs", 6, 0)+                          , ("OtherModule.hs", 8, 16)+                          ]++          , referenceTest "getting references works in the Main module"+                          ("Main.hs", 9, 0)+                          YesIncludeDeclaration+                          [ ("Main.hs", 9, 0)+                          , ("Main.hs", 10, 4)+                          ]++          , referenceTest "getting references to main works"+                          ("Main.hs", 5, 0)+                          YesIncludeDeclaration+                          [ ("Main.hs", 4, 0)+                          , ("Main.hs", 5, 0)+                          ]++          , referenceTest "can get type references"+                          ("Main.hs", 9, 9)+                          YesIncludeDeclaration+                          [ ("Main.hs", 9, 0)+                          , ("Main.hs", 9, 9)+                          , ("Main.hs", 10, 0)+                          ]++          , expectFailBecause "references provider does not respect includeDeclaration parameter" $+ referenceTest "works when we ask to exclude declarations"+                          ("References.hs", 4, 7)+                          NoExcludeDeclaration+                          [ ("References.hs", 6, 0)+                          , ("References.hs", 6, 14)+                          , ("References.hs", 9, 7)+                          , ("References.hs", 10, 11)+                          ]++          , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"+                          ("References.hs", 4, 7)+                          NoExcludeDeclaration+                          [ ("References.hs", 4, 6)+                          , ("References.hs", 6, 0)+                          , ("References.hs", 6, 14)+                          , ("References.hs", 9, 7)+                          , ("References.hs", 10, 11)+                          ]+          ]++    , testGroup "can get references to non FOIs"+          [ referenceTest "can get references to symbol defined in a module we import"+                          ("References.hs", 22, 4)+                          YesIncludeDeclaration+                          [ ("References.hs", 22, 4)+                          , ("OtherModule.hs", 0, 20)+                          , ("OtherModule.hs", 4, 0)+                          ]++          , referenceTest "can get references in modules that import us to symbols we define"+                          ("OtherModule.hs", 4, 0)+                          YesIncludeDeclaration+                          [ ("References.hs", 22, 4)+                          , ("OtherModule.hs", 0, 20)+                          , ("OtherModule.hs", 4, 0)+                          ]++          , referenceTest "can get references to symbol defined in a module we import transitively"+                          ("References.hs", 24, 4)+                          YesIncludeDeclaration+                          [ ("References.hs", 24, 4)+                          , ("OtherModule.hs", 0, 48)+                          , ("OtherOtherModule.hs", 2, 0)+                          ]++          , referenceTest "can get references in modules that import us transitively to symbols we define"+                          ("OtherOtherModule.hs", 2, 0)+                          YesIncludeDeclaration+                          [ ("References.hs", 24, 4)+                          , ("OtherModule.hs", 0, 48)+                          , ("OtherOtherModule.hs", 2, 0)+                          ]++          , referenceTest "can get type references to other modules"+                          ("Main.hs", 12, 10)+                          YesIncludeDeclaration+                          [ ("Main.hs", 12, 7)+                          , ("Main.hs", 13, 0)+                          , ("References.hs", 12, 5)+                          , ("References.hs", 16, 0)+                          ]+          ]+    ]++-- | When we ask for all references to symbol "foo", should the declaration "foo+-- = 2" be among the references returned?+data IncludeDeclaration =+    YesIncludeDeclaration+    | NoExcludeDeclaration++getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location)+getReferences' (file, l, c) includeDeclaration = do+    doc <- openDoc file "haskell"+    getReferences doc (Position l c) $ toBool includeDeclaration+    where toBool YesIncludeDeclaration = True+          toBool NoExcludeDeclaration  = False++referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree+referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do+  -- needed to build whole project indexing+  configureCheckProject True+  let docs = map (dir </>) $ delete thisDoc $ nubOrd docs'+  -- Initial Index+  docid <- openDoc thisDoc "haskell"+  let+    loop :: [FilePath] -> Session ()+    loop [] = pure ()+    loop docs = do+      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)+      loop (delete doc docs)+  loop docs+  f dir+  closeDoc docid++-- | Given a location, lookup the symbol and all references to it. Make sure+-- they are the ones we expect.+referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree+referenceTest name loc includeDeclaration expected =+    referenceTestSession name (fst3 loc) docs $ \dir -> do+        List actual <- getReferences' loc includeDeclaration+        liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected+  where+    docs = map fst3 expected++type SymbolLocation = (FilePath, UInt, UInt)++expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion+expectSameLocations actual expected = do+    let actual' =+            Set.map (\location -> (location ^. L.uri+                                   , location ^. L.range . L.start . L.line . to fromIntegral+                                   , location ^. L.range . L.start . L.character . to fromIntegral))+            $ Set.fromList actual+    expected' <- Set.fromList <$>+        (forM expected $ \(file, l, c) -> do+                              fp <- canonicalizePath file+                              return (filePathToUri fp, l, c))+    actual' @?= expected'++----------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------++testSession :: String -> Session () -> TestTree+testSession name = testCase name . run++testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix++testSession' :: String -> (FilePath -> Session ()) -> TestTree+testSession' name = testCase name . run'++testSessionWait :: HasCallStack => String -> Session () -> TestTree+testSessionWait name = testSession name .+      -- Check that any diagnostics produced were already consumed by the test case.+      --+      -- If in future we add test cases where we don't care about checking the diagnostics,+      -- this could move elsewhere.+      --+      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.+      ( >> expectNoMoreDiagnostics 0.5)++mkRange :: UInt -> UInt -> UInt -> UInt -> Range+mkRange a b c d = Range (Position a b) (Position c d)++run :: Session a -> IO a+run s = run' (const s)++runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a+runWithExtraFiles prefix s = withTempDir $ \dir -> do+  copyTestDataFiles dir prefix+  runInDir dir (s dir)++copyTestDataFiles :: FilePath -> FilePath -> IO ()+copyTestDataFiles dir prefix = do+  -- Copy all the test data files to the temporary workspace+  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]+  for_ testDataFiles $ \f -> do+    createDirectoryIfMissing True $ dir </> takeDirectory f+    copyFile ("test/data" </> prefix </> f) (dir </> f)++run' :: (FilePath -> Session a) -> IO a+run' s = withTempDir $ \dir -> runInDir dir (s dir)++runInDir :: FilePath -> Session a -> IO a+runInDir dir = runInDir' dir "." "." []++withLongTimeout :: IO a -> IO a+withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")++-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.+runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a+runInDir' = runInDir'' lspTestCaps++runInDir''+    :: ClientCapabilities+    -> FilePath+    -> FilePath+    -> FilePath+    -> [String]+    -> Session b+    -> IO b+runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do++  ghcideExe <- locateGhcideExecutable+  let startDir = dir </> startExeIn+  let projDir = dir </> startSessionIn++  createDirectoryIfMissing True startDir+  createDirectoryIfMissing True projDir+  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56+  -- since the package import test creates "Data/List.hs", which otherwise has no physical home+  createDirectoryIfMissing True $ projDir ++ "/Data"++  shakeProfiling <- getEnv "SHAKE_PROFILING"+  let cmd = unwords $+       [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir+       ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]+       ] ++ extraOptions+  -- HIE calls getXgdDirectory which assumes that HOME is set.+  -- Only sets HOME if it wasn't already set.+  setEnv "HOME" "/homeless-shelter" False+  conf <- getConfigFromEnv+  runSessionWithConfig conf cmd lspCaps projDir $ do+      configureCheckProject False+      s+++getConfigFromEnv :: IO SessionConfig+getConfigFromEnv = do+  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"+  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"+  return defaultConfig+    { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride+    , logColor+    }+  where+    checkEnv :: String -> IO (Maybe Bool)+    checkEnv s = fmap convertVal <$> getEnv s+    convertVal "0" = False+    convertVal _   = True++lspTestCaps :: ClientCapabilities+lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }++lspTestCapsNoFileWatches :: ClientCapabilities+lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing++openTestDataDoc :: FilePath -> Session TextDocumentIdentifier+openTestDataDoc path = do+  source <- liftIO $ readFileUtf8 $ "test/data" </> path+  createDoc path "haskell" source++unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree+unitTests recorder logger = do+  testGroup "Unit"+     [ testCase "empty file path does NOT work with the empty String literal" $+         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."+     , testCase "empty file path works using toNormalizedFilePath'" $+         uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""+     , testCase "empty path URI" $ do+         Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)+         uriScheme @?= "file:"+         uriPath @?= ""+     , testCase "from empty path URI" $ do+         let uri = Uri "file://"+         uriToFilePath' uri @?= Just ""+     , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do+         let diag = ("", Diagnostics.ShowDiag, Diagnostic+               { _range = Range+                   { _start = Position{_line = 0, _character = 1}+                   , _end = Position{_line = 2, _character = 3}+                   }+               , _severity = Nothing+               , _code = Nothing+               , _source = Nothing+               , _message = ""+               , _relatedInformation = Nothing+               , _tags = Nothing+               })+         let shown = T.unpack (Diagnostics.showDiagnostics [diag])+         let expected = "1:2-3:4"+         assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $+             expected `isInfixOf` shown+     , testCase "notification handlers run in priority order" $ do+        orderRef <- newIORef []+        let plugins = pluginDescToIdePlugins $+                [ (priorityPluginDescriptor i)+                    { pluginNotificationHandlers = mconcat+                        [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ ->+                            liftIO $ atomicModifyIORef_ orderRef (i:)+                        ]+                    }+                    | i <- [1..20]+                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)+            priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i}++        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do+            _ <- createDoc "A.hs" "haskell" "module A where"+            waitForProgressDone+            actualOrder <- liftIO $ reverse <$> readIORef orderRef++            -- Handlers are run in priority descending order+            liftIO $ actualOrder @?= [20, 19 .. 1]+     , ignoreTestBecause "The test fails sometimes showing 10000us" $+         testCase "timestamps have millisecond resolution" $ do+           resolution_us <- findResolution_us 1+           let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us+           assertBool msg (resolution_us <= 1000)+     , Progress.tests+     , FuzzySearch.tests+     ]++garbageCollectionTests :: TestTree+garbageCollectionTests = testGroup "garbage collection"+  [ testGroup "dirty keys"+        [ testSession' "are collected" $ \dir -> do+            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+            doc <- generateGarbage "A" dir+            closeDoc doc+            garbage <- waitForGC+            liftIO $ assertBool "no garbage was found" $ not $ null garbage++        , testSession' "are deleted from the state" $ \dir -> do+            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+            docA <- generateGarbage "A" dir+            keys0 <- getStoredKeys+            closeDoc docA+            garbage <- waitForGC+            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage+            keys1 <- getStoredKeys+            liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)++        , testSession' "are not regenerated unless needed" $ \dir -> do+            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"+            docA <- generateGarbage "A" dir+            _docB <- generateGarbage "B" dir++            -- garbage collect A keys+            keysBeforeGC <- getStoredKeys+            closeDoc docA+            garbage <- waitForGC+            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage+            keysAfterGC <- getStoredKeys+            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"+                (length keysAfterGC < length keysBeforeGC)++            -- re-typecheck B and check that the keys for A have not materialized back+            _docB <- generateGarbage "B" dir+            keysB <- getStoredKeys+            let regeneratedKeys = Set.filter (not . isExpected) $+                    Set.intersection (Set.fromList garbage) (Set.fromList keysB)+            liftIO $ regeneratedKeys @?= mempty++        , testSession' "regenerate successfully" $ \dir -> do+            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"+            docA <- generateGarbage "A" dir+            closeDoc docA+            garbage <- waitForGC+            liftIO $ assertBool "no garbage was found" $ not $ null garbage+            let edit = T.unlines+                        [ "module A where"+                        , "a :: Bool"+                        , "a = ()"+                        ]+            doc <- generateGarbage "A" dir+            changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit]+            builds <- waitForTypecheck doc+            liftIO $ assertBool "it still builds" builds+            expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")]+        ]+  ]+  where+    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]++    generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier+    generateGarbage modName dir = do+        let fp = modName <> ".hs"+            body = printf "module %s where" modName+        doc <- createDoc fp "haskell" (T.pack body)+        liftIO $ writeFile (dir </> fp) body+        builds <- waitForTypecheck doc+        liftIO $ assertBool "something is wrong with this test" builds+        return doc++findResolution_us :: Int -> IO Int+findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"+findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do+    performGC+    writeFile f ""+    threadDelay delay_us+    writeFile f' ""+    t <- getModTime f+    t' <- getModTime f'+    if t /= t' then return delay_us else findResolution_us (delay_us * 10)+++testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()+testIde recorder arguments session = do+    config <- getConfigFromEnv+    cwd <- getCurrentDirectory+    (hInRead, hInWrite) <- createPipe+    (hOutRead, hOutWrite) <- createPipe+    let projDir = "."+    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments+            { IDE.argsHandleIn = pure hInRead+            , IDE.argsHandleOut = pure hOutWrite+            }++    flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->+        runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session++positionMappingTests :: Recorder (WithPriority Log) -> TestTree+positionMappingTests recorder =+    testGroup "position mapping"+        [ testGroup "toCurrent"+              [ testCase "before" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= PositionExact (Position 0 0)+              , testCase "after, same line, same length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= PositionExact (Position 0 3)+              , testCase "after, same line, increased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 3) @?= PositionExact (Position 0 4)+              , testCase "after, same line, decreased length" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 3) @?= PositionExact (Position 0 2)+              , testCase "after, next line, no newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= PositionExact (Position 1 3)+              , testCase "after, next line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 1 0) @?= PositionExact (Position 2 0)+              , testCase "after, same line, newline" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 0 4) @?= PositionExact (Position 1 2)+              , testCase "after, same line, newline + newline at end" $+                toCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd\n"+                    (Position 0 4) @?= PositionExact (Position 2 1)+              , testCase "after, same line, newline + newline at end" $+                toCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 1) @?= PositionExact (Position 0 4)+              ]+        , testGroup "fromCurrent"+              [ testCase "before" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 0) @?= PositionExact (Position 0 0)+              , testCase "after, same line, same length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "ab"+                    (Position 0 3) @?= PositionExact (Position 0 3)+              , testCase "after, same line, increased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 0 4) @?= PositionExact (Position 0 3)+              , testCase "after, same line, decreased length" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "a"+                    (Position 0 2) @?= PositionExact (Position 0 3)+              , testCase "after, next line, no newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc"+                    (Position 1 3) @?= PositionExact (Position 1 3)+              , testCase "after, next line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\ndef"+                    (Position 2 0) @?= PositionExact (Position 1 0)+              , testCase "after, same line, newline" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd"+                    (Position 1 2) @?= PositionExact (Position 0 4)+              , testCase "after, same line, newline + newline at end" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 3))+                    "abc\nd\n"+                    (Position 2 1) @?= PositionExact (Position 0 4)+              , testCase "after, same line, newline + newline at end" $+                fromCurrent+                    (Range (Position 0 1) (Position 0 1))+                    "abc"+                    (Position 0 4) @?= PositionExact (Position 0 1)+              ]+        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"+              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do+                -- Note that it is important to use suchThatMap on all values at once+                -- instead of only using it on the position. Otherwise you can get+                -- into situations where there is no position that can be mapped back+                -- for the edit which will result in QuickCheck looping forever.+                let gen = do+                        rope <- genRope+                        range <- genRange rope+                        PrintableText replacement <- arbitrary+                        oldPos <- genPosition rope+                        pure (range, replacement, oldPos)+                forAll+                    (suchThatMap gen+                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $+                    \(range, replacement, oldPos, newPos) ->+                    fromCurrent range replacement newPos === PositionExact oldPos+              , testProperty "toCurrent r t <=< fromCurrent r t" $ do+                let gen = do+                        rope <- genRope+                        range <- genRange rope+                        PrintableText replacement <- arbitrary+                        let newRope = runIdentity $ applyChange mempty rope+                                (TextDocumentContentChangeEvent (Just range) Nothing replacement)+                        newPos <- genPosition newRope+                        pure (range, replacement, newPos)+                forAll+                    (suchThatMap gen+                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $+                    \(range, replacement, newPos, oldPos) ->+                    toCurrent range replacement oldPos === PositionExact newPos+              ]+        ]++newtype PrintableText = PrintableText { getPrintableText :: T.Text }+    deriving Show++instance Arbitrary PrintableText where+    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary+++genRope :: Gen Rope+genRope = Rope.fromText . getPrintableText <$> arbitrary++genPosition :: Rope -> Gen Position+genPosition r = do+    let rows :: Int = fromIntegral $ Rope.lengthInLines r+    row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt+    let columns = T.length (nthLine (fromIntegral row) r)+    column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt+    pure $ Position (fromIntegral row) (fromIntegral column)++genRange :: Rope -> Gen Range+genRange r = do+    let rows :: Int = fromIntegral $ Rope.lengthInLines r+    startPos@(Position startLine startColumn) <- genPosition r+    let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine+    endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt+    let columns = T.length (nthLine (fromIntegral endLine) r)+    endColumn <-+        if fromIntegral startLine == endLine+            then choose (fromIntegral startColumn, columns)+            else choose (0, max 0 $ columns - 1)+        `suchThat` inBounds @UInt+    pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn))++inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool+inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b)++-- | Get the ith line of a rope, starting from 0. Trailing newline not included.+nthLine :: Int -> Rope -> T.Text+nthLine i r+    | Rope.null r = ""+    | otherwise = Rope.lines r !! i++getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]+getWatchedFilesSubscriptionsUntil m = do+      msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m)+      return+            [ args+            | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs+            , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs+            ]++-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path+-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or+-- @/var@+withTempDir :: (FilePath -> IO a) -> IO a+withTempDir f = System.IO.Extra.withTempDir $ \dir -> do+  dir' <- canonicalizePath dir+  f dir'+  -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text
test/src/Development/IDE/Test.hs view
@@ -29,11 +29,6 @@   , getStoredKeys   , waitForCustomMessage   , waitForGC-  , getBuildKeysBuilt-  , getBuildKeysVisited-  , getBuildKeysChanged-  , getBuildEdgesCount-  , getRebuildsCount   , configureCheckProject   , isReferenceReady   , referenceReady) where@@ -63,9 +58,9 @@                                                   SemanticTokensEdit (_start)) import           Language.LSP.Types.Lens         as Lsp import           System.Directory                (canonicalizePath)+import           System.FilePath                 (equalFilePath) import           System.Time.Extra import           Test.Tasty.HUnit-import System.FilePath (equalFilePath)  requireDiagnosticM     :: (Foldable f, Show (f Diagnostic), HasCallStack)@@ -83,7 +78,7 @@   expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do     let fileUri = diagsNot ^. params . uri         actual = diagsNot ^. params . diagnostics-    liftIO $+    unless (actual == List []) $ liftIO $       assertFailure $         "Got unexpected diagnostics for " <> show fileUri           <> " got "@@ -213,21 +208,6 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult waitForAction key TextDocumentIdentifier{_uri} =     callTestPlugin (WaitForIdeRule key _uri)--getBuildKeysBuilt :: Session (Either ResponseError [T.Text])-getBuildKeysBuilt = tryCallTestPlugin GetBuildKeysBuilt--getBuildKeysVisited :: Session (Either ResponseError [T.Text])-getBuildKeysVisited = tryCallTestPlugin GetBuildKeysVisited--getBuildKeysChanged :: Session (Either ResponseError [T.Text])-getBuildKeysChanged = tryCallTestPlugin GetBuildKeysChanged--getBuildEdgesCount :: Session (Either ResponseError Int)-getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount--getRebuildsCount :: Session (Either ResponseError Int)-getRebuildsCount = tryCallTestPlugin GetRebuildsCount  getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)