ghcide 1.4.2.3 → 1.5.0
raw patch · 64 files changed
+4484/−1923 lines, 64 filesdep +exceptionsdep −ghc-api-compatdep ~hiedbdep ~hls-graphdep ~hls-plugin-api
Dependencies added: exceptions
Dependencies removed: ghc-api-compat
Dependency ranges changed: hiedb, hls-graph, hls-plugin-api, prettyprinter
Files
- bench/lib/Experiments.hs +57/−20
- exe/Arguments.hs +11/−9
- exe/Main.hs +15/−17
- ghcide.cabal +50/−22
- session-loader/Development/IDE/Session.hs +59/−68
- src/Development/IDE/Core/Actions.hs +4/−9
- src/Development/IDE/Core/Compile.hs +131/−122
- src/Development/IDE/Core/FileExists.hs +2/−6
- src/Development/IDE/Core/FileStore.hs +13/−21
- src/Development/IDE/Core/OfInterest.hs +23/−4
- src/Development/IDE/Core/Preprocessor.hs +48/−45
- src/Development/IDE/Core/RuleTypes.hs +14/−50
- src/Development/IDE/Core/Rules.hs +151/−123
- src/Development/IDE/Core/Shake.hs +177/−86
- src/Development/IDE/Core/Tracing.hs +117/−53
- src/Development/IDE/Core/UseStale.hs +4/−3
- src/Development/IDE/GHC/CPP.hs +21/−187
- src/Development/IDE/GHC/Compat.hs +109/−407
- src/Development/IDE/GHC/Compat/CPP.hs +204/−0
- src/Development/IDE/GHC/Compat/Core.hs +860/−0
- src/Development/IDE/GHC/Compat/Env.hs +284/−0
- src/Development/IDE/GHC/Compat/Iface.hs +41/−0
- src/Development/IDE/GHC/Compat/Logger.hs +56/−0
- src/Development/IDE/GHC/Compat/Outputable.hs +165/−0
- src/Development/IDE/GHC/Compat/Parser.hs +117/−0
- src/Development/IDE/GHC/Compat/Plugins.hs +73/−0
- src/Development/IDE/GHC/Compat/Units.hs +342/−0
- src/Development/IDE/GHC/Compat/Util.hs +115/−0
- src/Development/IDE/GHC/Error.hs +27/−37
- src/Development/IDE/GHC/ExactPrint.hs +19/−13
- src/Development/IDE/GHC/Orphans.hs +25/−9
- src/Development/IDE/GHC/Util.hs +71/−51
- src/Development/IDE/GHC/Warnings.hs +8/−8
- src/Development/IDE/Import/DependencyInformation.hs +1/−0
- src/Development/IDE/Import/FindImports.hs +24/−28
- src/Development/IDE/LSP/LanguageServer.hs +2/−1
- src/Development/IDE/LSP/Notifications.hs +28/−22
- src/Development/IDE/LSP/Outline.hs +18/−20
- src/Development/IDE/Main.hs +63/−27
- src/Development/IDE/Plugin/CodeAction.hs +27/−38
- src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +3/−7
- src/Development/IDE/Plugin/Completions.hs +45/−12
- src/Development/IDE/Plugin/Completions/Logic.hs +151/−83
- src/Development/IDE/Plugin/Completions/Types.hs +8/−2
- src/Development/IDE/Plugin/Test.hs +67/−23
- src/Development/IDE/Plugin/TypeLenses.hs +5/−24
- src/Development/IDE/Spans/AtPoint.hs +26/−25
- src/Development/IDE/Spans/Common.hs +5/−16
- src/Development/IDE/Spans/Documentation.hs +12/−19
- src/Development/IDE/Spans/LocalBindings.hs +5/−4
- src/Development/IDE/Types/Diagnostics.hs +9/−5
- src/Development/IDE/Types/Exports.hs +33/−10
- src/Development/IDE/Types/HscEnvEq.hs +30/−40
- src/Development/IDE/Types/Location.hs +7/−1
- src/Development/IDE/Types/Logger.hs +5/−0
- src/Development/IDE/Types/Options.hs +7/−4
- src/Development/IDE/Types/Shake.hs +26/−42
- src/Text/Fuzzy/Parallel.hs +70/−13
- test/data/hiding/HideFunctionWithoutLocal.expected.hs +14/−0
- test/data/hiding/HideFunctionWithoutLocal.hs +13/−0
- test/data/hiding/HidePreludeLocalInfix.expected.hs +9/−0
- test/data/hiding/HidePreludeLocalInfix.hs +8/−0
- test/exe/Main.hs +273/−77
- test/src/Development/IDE/Test.hs +77/−10
bench/lib/Experiments.hs view
@@ -26,11 +26,17 @@ 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) import Development.IDE.Test.Diagnostic import Development.Shake (CmdOption (Cwd, FileStdout), cmd_)@@ -152,21 +158,22 @@ benchWithSetup "code actions after cradle 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]+ 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 ]- forM_ docs $ \DocumentPositions{..} -> do- changeDoc doc [charEdit stringLiteralP]- waitForProgressStart+ waitForProgressStart+ waitForProgressStart+ waitForProgressStart -- the Session logic restarts a second time waitForProgressDone- not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do+ not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do forM identifierP $ \p -> getCodeActions doc (Range p p)) ),@@ -322,6 +329,11 @@ , "userTime" , "delayedTime" , "totalTime"+ , "buildRulesBuilt"+ , "buildRulesChanged"+ , "buildRulesVisited"+ , "buildRulesTotal"+ , "buildEdges" ] rows = [ [ name,@@ -331,7 +343,12 @@ show runSetup', show userWaits, show delayedWork,- show runExperiment+ show runExperiment,+ show rulesBuilt,+ show rulesChanged,+ show rulesVisited,+ show rulesTotal,+ show edgesTotal ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup@@ -351,7 +368,12 @@ showDuration runSetup', showDuration userWaits, showDuration delayedWork,- showDuration runExperiment+ showDuration runExperiment,+ show rulesBuilt,+ show rulesChanged,+ show rulesVisited,+ show rulesTotal,+ show edgesTotal ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup@@ -397,11 +419,16 @@ runExperiment :: !Seconds, userWaits :: !Seconds, delayedWork :: !Seconds,+ rulesBuilt :: !Int,+ rulesChanged :: !Int,+ rulesVisited :: !Int,+ rulesTotal :: !Int,+ edgesTotal :: !Int, success :: !Bool } badRun :: BenchRun-badRun = BenchRun 0 0 0 0 0 False+badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False waitForProgressStart :: Session () waitForProgressStart = void $ do@@ -421,6 +448,17 @@ 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) ->@@ -451,19 +489,18 @@ else do output (showDuration t) -- Wait for the delayed actions to finish- let m = SCustomMethod "test"- waitId <- sendRequest m (toJSON WaitForShakeQueue)- (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId- case resp of- ResponseMessage{_result=Right Null} -> do- loop (userWaits+t) (delayedWork+td) (n -1)- _ ->- -- Assume a ghcide build lacking the WaitForShakeQueue command- loop (userWaits+t) delayedWork (n -1)+ td <- waitForBuildQueue+ loop (userWaits+t) (delayedWork+td) (n -1) (runExperiment, result) <- duration $ loop 0 0 samples let success = isJust result (userWaits, delayedWork) = fromMaybe (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 return BenchRun {..}
exe/Arguments.hs view
@@ -9,15 +9,16 @@ import Options.Applicative data Arguments = Arguments- {argsCwd :: Maybe FilePath- ,argsVersion :: Bool- ,argsShakeProfiling :: Maybe FilePath- ,argsOTMemoryProfiling :: Bool- ,argsTesting :: Bool- ,argsDisableKick :: Bool- ,argsThreads :: Int- ,argsVerbose :: Bool- ,argsCommand :: Command+ {argsCwd :: Maybe FilePath+ ,argsVersion :: Bool+ ,argsShakeProfiling :: Maybe FilePath+ ,argsOTMemoryProfiling :: Bool+ ,argsTesting :: Bool+ ,argsDisableKick :: Bool+ ,argsThreads :: Int+ ,argsVerbose :: Bool+ ,argsCommand :: Command+ ,argsConservativeChangeTracking :: Bool } getArguments :: IdePlugins IdeState -> IO Arguments@@ -38,6 +39,7 @@ <*> 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)") 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
@@ -8,16 +8,17 @@ import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless, whenJust)-import Data.Default (Default (def))+import Data.Default (def) import Data.Version (showVersion) import Development.GitRev (gitHash)-import Development.IDE (action)+import Development.IDE (Priority (Debug, Info),+ action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule)+import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde-import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins)@@ -40,7 +41,7 @@ <> gitHashSection main :: IO ()-main = do+main = withTelemetryLogger $ \telemetryLogger -> do let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work@@ -51,34 +52,31 @@ whenJust argsCwd IO.setCurrentDirectory - Main.defaultMain def+ let logPriority = if argsVerbose then Debug else Info+ arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority++ Main.defaultMain arguments {Main.argCommand = argsCommand+ ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger ,Main.argsRules = do -- install the main and ghcide-plugin rules- mainRule+ mainRule def -- install the kick action, which triggers a typecheck on every -- Shake database restart, i.e. on every user edit. unless argsDisableKick $ action kick - ,Main.argsHlsPlugins =- pluginDescToIdePlugins $- GhcIde.descriptors- ++ [Test.blockCommandDescriptor "block-command" | argsTesting]-- ,Main.argsGhcidePlugin = if argsTesting- then Test.plugin- else mempty+ ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) - ,Main.argsIdeOptions = \config sessionLoader ->- let defOptions = defaultIdeOptions sessionLoader+ ,Main.argsIdeOptions = \config sessionLoader ->+ let defOptions = Main.argsIdeOptions arguments config sessionLoader in defOptions { optShakeProfiling = argsShakeProfiling , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling- , optTesting = IdeTesting argsTesting , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config+ , optRunSubset = not argsConservativeChangeTracking } }
ghcide.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-version: 1.4.2.3+version: 1.5.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors@@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues-tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1+tested-with: GHC == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal@@ -48,6 +48,7 @@ dependent-map, dependent-sum, dlist,+ exceptions, -- we can't use >= 1.7.10 while we have to use hlint == 3.2.* extra >= 1.7.4 && < 1.7.10, fuzzy,@@ -61,7 +62,7 @@ hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.2.0.0, lens,- hiedb == 0.4.0.*,+ hiedb == 0.4.1.*, lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, monoid-subclasses,@@ -70,13 +71,13 @@ optparse-applicative, parallel, prettyprinter-ansi-terminal,- prettyprinter,+ prettyprinter >= 1.7, regex-tdfa >= 1.3.1.0, retrie, rope-utf16-splay, safe, safe-exceptions,- hls-graph ^>= 1.4,+ hls-graph ^>= 1.5.1, sorted-list, sqlite-simple, stm,@@ -112,22 +113,6 @@ build-depends: unix - if impl(ghc < 8.10.5)- build-depends:- ghc-api-compat ==8.6- elif impl(ghc == 8.10.5)- build-depends:- ghc-api-compat ==8.10.5- elif impl(ghc == 8.10.6)- build-depends:- ghc-api-compat ==8.10.6- elif impl(ghc == 8.10.7)- build-depends:- ghc-api-compat ==8.10.7- elif impl(ghc == 9.0.1)- build-depends:- ghc-api-compat ==9.0.1- default-extensions: ApplicativeDo BangPatterns@@ -173,6 +158,15 @@ Development.IDE.Core.Tracing Development.IDE.Core.UseStale Development.IDE.GHC.Compat+ Development.IDE.GHC.Compat.Core+ Development.IDE.GHC.Compat.Env+ Development.IDE.GHC.Compat.Iface+ Development.IDE.GHC.Compat.Logger+ Development.IDE.GHC.Compat.Outputable+ Development.IDE.GHC.Compat.Parser+ Development.IDE.GHC.Compat.Plugins+ Development.IDE.GHC.Compat.Units+ Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint@@ -219,11 +213,24 @@ Development.IDE.Types.Action Text.Fuzzy.Parallel - ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors+ ghc-options:+ -Wall+ -Wno-name-shadowing+ -Wincomplete-uni-patterns+ -Wno-unticked-promoted-constructors+ -fno-ignore-asserts if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if impl(ghc < 8.10)+ exposed-modules:+ Development.IDE.GHC.Compat.CPP++flag test-exe+ description: Build the ghcide-test-preprocessor executable+ default: True+ executable ghcide-test-preprocessor default-language: Haskell2010 hs-source-dirs: test/preprocessor@@ -232,6 +239,9 @@ build-depends: base == 4.* + if !flag(test-exe)+ buildable: False+ benchmark benchHist type: exitcode-stdio-1.0 default-language: Haskell2010@@ -265,11 +275,16 @@ directory, extra, filepath,+ lens, optparse-applicative, shake, text, yaml +flag executable+ description: Build the ghcide executable+ default: True+ executable ghcide default-language: Haskell2010 hs-source-dirs: exe@@ -329,6 +344,9 @@ TypeApplications ViewPatterns + if !flag(executable)+ buildable: False+ test-suite ghcide-tests type: exitcode-stdio-1.0 default-language: Haskell2010@@ -411,6 +429,10 @@ TypeApplications ViewPatterns +flag bench-exe+ description: Build the ghcide-bench executable+ default: True+ executable ghcide-bench default-language: Haskell2010 build-tool-depends:@@ -424,6 +446,7 @@ extra, filepath, ghcide,+ hls-plugin-api, lens, lsp-test, lsp-types,@@ -432,11 +455,13 @@ 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@@ -455,3 +480,6 @@ TupleSections TypeApplications ViewPatterns++ if !flag(bench-exe)+ buildable: False
session-loader/Development/IDE/Session.hs view
@@ -19,7 +19,7 @@ import Control.Concurrent.Async import Control.Concurrent.Strict-import Control.Exception.Safe+import Control.Exception.Safe as Safe import Control.Monad import Control.Monad.Extra import Control.Monad.IO.Class@@ -42,9 +42,13 @@ import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat hiding (Target,- TargetFile, TargetModule)-import qualified Development.IDE.GHC.Compat as GHC+import qualified Development.IDE.GHC.Compat as Compat+import Development.IDE.GHC.Compat.Core hiding (Target,+ TargetFile, TargetModule,+ Var)+import qualified Development.IDE.GHC.Compat.Core as GHC+import Development.IDE.GHC.Compat.Env hiding (Logger)+import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck@@ -71,17 +75,12 @@ import Control.Applicative (Alternative ((<|>))) import Control.Exception (evaluate) import Data.Void-import GHCi-import HscTypes (hsc_IC, hsc_NC,- hsc_dflags, ic_dflags)-import Linker-import Module-import NameCache import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple+import Development.IDE.Core.Tracing (withTrace) import HieDb.Create import HieDb.Types import HieDb.Utils@@ -104,8 +103,8 @@ -- or 'Nothing' to respect the cradle setting , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'- , getInitialGhcLibDir :: FilePath -> IO (Maybe LibDir)- , fakeUid :: GHC.InstalledUnitId+ , getInitialGhcLibDir :: Logger -> FilePath -> IO (Maybe LibDir)+ , 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@@ -118,7 +117,7 @@ ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault- ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main")+ ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") } -- | Find the cradle for a given 'hie.yaml' configuration.@@ -142,11 +141,11 @@ Just yaml -> HieBios.loadCradle yaml Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)-getInitialGhcLibDirDefault rootDir = do+getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir)+getInitialGhcLibDirDefault logger rootDir = do hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir- hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle+ logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir@@ -158,9 +157,9 @@ pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)-setInitialDynFlags rootDir SessionLoadingOptions{..} = do- libdir <- getInitialGhcLibDir rootDir+setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)+setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do+ libdir <- getInitialGhcLibDir logger rootDir dynFlags <- mapM dynFlagsForPrinting libdir mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir@@ -169,11 +168,11 @@ -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy-runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()-runWithDb fp k = do+runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()+runWithDb logger fp k = do -- Delete the database if it has an incompatible schema version withHieDb fp (const $ pure ())- `catch` \IncompatibleSchemaVersion{} -> removeFile fp+ `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp withHieDb fp $ \writedb -> do initConn writedb chan <- newTQueueIO@@ -187,15 +186,15 @@ forever $ do k <- atomically $ readTQueue chan k db- `catch` \e@SQLError{} -> do- hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e- `catchAny` \e -> do- hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e+ `Safe.catch` \e@SQLError{} -> do+ logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e+ `Safe.catchAny` \e -> do+ logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do- let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb"+ let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir@@ -252,7 +251,6 @@ IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject- , optModifyDynFlags , optExtensions } <- getIdeOptions @@ -266,6 +264,7 @@ TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return (targetTarget, found)+ recordDirtyKeys extras GetKnownTargets [emptyFilePath] modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets when (known /= known') $@@ -297,7 +296,7 @@ -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information.- new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info+ new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component inplace = map rawComponentUnitId new_deps@@ -363,7 +362,7 @@ res <- loadDLL hscEnv "libm.so.6" case res of Nothing -> pure ()- Just err -> hPutStrLn stderr $+ Just err -> logDebug logger $ T.pack $ "Error dynamically loading libm.so.6:\n" <> err -- Make a map from unit-id to DynFlags, this is used when trying to@@ -392,7 +391,7 @@ -- Invalidate all the existing GhcSession build nodes by restarting the Shake session invalidateShakeCache- restartShakeSession []+ restartShakeSession "new component" [] -- Typecheck all files in the project on startup checkProject <- getCheckProject@@ -427,8 +426,13 @@ let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $- cradleToOptsAndLibDir cradle cfp+ withTrace "Load cradle" $ \addTag -> do+ addTag "file" lfp+ res <- cradleToOptsAndLibDir logger cradle cfp+ addTag "result" (show res)+ return res + logDebug logger $ T.pack ("Session loading result: " <> show eopts) case eopts of -- The cradle gave us some options so get to work turning them@@ -482,7 +486,7 @@ ncfp <- toNormalizedFilePath' <$> canonicalizePath file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file- sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e ->+ sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do@@ -497,11 +501,11 @@ -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath+cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath))-cradleToOptsAndLibDir cradle file = do+cradleToOptsAndLibDir logger cradle file = do -- Start off by getting the session options- hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle+ logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do@@ -522,11 +526,11 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession- when (ghcVersion < GHC90) $+ when (Compat.ghcVersion < Compat.GHC90) $ -- This causes ghc9 to crash with the error: -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env- pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } }+ pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails {@@ -571,13 +575,13 @@ -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv- -> [(InstalledUnitId, DynFlags)]+ -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) newComponentCache logger exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci- let hscEnv' = hsc_env { hsc_dflags = df- , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }+ let hscEnv' = hscSetFlags df hsc_env+ { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids@@ -676,7 +680,7 @@ -- This is pristine information about a component data RawComponentInfo = RawComponentInfo- { rawComponentUnitId :: InstalledUnitId+ { rawComponentUnitId :: UnitId -- | Unprocessed DynFlags. Contains inplace packages such as libraries. -- We do not want to use them unprocessed. , rawComponentDynFlags :: DynFlags@@ -693,14 +697,14 @@ -- This is processed information about the component, in particular the dynflags will be modified. data ComponentInfo = ComponentInfo- { componentUnitId :: InstalledUnitId+ { componentUnitId :: UnitId -- | Processed DynFlags. Does not contain inplace packages such as local -- libraries. Can be used to actually load this Component. , componentDynFlags :: DynFlags -- | Internal units, such as local libraries, that this component -- is loaded with. These have been extracted from the original -- ComponentOptions.- , _componentInternalUnits :: [InstalledUnitId]+ , _componentInternalUnits :: [UnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component@@ -733,7 +737,7 @@ where tryIO :: IO a -> IO (Either IOException a)- tryIO = try+ tryIO = Safe.try do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)@@ -747,18 +751,14 @@ -- tcRnImports) which assume that all modules in the HPT have the same unit -- ID. Therefore we create a fake one and give them all the same unit id. removeInplacePackages- :: InstalledUnitId -- ^ fake uid to use for our internal component- -> [InstalledUnitId]+ :: UnitId -- ^ fake uid to use for our internal component+ -> [UnitId] -> DynFlags- -> (DynFlags, [InstalledUnitId])-removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $+ -> (DynFlags, [UnitId])+removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ df { packageFlags = ps }, uids) where- (uids, ps) = partitionEithers (map go (packageFlags df))- go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us- then Left (GHC.toInstalledUnitId u)- else Right p- go p = Right p+ (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) -- | Memoize an IO function, with the characteristics: --@@ -790,25 +790,16 @@ -- also, it can confuse the interface stale check dontWriteHieFiles $ setIgnoreInterfacePragmas $- setLinkerOptions $+ setBytecodeLinkerOptions $ disableOptimisation $- setUpTypedHoles $+ Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied.- final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags''- return (final_df, targets)---- we don't want to generate object code so we compile to bytecode--- (HscInterpreted) which implies LinkInMemory--- HscInterpreted-setLinkerOptions :: DynFlags -> DynFlags-setLinkerOptions df = df {- ghcLink = LinkInMemory- , hscTarget = HscNothing- , ghcMode = CompManager- }+ env <- hscSetFlags dflags'' <$> getSession+ final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env+ return (hsc_dflags final_env', targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df =
src/Development/IDE/Core/Actions.hs view
@@ -23,17 +23,12 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat hiding (TargetFile,- TargetModule,- parseModule,- typecheckModule,- writeHieFile)+import Development.IDE.GHC.Compat hiding (writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb-import HscTypes (hsc_dflags) import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) @@ -44,7 +39,7 @@ :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database -> ModuleName- -> UnitId+ -> Unit -> Bool -- ^ Is this file a boot file? -> MaybeT IdeAction Uri lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing@@ -64,11 +59,11 @@ opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file- df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file+ env <- hscEnv . fst <$> useE GhcSession file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)- MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos'+ MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go
src/Development/IDE/Core/Compile.hs view
@@ -30,7 +30,7 @@ , setupFinderCache , getDocsBatch , lookupName- ) where+ ,mergeEnvs) where import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes@@ -43,19 +43,18 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options-import Outputable hiding ((<>)) +import Development.IDE.GHC.Compat hiding (loadInterface,+ parseHeader, parseModule,+ tcRnModule, writeHieFile)+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 HieDb import Language.LSP.Types (DiagnosticTag (..)) -import DriverPhases-import DriverPipeline hiding (unP)-import HscTypes-import LoadIface (loadModuleInterface)--import Lexer-import qualified Parser #if MIN_VERSION_ghc(8,10,0) import Control.DeepSeq (force, rnf) #else@@ -63,35 +62,13 @@ import ErrUtils #endif -import Development.IDE.GHC.Compat hiding (parseModule,- typecheckModule,- writeHieFile)-import qualified Development.IDE.GHC.Compat as Compat-import qualified Development.IDE.GHC.Compat as GHC-import Finder-import GhcMonad-import GhcPlugins as GHC hiding (fst3, (<>))-import Hooks-import HscMain (hscDesugar, hscGenHardCode,- hscInteractive, hscSimplify,- hscTypecheckRename,- makeSimpleDetails)-import MkIface-import StringBuffer as SB-import TcIface (typecheckIface)-import TcRnMonad hiding (newUnique)+ #if MIN_VERSION_ghc(9,0,1)-import GHC.Builtin.Names-import GHC.Iface.Recomp import GHC.Tc.Gen.Splice-import GHC.Tc.Types.Evidence (EvBind) #else-import PrelNames import TcSplice #endif-import TidyPgm -import Bag import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens hiding (List)@@ -108,14 +85,16 @@ import qualified Data.Text as T import Data.Time (UTCTime, getCurrentTime) import qualified GHC.LanguageExtensions as LangExt-import HeaderInfo-import Linker (unload)-import Maybes (orElse) import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin)-import TcEnv (tcLookup) +-- GHC API imports+-- GHC API imports+import GHC (GetDocsFailure (..),+ mgModSummaries,+ parsedSource)+ import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) import Data.Aeson (toJSON)@@ -123,11 +102,14 @@ import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map) import Data.Tuple.Extra (dupe)-import Data.Unique-import GHC.Fingerprint+import Data.Unique as Unique+import Development.IDE.Core.Tracing (withTrace)+import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP+import Unsafe.Coerce -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule@@ -146,11 +128,10 @@ -- | Given a package identifier, what packages does it depend on computePackageDeps :: HscEnv- -> InstalledUnitId- -> IO (Either [FileDiagnostic] [InstalledUnitId])+ -> Unit+ -> IO (Either [FileDiagnostic] [UnitId]) computePackageDeps env pkg = do- let dflags = hsc_dflags env- case oldLookupInstalledPackage dflags pkg of+ case lookupUnit env pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo@@ -169,7 +150,12 @@ modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->- tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}+ let+ session = tweak (hscSetFlags dflags hsc)+ -- TODO: maybe settings ms_hspp_opts is unnecessary?+ mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}+ in+ tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags@@ -180,10 +166,10 @@ -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover.-captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)-captureSplices dflags k = do+captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices)+captureSplices env k = do splice_ref <- newIORef mempty- res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)})+ res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) splices <- readIORef splice_ref return (res, splices) where@@ -217,14 +203,13 @@ tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod- hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+ hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env unload hsc_env_tmp keep_lbls ((tc_gbl_env, mrn_info), splices)- <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags ->- do let hsc_env_tmp = hsc_env { hsc_dflags = dflags }- hscTypecheckRename hsc_env_tmp ms $+ <- liftIO $ captureSplices (hscSetFlags (ms_hspp_opts ms) hsc_env) $ \hsc_env_tmp ->+ do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod }@@ -235,7 +220,7 @@ mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do- let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms }+ let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv@@ -255,7 +240,7 @@ -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do- let session = session' { hsc_dflags = ms_hspp_opts ms }+ let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm @@ -297,8 +282,8 @@ initPlugins :: HscEnv -> ModSummary -> IO ModSummary initPlugins session modSummary = do- dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary- return modSummary{ms_hspp_opts = dflags}+ session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)+ return modSummary{ms_hspp_opts = hsc_dflags session1} -- | Whether we should run the -O0 simplifier when generating core. --@@ -318,9 +303,9 @@ fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags session) "compile" $ do (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do- let ms' = tweak ms- session' = session{ hsc_dflags = ms_hspp_opts ms'}- desugar <- hscDesugar session' ms' tcg+ let session' = tweak (hscSetFlags (ms_hspp_opts ms) session)+ -- TODO: maybe settings ms_hspp_opts is unnecessary?+ desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg if simplify then do plugins <- readIORef (tcg_th_coreplugins tcg)@@ -337,23 +322,20 @@ fp = replaceExtension dot_o "s" createDirectoryIfMissing True (takeDirectory fp) (warnings, dot_o_fp) <-- withWarnings "object" $ \_tweak -> do- let summary' = _tweak summary-#if MIN_VERSION_ghc(8,10,0)- target = defaultObjectTarget $ hsc_dflags session-#else- target = defaultObjectTarget $ targetPlatform $ hsc_dflags session-#endif- session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}+ withWarnings "object" $ \tweak -> do+ let env' = tweak (hscSetFlags (ms_hspp_opts summary) session)+ target = platformDefaultBackend (hsc_dflags env')+ newFlags = setBackend target $ updOptLevel 0 $ (hsc_dflags env') { outputFile = Just dot_o }+ session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts #endif #if MIN_VERSION_ghc(8,10,0)- (ms_location summary')+ (ms_location summary) #else- summary'+ summary #endif fp compileFile session' StopLn (outputFilename, Just (As False))@@ -370,8 +352,9 @@ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \_tweak -> do- let summary' = _tweak summary- session = hscEnv { hsc_dflags = ms_hspp_opts summary' }+ let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)+ -- TODO: maybe settings ms_hspp_opts is unnecessary?+ summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session guts #if MIN_VERSION_ghc(8,10,0) (ms_location summary')@@ -475,16 +458,16 @@ -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- don't export an interface which allows for additional information to be added to hie files.- let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))+ let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm #if MIN_VERSION_ghc(9,0,1) ts = tmrTypechecked tcm :: TcGblEnv- top_ev_binds = tcg_ev_binds ts :: Bag EvBind+ top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon]- Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs+ Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else- Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm)+ Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv@@ -527,7 +510,7 @@ -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we -- can just increment the 'indexCompleted' TVar and exit. ---indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO ()+indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do@@ -565,7 +548,7 @@ case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do- u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique+ u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique -- TODO: Wait for the progress create response to use the token _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $@@ -634,7 +617,7 @@ hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source atomicFileWrite targetPath $ flip GHC.writeHieFile hf- hash <- getFileHash targetPath+ hash <- Util.getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where dflags = hsc_dflags hscEnv@@ -645,7 +628,7 @@ writeHiFile hscEnv tc = handleGenerationErrors dflags "interface write" $ do atomicFileWrite targetPath $ \fp ->- writeIfaceFile dflags fp modIface+ writeIfaceFile hscEnv fp modIface where modIface = hm_iface $ hirHomeMod tc targetPath = ml_hi_file $ ms_location $ hirModSummary tc@@ -674,7 +657,7 @@ -- Make modules available for others that import them, -- by putting them in the finder cache.- let ims = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss+ let ims = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims -- set the target and module graph in the session graph = mkModuleGraph mss@@ -708,6 +691,30 @@ where mod_name = moduleName . mi_module . hm_iface +-- Merge the HPTs, module graphs and FinderCaches+mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv+mergeEnvs env extraModSummaries extraMods envs = do+ prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs+ let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries+ ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims+ newFinderCache <- newIORef $+ foldl'+ (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache+ $ zip ims ifrs+ return $ loadModulesHome extraMods $ env{+ hsc_HPT = foldMapBy plusUDFM emptyUDFM hsc_HPT envs,+ hsc_FC = newFinderCache,+ hsc_mod_graph = mkModuleGraph $ extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)+ }+ where+ -- required because 'FinderCache':+ -- 1) doesn't have a 'Monoid' instance,+ -- 2) is abstract and doesn't export constructors+ -- To work around this, we coerce to the underlying type+ -- To remove this, I plan to upstream the missing Monoid instance+ concatFC :: [FinderCache] -> FinderCache+ concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))+ withBootSuffix :: HscSource -> ModLocation -> ModLocation withBootSuffix HsBootFile = addBootSuffixLocnOut withBootSuffix _ = id@@ -718,7 +725,7 @@ :: HscEnv -> FilePath -> UTCTime- -> Maybe SB.StringBuffer+ -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do (contents, opts, dflags) <- preprocessor env fp contents@@ -730,7 +737,7 @@ let mb_mod = hsmodName hsmod imps = hsmodImports hsmod - mod = fmap unLoc mb_mod `orElse` mAIN_NAME+ mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps @@ -754,9 +761,13 @@ liftIO $ evaluate $ rnf srcImports liftIO $ evaluate $ rnf textualImports - modLoc <- liftIO $ mkHomeModLocation dflags mod fp+ 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+ then mkHomeModLocation dflags (pathToModuleName fp) fp+ else mkHomeModLocation dflags mod fp - let modl = mkModule (thisPackage dflags) mod+ let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary = ModSummary@@ -785,14 +796,14 @@ -- eliding the timestamps, the preprocessed source and other non relevant fields computeFingerprint opts ModSummary{..} = do fingerPrintImports <- fingerprintFromPut $ do- put $ uniq $ moduleNameFS $ moduleName ms_mod+ put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do- put $ uniq $ moduleNameFS $ unLoc m- whenJust mb_p $ put . uniq- return $! fingerprintFingerprints $- [ fingerprintString fp+ put $ Util.uniq $ moduleNameFS $ unLoc m+ whenJust mb_p $ put . Util.uniq+ return $! Util.fingerprintFingerprints $+ [ Util.fingerprintString fp , fingerPrintImports- ] ++ map fingerprintString opts+ ] ++ map Util.fingerprintString opts -- | Parse only the module header@@ -800,15 +811,15 @@ :: Monad m => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations)- -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)+ -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) #if MIN_VERSION_ghc(9,0,1) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) #endif parseHeader dflags filename contents = do- let loc = mkRealSrcLoc (mkFastString filename) 1 1- case unP Parser.parseHeader (mkPState dflags contents loc) of+ let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1+ case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags@@ -828,9 +839,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $- throwE $ diagFromErrMsgs "parser" dflags errs+ throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) - let warnings = diagFromErrMsgs "parser" dflags warns+ let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a@@ -843,10 +854,10 @@ -> ModSummary -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) parseFileContents env customPreprocessor filename ms = do- let loc = mkRealSrcLoc (mkFastString filename) 1 1+ let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms- case unP Parser.parseModule (mkPState dflags contents loc) of+ case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else@@ -854,21 +865,8 @@ throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module ->- let hpm_annotations :: ApiAnns- hpm_annotations =-#if MIN_VERSION_ghc(9,0,1)- -- Copied from GHC.Driver.Main- ApiAnns {- apiAnnItems = Map.fromListWith (++) $ annotations pst,- apiAnnEofPos = eof_pos pst,- apiAnnComments = Map.fromList (annotations_comments pst),- apiAnnRogueComments = comment_q pst- }-#else- (Map.fromListWith (++) $ annotations pst,- Map.fromList ((noSrcSpan,comment_q pst)- :annotations_comments pst))-#endif+ let+ hpm_annotations = mkApiAnns pst (warns, errs) = getMessages pst dflags in do@@ -908,7 +906,7 @@ $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<")- $ map unpackFS+ $ map Util.unpackFS $ srcfiles pst srcs1 = case ml_hs_file (ms_location ms) of Just f -> filter (/= normalise f) srcs0@@ -919,13 +917,7 @@ -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm =- ParsedModule {- pm_mod_summary = ms- , pm_parsed_source = parsed'- , pm_extra_src_files = srcs2- , pm_annotations = hpm_annotations- }+ let pm = mkParsedModule ms parsed' srcs2 hpm_annotations warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) @@ -937,14 +929,15 @@ -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies loadInterface- :: MonadIO m => HscEnv+ :: (MonadIO m, MonadMask m)+ => HscEnv -> ModSummary -> SourceModified -> Maybe LinkableType -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms sourceMod linkableNeeded regen = do- let sessionWithMsDynFlags = session{hsc_dflags = ms_hspp_opts ms}+ let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing case res of (UpToDate, Just iface)@@ -977,8 +970,16 @@ hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable return ([], Just $ mkHiFileResult ms hmi) else regen linkableNeeded- (_reason, _) -> regen linkableNeeded+ (_reason, _) -> withTrace "regenerate interface" $ \setTag -> do+ setTag "Module" $ moduleNameString $ moduleName $ ms_mod ms+ setTag "Reason" $ showReason _reason+ regen linkableNeeded +showReason :: RecompileRequired -> String+showReason UpToDate = "UpToDate"+showReason MustCompile = "MustCompile"+showReason (RecompBecause s) = s+ mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo mkDetailsFromIface session iface linkable = do details <- liftIO $ fixIO $ \details -> do@@ -1019,7 +1020,7 @@ UnhelpfulLoc {} -> True fakeSpan :: RealSrcSpan-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<ghcide>") 1 1+fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds@@ -1036,3 +1037,11 @@ ATcId{tct_id=id} -> return (AnId id) _ -> panic "tcRnLookupName'" return res+++pathToModuleName :: FilePath -> ModuleName+pathToModuleName = mkModuleName . map rep+ where+ rep c | isPathSeparator c = '_'+ rep ':' = '_'+ rep c = c
src/Development/IDE/Core/FileExists.hs view
@@ -88,14 +88,10 @@ liftIO $ readVar v -- | Modify the global store of file exists.-modifyFileExists :: IdeState -> [FileEvent] -> IO ()+modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state- changesMap <- evaluate $ HashMap.fromList $- [ (toNormalizedFilePath' f, change)- | FileEvent uri change <- changes- , Just f <- [uriToFilePath uri]- ]+ changesMap <- evaluate $ HashMap.fromList changes -- Masked to ensure that the previous values are flushed together with the map update mask $ \_ -> do -- update the map
src/Development/IDE/Core/FileStore.hs view
@@ -32,14 +32,12 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.Either.Extra-import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX-import Development.IDE.Core.OfInterest (OfInterestVar (..)) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Orphans ()@@ -48,7 +46,6 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options-import Development.IDE.Types.Shake (SomeShakeValue) import HieDb.Create (deleteMissingRealFiles) import Ide.Plugin.Config (CheckParents (..), Config)@@ -75,12 +72,9 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileChangeType (FcChanged),- FileEvent (FileEvent), FileSystemWatcher (..), WatchKind (..),- _watchers,- toNormalizedFilePath,- uriToFilePath)+ _watchers) import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS@@ -171,18 +165,16 @@ deleteValue state GetModificationTime f -- | Reset the GetModificationTime state of watched files-resetFileStore :: IdeState -> [FileEvent] -> IO ()+-- Assumes the list does not include any FOIs+resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions- OfInterestVar foisVar <- getIdeGlobalExtras (shakeExtras ideState)- fois <- readVar foisVar- forM_ changes $ \(FileEvent uri c) -> do+ -- FOI filtering is done by the caller (LSP Notification handler)+ forM_ changes $ \(nfp, c) -> do case c of FcChanged- | Just f <- uriToFilePath uri- , nfp <- toNormalizedFilePath f- , not $ HM.member nfp fois+ -- already checked elsewhere | not $ HM.member nfp fois -> deleteValue (shakeExtras ideState) GetModificationTime nfp _ -> pure () @@ -264,14 +256,14 @@ ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of- AlwaysCheck -> True- CheckOnSaveAndClose -> saved- _ -> False+ AlwaysCheck -> True+ CheckOnSave -> saved+ _ -> False VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setFileModified can't be called on this type of VFSHandle" recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]- restartShakeSession (shakeExtras state) []+ restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ typecheckParents state nfp @@ -294,8 +286,8 @@ -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified.-setSomethingModified :: IdeState -> [SomeShakeValue] -> IO ()-setSomethingModified state keys = do+setSomethingModified :: IdeState -> [Key] -> String -> IO ()+setSomethingModified state keys reason = do VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setSomethingModified can't be called on this type of VFSHandle"@@ -303,7 +295,7 @@ atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x -> foldl' (flip HSet.insert) x keys- void $ restartShakeSession (shakeExtras state) []+ void $ restartShakeSession (shakeExtras state) reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do
src/Development/IDE/Core/OfInterest.hs view
@@ -8,13 +8,14 @@ -- open in the editor. The rule is 'IsFileOfInterest' module Development.IDE.Core.OfInterest( ofInterestRules,+ getFilesOfInterest, getFilesOfInterestUntracked, addFileOfInterest, deleteFileOfInterest, setFilesOfInterest, kick, FileOfInterestStatus(..), OfInterestVar(..)- ) where+ ,scheduleGarbageCollection) where import Control.Concurrent.Strict import Control.Monad@@ -40,6 +41,7 @@ ofInterestRules :: Rules () ofInterestRules = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty)+ addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked@@ -53,10 +55,18 @@ summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 +------------------------------------------------------------+newtype GarbageCollectVar = GarbageCollectVar (Var Bool)+instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API +getFilesOfInterest :: IdeState -> IO( HashMap NormalizedFilePath FileOfInterestStatus)+getFilesOfInterest state = do+ OfInterestVar var <- getIdeGlobalState state+ readVar var+ -- | Set the files-of-interest - not usually necessary or advisable. -- The LSP client will keep this information up to date. setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO ()@@ -74,7 +84,7 @@ OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict- pure (new, (prev, dict))+ pure (new, (prev, new)) when (prev /= Just v) $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $@@ -87,6 +97,10 @@ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) +scheduleGarbageCollection :: IdeState -> IO ()+scheduleGarbageCollection state = do+ GarbageCollectVar var <- getIdeGlobalState state+ writeVar var True -- | Typecheck all the files of interest. -- Could be improved@@ -99,7 +113,12 @@ -- Update the exports map results <- uses GenerateCore files <* uses GetHieAst files let mguts = catMaybes results- !exportsMap' = createExportsMapMg mguts- void $ liftIO $ modifyVar' exportsMap (exportsMap' <>)+ void $ liftIO $ modifyVar' exportsMap (updateExportsMapMg mguts) liftIO $ progressUpdate progress KickCompleted++ GarbageCollectVar var <- getIdeGlobalAction+ garbageCollectionScheduled <- liftIO $ readVar var+ when garbageCollectionScheduled $ do+ void garbageCollectDirtyKeys+ liftIO $ writeVar var False
src/Development/IDE/Core/Preprocessor.hs view
@@ -7,13 +7,13 @@ import Development.IDE.GHC.CPP import Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans ()-import GhcMonad-import StringBuffer as SB import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) import Control.Exception.Safe (catch, throw)+import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Char import Data.IORef (IORef, modifyIORef,@@ -26,56 +26,52 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt-import qualified HeaderInfo as Hdr-import HscTypes (HscEnv (hsc_dflags))-import Outputable (showSDoc)-import SysTools (Option (..), runPp,- runUnlit) import System.FilePath import System.IO.Extra - -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.-preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags)-preprocessor env filename mbContents = do+preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags)+preprocessor env0 filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do- let dflags = hsc_dflags env- newcontent <- liftIO $ runLhs dflags filename mbContents+ newcontent <- liftIO $ runLhs env0 filename mbContents return (False, newcontent) else do- contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents+ contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents let isOnDisk = isNothing mbContents return (isOnDisk, contents) -- Perform cpp- (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents+ (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents+ let env1 = hscSetFlags dflags env0+ let logger = hsc_logger env1 (isOnDisk, contents, opts, dflags) <- if not $ xopt LangExt.Cpp dflags then return (isOnDisk, contents, opts, dflags) else do cppLogs <- liftIO $ newIORef []+ let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger contents <- ExceptT- $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename+ $ (Right <$> (runCpp (putLogHook newLogger env1) filename $ if isOnDisk then Nothing else Just contents)) `catch`- ( \(e :: GhcException) -> do+ ( \(e :: Util.GhcException) -> do logs <- readIORef cppLogs case diagsFromCPPLogs filename (reverse logs) of [] -> throw e diags -> return $ Left diags )- (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents+ (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (False, contents, opts, dflags) -- Perform preprocessor if not $ gopt Opt_Pp dflags then return (contents, opts, dflags) else do- contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents- (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents+ contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents+ (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogActionCompat@@ -107,7 +103,7 @@ -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc- go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) =+ go acc (CPPLog sev (RealSrcSpan span _) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =@@ -134,22 +130,22 @@ parsePragmasIntoDynFlags :: HscEnv -> FilePath- -> SB.StringBuffer+ -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do- let opts = Hdr.getOptions dflags0 contents fp+ let opts = getOptions dflags0 contents fp -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts- dflags' <- initializePlugins env dflags- return (map unLoc opts, disableWarningsAsErrors dflags')+ hsc_env' <- initializePlugins (hscSetFlags dflags env)+ return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env')) where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set-runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer-runLhs dflags filename contents = withTempDir $ \dir -> do+runLhs :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer+runLhs env filename contents = withTempDir $ \dir -> do let fout = dir </> takeFileName filename <.> "unlit" filesrc <- case contents of Nothing -> return filename@@ -159,14 +155,17 @@ hPutStringBuffer h cnts return fsrc unlit filesrc fout- SB.hGetStringBuffer fout+ Util.hGetStringBuffer fout where- unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)+ logger = hsc_logger env+ dflags = hsc_dflags env++ unlit filein fileout = runUnlit logger dflags (args filein fileout) args filein fileout = [- SysTools.Option "-h"- , SysTools.Option (escape filename) -- name this file- , SysTools.FileOption "" filein -- input file- , SysTools.FileOption "" fileout ] -- output file+ Option "-h"+ , Option (escape filename) -- name this file+ , FileOption "" filein -- input file+ , FileOption "" fileout ] -- output file -- taken from ghc's DriverPipeline.hs escape ('\\':cs) = '\\':'\\': escape cs escape ('\"':cs) = '\\':'\"': escape cs@@ -175,31 +174,32 @@ escape [] = [] -- | Run CPP on a file-runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer-runCpp dflags filename contents = withTempDir $ \dir -> do+runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer+runCpp env0 filename contents = withTempDir $ \dir -> do let out = dir </> takeFileName filename <.> "out"- dflags <- pure $ addOptP "-D__GHCIDE__" dflags+ let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0)+ let env1 = hscSetFlags dflags1 env0 case contents of Nothing -> do -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work -- and means location information is correct- doCpp dflags True filename out- liftIO $ SB.hGetStringBuffer out+ doCpp env1 True filename out+ liftIO $ Util.hGetStringBuffer out Just contents -> do -- Sad path, we have to create a version of the path in a temp dir -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue) -- Relative includes aren't going to work, so we fix that by adding to the include path.- dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags-+ let dflags2 = addIncludePathsQuote (takeDirectory filename) dflags1+ let env2 = hscSetFlags dflags2 env0 -- Location information is wrong, so we fix that by patching it afterwards. let inp = dir </> "___GHCIDE_MAGIC___" withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents- doCpp dflags True inp out+ doCpp env2 True inp out -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"@@ -211,12 +211,12 @@ -- and GHC gets all confused = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" | otherwise = x- stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out+ Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file-runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer-runPreprocessor dflags filename contents = withTempDir $ \dir -> do+runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer+runPreprocessor env filename contents = withTempDir $ \dir -> do let out = dir </> takeFileName filename <.> "out" inp <- case contents of Nothing -> return filename@@ -225,5 +225,8 @@ withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents return inp- runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]- SB.hGetStringBuffer out+ runPp logger dflags [Option filename, Option inp, FileOption "" out]+ Util.hGetStringBuffer out+ where+ logger = hsc_logger env+ dflags = hsc_dflags env
src/Development/IDE/Core/RuleTypes.hs view
@@ -18,13 +18,13 @@ import Control.DeepSeq import Control.Lens import Data.Aeson.Types (Value)-import Data.Binary import Data.Hashable import qualified Data.Map as M import Data.Time.Clock.POSIX import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult)+import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Util import Development.IDE.Graph import Development.IDE.Import.DependencyInformation@@ -32,11 +32,6 @@ import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) -import HscTypes (HomeModInfo,- ModGuts,- hm_iface,- hm_linkable)- import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS@@ -46,16 +41,22 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics-import Fingerprint import GHC.Serialized (Serialized) import Language.LSP.Types (NormalizedFilePath)-import TcRnMonad (TcGblEnv) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) instance Hashable LinkableType instance NFData LinkableType +-- | Encode the linkable into an ordered bytestring.+-- This is used to drive an ordered "newness" predicate in the+-- 'NeedsCompilation' build rule.+encodeLinkableType :: Maybe LinkableType -> ByteString+encodeLinkableType Nothing = "0"+encodeLinkableType (Just BCOLinkable) = "1"+encodeLinkableType (Just ObjectLinkable) = "2"+ -- NOTATION -- Foo+ means Foo for the dependencies -- Foo* means Foo for me and Foo+@@ -72,17 +73,12 @@ -- a module could not be parsed or an import cycle. type instance RuleResult GetDependencyInformation = DependencyInformation --- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation.--- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure.-type instance RuleResult GetDependencies = TransitiveDependencies- type instance RuleResult GetModuleGraph = DependencyInformation data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets instance NFData GetKnownTargets-instance Binary GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets -- | Convert to Core, requires TypeCheck*@@ -92,13 +88,11 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable GenerateCore instance NFData GenerateCore-instance Binary GenerateCore data GetImportMap = GetImportMap deriving (Eq, Show, Typeable, Generic) instance Hashable GetImportMap instance NFData GetImportMap-instance Binary GetImportMap type instance RuleResult GetImportMap = ImportMap newtype ImportMap = ImportMap@@ -236,6 +230,7 @@ type instance RuleResult GhcSession = HscEnvEq -- | A GHC session preloaded with all the dependencies+-- This rule is also responsible for calling ReportImportCycles for the direct dependencies type instance RuleResult GhcSessionDeps = HscEnvEq -- | Resolve the imports in a module to the file path of a module in the same package@@ -274,8 +269,11 @@ { missingFileDiagnostics :: Bool -- ^ If false, missing file diagnostics are not reported }- deriving (Show, Generic)+ deriving (Generic) +instance Show GetModificationTime where+ show _ = "GetModificationTime"+ instance Eq GetModificationTime where -- Since the diagnostics are not part of the answer, the query identity is -- independent from the 'missingFileDiagnostics' field@@ -287,7 +285,6 @@ hashWithSalt salt _ = salt instance NFData GetModificationTime-instance Binary GetModificationTime pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}@@ -310,14 +307,12 @@ deriving (Eq, Show, Generic) instance Hashable GetFileContents instance NFData GetFileContents-instance Binary GetFileContents data GetFileExists = GetFileExists deriving (Eq, Show, Typeable, Generic) instance NFData GetFileExists instance Hashable GetFileExists-instance Binary GetFileExists data FileOfInterestStatus = OnDisk@@ -326,13 +321,11 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus instance NFData FileOfInterestStatus-instance Binary FileOfInterestStatus data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult-instance Binary IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult @@ -359,19 +352,16 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule instance NFData GetParsedModule-instance Binary GetParsedModule data GetParsedModuleWithComments = GetParsedModuleWithComments deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModuleWithComments instance NFData GetParsedModuleWithComments-instance Binary GetParsedModuleWithComments data GetLocatedImports = GetLocatedImports deriving (Eq, Show, Typeable, Generic) instance Hashable GetLocatedImports instance NFData GetLocatedImports-instance Binary GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Maybe LinkableType@@ -380,122 +370,97 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable NeedsCompilation instance NFData NeedsCompilation-instance Binary NeedsCompilation data GetDependencyInformation = GetDependencyInformation deriving (Eq, Show, Typeable, Generic) instance Hashable GetDependencyInformation instance NFData GetDependencyInformation-instance Binary GetDependencyInformation data GetModuleGraph = GetModuleGraph deriving (Eq, Show, Typeable, Generic) instance Hashable GetModuleGraph instance NFData GetModuleGraph-instance Binary GetModuleGraph data ReportImportCycles = ReportImportCycles deriving (Eq, Show, Typeable, Generic) instance Hashable ReportImportCycles instance NFData ReportImportCycles-instance Binary ReportImportCycles -data GetDependencies = GetDependencies- deriving (Eq, Show, Typeable, Generic)-instance Hashable GetDependencies-instance NFData GetDependencies-instance Binary GetDependencies- data TypeCheck = TypeCheck deriving (Eq, Show, Typeable, Generic) instance Hashable TypeCheck instance NFData TypeCheck-instance Binary TypeCheck data GetDocMap = GetDocMap deriving (Eq, Show, Typeable, Generic) instance Hashable GetDocMap instance NFData GetDocMap-instance Binary GetDocMap data GetHieAst = GetHieAst deriving (Eq, Show, Typeable, Generic) instance Hashable GetHieAst instance NFData GetHieAst-instance Binary GetHieAst data GetBindings = GetBindings deriving (Eq, Show, Typeable, Generic) instance Hashable GetBindings instance NFData GetBindings-instance Binary GetBindings data GhcSession = GhcSession deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSession instance NFData GhcSession-instance Binary GhcSession data GhcSessionDeps = GhcSessionDeps deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionDeps instance NFData GhcSessionDeps-instance Binary GhcSessionDeps data GetModIfaceFromDisk = GetModIfaceFromDisk deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIfaceFromDisk instance NFData GetModIfaceFromDisk-instance Binary GetModIfaceFromDisk data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIfaceFromDiskAndIndex instance NFData GetModIfaceFromDiskAndIndex-instance Binary GetModIfaceFromDiskAndIndex data GetModIface = GetModIface deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIface instance NFData GetModIface-instance Binary GetModIface data GetModIfaceWithoutLinkable = GetModIfaceWithoutLinkable deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIfaceWithoutLinkable instance NFData GetModIfaceWithoutLinkable-instance Binary GetModIfaceWithoutLinkable data IsFileOfInterest = IsFileOfInterest deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterest instance NFData IsFileOfInterest-instance Binary IsFileOfInterest data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps deriving (Eq, Show, Typeable, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps-instance Binary GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary deriving (Eq, Show, Typeable, Generic) instance Hashable GetModSummary instance NFData GetModSummary-instance Binary GetModSummary -- | Get the vscode client settings stored in the ide state data GetClientSettings = GetClientSettings deriving (Eq, Show, Typeable, Generic) instance Hashable GetClientSettings instance NFData GetClientSettings-instance Binary GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) instance Hashable AddWatchedFile instance NFData AddWatchedFile-instance Binary AddWatchedFile -- A local rule type to get caching. We want to use newCache, but it has@@ -516,7 +481,6 @@ data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO-instance Binary GhcSessionIO makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
src/Development/IDE/Core/Rules.hs view
@@ -11,7 +11,7 @@ -- module Development.IDE.Core.Rules( -- * Types- IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),+ IdeState, GetParsedModule(..), TransitiveDependencies(..), Priority(..), GhcSessionIO(..), GetClientSettings(..), -- * Functions priorityTypeCheck,@@ -22,6 +22,7 @@ defineNoFile, defineEarlyCutOffNoFile, mainRule,+ RulesConfig(..), getDependencies, getParsedModule, getParsedModuleWithComments,@@ -35,7 +36,6 @@ getLocatedImportsRule, getDependencyInformationRule, reportImportCyclesRule,- getDependenciesRule, typeCheckRule, getDocMapRule, loadGhcSession,@@ -50,14 +50,19 @@ getHieAstsRule, getBindingsRule, needsCompilationRule,+ computeLinkableTypeForDynFlags, generateCoreRule, getImportMapRule, regenerateHiFile, ghcSessionDepsDefinition, getParsedModuleDefinition, typeCheckRuleDefinition,+ GhcSessionDepsConfig(..), ) where +#if !MIN_VERSION_ghc(8,8,0)+import Control.Applicative (liftA2)+#endif import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.Exception.Safe@@ -70,7 +75,6 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson.Types as A-import Data.Binary hiding (get, put) import qualified Data.Binary as B import qualified Data.ByteString as BS import Data.ByteString.Encoding as T@@ -103,18 +107,20 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat hiding- (TargetFile,- TargetModule,- parseModule,- typecheckModule,- writeHieFile)+import Development.IDE.GHC.Compat.Env+import Development.IDE.GHC.Compat.Core hiding+ (parseModule,+ TargetId(..),+ loadInterface,+ Var)+import qualified Development.IDE.GHC.Compat as Compat+import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph-import Development.IDE.Graph.Classes hiding (get, put)+import Development.IDE.Graph.Classes import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint as AtPoint@@ -125,24 +131,16 @@ import Development.IDE.Types.Location import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options-import Fingerprint import GHC.Generics (Generic) import GHC.IO.Encoding import qualified GHC.LanguageExtensions as LangExt import qualified HieDb-import HscTypes hiding- (TargetFile,- TargetModule) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import Language.LSP.Types (SMethod (SCustomMethod)) import Language.LSP.VFS-import Module import System.Directory (canonicalizePath, makeAbsolute)-import TcRnMonad (tcg_dependent_files)--import Control.Applicative-import Data.Default (def)+import Data.Default (def, Default) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties,@@ -151,7 +149,6 @@ import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId)-import qualified Data.HashSet as HS -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing@@ -165,7 +162,8 @@ -- | Get all transitive file dependencies of a given module. -- Does not include the file itself. getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])-getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file+getDependencies file =+ fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do@@ -215,38 +213,41 @@ opt <- getIdeOptions modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }-- let dflags = ms_hspp_opts ms- mainParse = getParsedModuleDefinition hsc opt file ms reset_ms pm = pm { pm_mod_summary = ms' } - -- Parse again (if necessary) to capture Haddock parse errors- res@(_,pmod) <- if gopt Opt_Haddock dflags- then- liftIO $ (fmap.fmap.fmap) reset_ms mainParse- else do- let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)+ -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information+ -- but we no longer need to parse with and without Haddocks separately for above GHC90.+ res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then+ liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms)+ else do+ let dflags = ms_hspp_opts ms+ mainParse = getParsedModuleDefinition hsc opt file ms - -- parse twice, with and without Haddocks, concurrently- -- we cannot ignore Haddock parse errors because files of- -- non-interest are always parsed with Haddocks- -- If we can parse Haddocks, might as well use them- --- -- HLINT INTEGRATION: might need to save the other parsed module too- ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse+ -- Parse again (if necessary) to capture Haddock parse errors+ if gopt Opt_Haddock dflags+ then+ liftIO $ (fmap.fmap.fmap) reset_ms mainParse+ else do+ let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) - -- Merge haddock and regular diagnostics so we can always report haddock- -- parse errors- let diagsM = mergeParseErrorsHaddock diags diagsh- case resh of- Just _- | HaddockParse <- optHaddockParse opt- -> pure (diagsM, resh)- -- If we fail to parse haddocks, report the haddock diagnostics as well and- -- return the non-haddock parse.- -- This seems to be the correct behaviour because the Haddock flag is added- -- by us and not the user, so our IDE shouldn't stop working because of it.- _ -> pure (diagsM, res)+ -- parse twice, with and without Haddocks, concurrently+ -- we cannot ignore Haddock parse errors because files of+ -- non-interest are always parsed with Haddocks+ -- If we can parse Haddocks, might as well use them+ ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse++ -- Merge haddock and regular diagnostics so we can always report haddock+ -- parse errors+ let diagsM = mergeParseErrorsHaddock diags diagsh+ case resh of+ Just _+ | HaddockParse <- optHaddockParse opt+ -> pure (diagsM, resh)+ -- If we fail to parse haddocks, report the haddock diagnostics as well and+ -- return the non-haddock parse.+ -- This seems to be the correct behaviour because the Haddock flag is added+ -- by us and not the user, so our IDE shouldn't stop working because of it.+ _ -> pure (diagsM, res) -- Add dependencies on included files _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) pure res@@ -336,14 +337,14 @@ return $ if itExists then Just nfp' else Nothing | Just tt <- HM.lookup (TargetModule modName) targets = do -- reuse the existing NormalizedFilePath in order to maximize sharing- let ttmap = HM.mapWithKey const (HS.toMap tt)+ let ttmap = HM.mapWithKey const (HashSet.toMap tt) nfp' = HM.lookupDefault nfp nfp ttmap itExists <- getFileExists nfp' return $ if itExists then Just nfp' else Nothing | otherwise = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do- diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource+ diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path))@@ -494,18 +495,6 @@ pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) --- returns all transitive dependencies in topological order.--- NOTE: result does not include the argument file.-getDependenciesRule :: Rules ()-getDependenciesRule =- defineEarlyCutoff $ RuleNoDiagnostics $ \GetDependencies file -> do- depInfo <- use_ GetDependencyInformation file- let allFiles = reachableModules depInfo- _ <- uses_ ReportImportCycles allFiles- opts <- getIdeOptions- let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts- return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file)- getHieAstsRule :: Rules () getHieAstsRule = define $ \GetHieAst f -> do@@ -523,9 +512,9 @@ case mvf of Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf)- let refmap = generateReferencesMap . getAsts . hie_asts $ res- del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource- pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver)+ let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res+ del = deltaFromDiff (T.decode encoding $ Compat.hie_hs_src res) currentSource+ pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do@@ -546,8 +535,8 @@ liftIO $ writeAndIndexHieFile hsc se msum f exports asts source _ -> pure [] - let refmap = generateReferencesMap . getAsts <$> masts- typemap = AtPoint.computeTypeReferences . getAsts <$> masts+ let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts+ typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Rules ()@@ -584,7 +573,7 @@ persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile+readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk file = do db <- asks hiedb log <- asks $ L.logDebug . logger@@ -593,7 +582,7 @@ liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) exceptToMaybeT $ readHieFileFromDisk hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile+readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk hie_loc = do nc <- asks ideNc log <- asks $ L.logDebug . logger@@ -656,8 +645,8 @@ where go (mod, time) = LM time mod [] -loadGhcSession :: Rules ()-loadGhcSession = do+loadGhcSession :: GhcSessionDepsConfig -> Rules ()+loadGhcSession ghcSessionDepsConfig = do -- This function should always be rerun because it tracks changes -- to the version of the collection of HscEnv's. defineEarlyCutOffNoFile $ \GhcSessionIO -> do@@ -693,49 +682,65 @@ Nothing -> LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file--ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)-ghcSessionDepsDefinition file = do+ defineNoDiagnostics $ \GhcSessionDeps file -> do env <- use_ GhcSession file- let hsc = hscEnv env- ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file- deps <- use_ GetDependencies file- let tdeps = transitiveModuleDeps deps- uses_th_qq =- xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags- dflags = ms_hspp_opts ms- ifaces <- if uses_th_qq- then uses_ GetModIface tdeps- else uses_ GetModIfaceWithoutLinkable tdeps+ ghcSessionDepsDefinition ghcSessionDepsConfig env file - -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.- -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.- -- Long-term we might just want to change the order returned by GetDependencies- let inLoadOrder = reverse (map hirHomeMod ifaces)+data GhcSessionDepsConfig = GhcSessionDepsConfig+ { checkForImportCycles :: Bool+ , forceLinkables :: Bool+ , fullModSummary :: Bool+ }+instance Default GhcSessionDepsConfig where+ def = GhcSessionDepsConfig+ { checkForImportCycles = True+ , forceLinkables = False+ , fullModSummary = False+ } - session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc+ghcSessionDepsDefinition :: GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq)+ghcSessionDepsDefinition GhcSessionDepsConfig{..} env file = do+ let hsc = hscEnv env - res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' []- return ([], Just res)+ mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file+ case mbdeps of+ Nothing -> return Nothing+ Just deps -> do+ when checkForImportCycles $ void $ uses_ ReportImportCycles deps+ ms:mss <- map msrModSummary <$> if fullModSummary+ then uses_ GetModSummary (file:deps)+ else uses_ GetModSummaryWithoutTimestamps (file:deps) + depSessions <- map hscEnv <$> uses_ GhcSessionDeps deps+ let uses_th_qq =+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags+ dflags = ms_hspp_opts ms+ ifaces <- if uses_th_qq || forceLinkables+ then uses_ GetModIface deps+ else uses_ GetModIfaceWithoutLinkable deps++ let inLoadOrder = map hirHomeMod ifaces+ session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions++ Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])+ -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. getModIfaceFromDiskRule :: Rules () getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do ms <- msrModSummary <$> use_ GetModSummary f- (diags_session, mb_session) <- ghcSessionDepsDefinition f+ mb_session <- use GhcSessionDeps f case mb_session of- Nothing -> return (Nothing, (diags_session, Nothing))+ Nothing -> return (Nothing, ([], Nothing)) Just session -> do sourceModified <- use_ IsHiFileStable f linkableType <- getLinkableType f r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) case r of- (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))+ (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do let !fp = Just $! hiFileFingerPrint x- return (fp, (diags <> diags_session, Just x))+ return (fp, (diags, Just x)) -- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? -- This function is responsible for ensuring database consistency@@ -754,8 +759,8 @@ -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x- hie_loc = ml_hie_file $ ms_location ms- hash <- liftIO $ getFileHash hie_loc+ hie_loc = Compat.ml_hie_file $ ms_location ms+ hash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow case mrow of@@ -785,7 +790,7 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath'- $ ml_hi_file $ ms_location ms+ $ Compat.ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile modVersion <- use_ GetModificationTime f sourceModified <- case mbHiVersion of@@ -811,7 +816,7 @@ defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal- let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' }+ let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $@@ -820,7 +825,7 @@ Right res -> do bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res- let fingerPrint = fingerprintFingerprints+ let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing))@@ -894,9 +899,11 @@ -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)- (diags, mb_pm) <- case mb_pm of- Just _ -> return (diags, mb_pm)- Nothing -> do+ (diags, mb_pm) <-+ -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892+ if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do+ return (diags, mb_pm)+ else do -- if parsing fails, try parsing again with Haddock turned off (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)@@ -990,8 +997,9 @@ getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -needsCompilationRule :: Rules ()-needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do+-- needsCompilationRule :: Rules ()+needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType))+needsCompilationRule file = do graph <- useNoFile GetModuleGraph res <- case graph of -- Treat as False if some reverse dependency header fails to parse@@ -1015,14 +1023,11 @@ (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) - pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res)+ pure (Just $ encodeLinkableType res, Just res) where uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - unboxed_tuples_or_sums (ms_hspp_opts -> d) =- xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d- computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType computeLinkableType this deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we@@ -1030,15 +1035,22 @@ | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile where- -- How should we compile this module? (assuming we do in fact need to compile it)- -- Depends on whether it uses unboxed tuples or sums- this_type+ this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this)++-- | How should we compile this module?+-- (assuming we do in fact need to compile it).+-- Depends on whether it uses unboxed tuples or sums+computeLinkableTypeForDynFlags :: DynFlags -> LinkableType+computeLinkableTypeForDynFlags d #if defined(GHC_PATCHED_UNBOXED_BYTECODE) = BCOLinkable #else- | unboxed_tuples_or_sums this = ObjectLinkable- | otherwise = BCOLinkable+ | unboxed_tuples_or_sums = ObjectLinkable+ | otherwise = BCOLinkable #endif+ where+ unboxed_tuples_or_sums =+ xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }@@ -1047,14 +1059,23 @@ writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do extras <- getShakeExtras- let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile+ let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile +data RulesConfig = RulesConfig+ { -- | Disable import cycle checking for improved performance in large codebases+ checkForImportCycles :: Bool+ -- | Disable TH for improved performance in large codebases+ , enableTemplateHaskell :: Bool+ }++instance Default RulesConfig where def = RulesConfig True True+ -- | A rule that wires per-file rules together-mainRule :: Rules ()-mainRule = do+mainRule :: RulesConfig -> Rules ()+mainRule RulesConfig{..} = do linkables <- liftIO $ newVar emptyModuleEnv addIdeGlobal $ CompiledLinkables linkables getParsedModuleRule@@ -1062,10 +1083,9 @@ getLocatedImportsRule getDependencyInformationRule reportImportCyclesRule- getDependenciesRule typeCheckRule getDocMapRule- loadGhcSession+ loadGhcSession def{checkForImportCycles} getModIfaceFromDiskRule getModIfaceFromDiskAndIndexRule getModIfaceRule@@ -1077,7 +1097,16 @@ getClientSettingsRule getHieAstsRule getBindingsRule- needsCompilationRule+ -- This rule uses a custom newness check that relies on the encoding+ -- produced by 'encodeLinkable'. This works as follows:+ -- * <previous> -> <new>+ -- * ObjectLinkable -> BCOLinkable : the prev linkable can be reused, signal "no change"+ -- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change"+ -- * otherwise : the prev linkable cannot be reused, signal "value has changed"+ if enableTemplateHaskell+ then defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->+ needsCompilationRule file+ else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing generateCoreRule getImportMapRule getAnnotatedParsedSourceRule@@ -1092,6 +1121,5 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable IsHiFileStable instance NFData IsHiFileStable-instance Binary IsHiFileStable type instance RuleResult IsHiFileStable = SourceModified
src/Development/IDE/Core/Shake.hs view
@@ -24,7 +24,7 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake(- IdeState, shakeSessionInit, shakeExtras,+ IdeState, shakeSessionInit, shakeExtras, shakeDb, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, IdeRule, IdeResult,@@ -53,7 +53,6 @@ GlobalIdeOptions(..), HLS.getClientConfig, getPluginConfig,- garbageCollect, knownTargets, setPriority, ideLogger,@@ -74,7 +73,9 @@ HieDb, HieDbWriter(..), VFSHandle(..),- addPersistentRule+ addPersistentRule,+ garbageCollectDirtyKeys,+ garbageCollectDirtyKeysOlderThan, ) where import Control.Concurrent.Async@@ -94,7 +95,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe-import qualified Data.Set as Set import qualified Data.SortedList as SL import qualified Data.Text as T import Data.Time@@ -109,12 +109,20 @@ import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing-import Development.IDE.GHC.Compat (NameCacheUpdater (..), upNameCache)+import Development.IDE.GHC.Compat (NameCache,+ NameCacheUpdater (..),+ initNameCache,+ knownKeyNames,+ mkSplitUniqSupply,+ upNameCache) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake-import Development.IDE.Graph.Classes-import Development.IDE.Graph.Database+import Development.IDE.Graph.Database (ShakeDatabase,+ shakeGetBuildStep,+ shakeOpenDatabase,+ shakeProfileDatabase,+ shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics@@ -137,20 +145,21 @@ import Data.IORef import GHC.Fingerprint import Language.LSP.Types.Capabilities-import NameCache import OpenTelemetry.Eventlog-import PrelInfo-import UniqSupply import Control.Exception.Extra hiding (bracket_)+import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8+import Data.Coerce (coerce) import Data.Default import Data.Foldable (toList) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_)+import Data.String (fromString) import Data.Text (pack)+import Debug.Trace.Flags (userTracingEnabled) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config@@ -194,7 +203,8 @@ ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession- :: [DelayedAction ()]+ :: String+ -> [DelayedAction ()] -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing)@@ -212,7 +222,7 @@ , vfs :: VFSHandle , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config- , dirtyKeys :: IORef (HashSet SomeShakeValue)+ , dirtyKeys :: IORef (HashSet Key) -- ^ Set of dirty rule keys since the last Shake run } @@ -324,10 +334,10 @@ MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> do- void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k)+ void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) return Nothing Just (v,del,ver) -> do- void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k)+ void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics@@ -338,7 +348,7 @@ -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (file,Key k) hm of+ case HMap.lookup (toKey k file) hm of Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver))@@ -353,12 +363,6 @@ s <- getShakeExtras liftIO $ lastValueIO s key file -valueVersion :: Value v -> Maybe TextDocumentVersion-valueVersion = \case- Succeeded ver _ -> Just ver- Stale _ ver _ -> Just ver- Failed _ -> Nothing- mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath@@ -416,7 +420,7 @@ -> Vector FileDiagnostic -> IO () setValues state key file val diags =- void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags)+ void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) -- | Delete the value stored for a given ide build key@@ -427,7 +431,7 @@ -> NormalizedFilePath -> IO () deleteValue ShakeExtras{dirtyKeys, state} key file = do- void $ modifyVar' state $ HMap.delete (file, Key key)+ void $ modifyVar' state $ HMap.delete (toKey key file) atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys@@ -436,9 +440,11 @@ -> k -> [NormalizedFilePath] -> IO ()-recordDirtyKeys ShakeExtras{dirtyKeys} key file =+recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do atomicModifyIORef_ dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file)+ addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file) + -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v.@@ -449,7 +455,7 @@ IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do vs <- readVar state- case HMap.lookup (file, Key key) vs of+ case HMap.lookup (toKey key file) vs of Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v@@ -538,14 +544,35 @@ { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle } <- getIdeOptionsIO shakeExtras- startTelemetry otProfilingEnabled logger $ state 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+ readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys+ readIORef 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)++ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do- initSession <- newSession shakeExtras shakeDb []+ initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession shakeShut :: IdeState -> IO ()@@ -583,8 +610,8 @@ -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued.-shakeRestart :: IdeState -> [DelayedAction ()] -> IO ()-shakeRestart IdeState{..} acts =+shakeRestart :: IdeState -> String -> [DelayedAction ()] -> IO ()+shakeRestart IdeState{..} reason acts = withMVar' shakeSession (\runner -> do@@ -594,8 +621,9 @@ let profile = case res of Just fp -> ", profile saved at " <> fp _ -> ""- let msg = T.pack $ "Restarting build session " ++ keysMsg ++ abortMsg- keysMsg = "for keys " ++ show (HSet.toList backlog) ++ " "+ let msg = T.pack $ "Restarting build session " ++ reason' ++ keysMsg ++ abortMsg+ reason' = "due to " ++ reason+ keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" logDebug (logger shakeExtras) msg notifyTestingLogMessage shakeExtras msg@@ -604,7 +632,7 @@ -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 (\() -> do- (,()) <$> newSession shakeExtras shakeDb acts)+ (,()) <$> newSession shakeExtras shakeDb acts reason) notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do@@ -641,8 +669,9 @@ :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal]+ -> String -> IO ShakeSession-newSession extras@ShakeExtras{..} shakeDb acts = do+newSession extras@ShakeExtras{..} shakeDb acts reason = do IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomically $ peekInProgress actionQueue allPendingKeys <-@@ -654,7 +683,7 @@ -- Runs actions from the work queue sequentially pumpActionThread otSpan = do d <- liftIO $ atomically $ popQueue actionQueue- void $ parallel [run otSpan d, pumpActionThread otSpan]+ actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan -- TODO figure out how to thread the otSpan into defineEarlyCutoff run _otSpan d = do@@ -671,6 +700,7 @@ -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do+ setTag otSpan "_reason" (fromString reason) whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $@@ -725,21 +755,74 @@ val <- readVar hiddenDiagnostics return $ getAllDiagnostics val --- | Clear the results for all files that do not match the given predicate.-garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()-garbageCollect keep = do- ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras- liftIO $- do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file)- void $ modifyVar' diagnostics $ filterDiagnostics keep- void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep- void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri))- let versionsForFile =- HMap.fromListWith Set.union $- mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $- HMap.toList newState- void $ modifyVar' positionMapping $ filterVersionMap versionsForFile+-- | Find and release old keys from the state Hashmap+-- For the record, there are other state sources that this process does not release:+-- * diagnostics store (normal, hidden and published)+-- * position mapping store+-- * indexing queue+-- * exports map+garbageCollectDirtyKeys :: Action [Key]+garbageCollectDirtyKeys = do+ IdeOptions{optCheckParents} <- getIdeOptions+ checkParents <- liftIO optCheckParents+ garbageCollectDirtyKeysOlderThan 0 checkParents +garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key]+garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do+ dirtySet <- getDirtySet+ garbageCollectKeys "dirty GC" maxAge checkParents dirtySet++garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]+garbageCollectKeys label maxAge checkParents agedKeys = do+ start <- liftIO offsetTime+ extras <- getShakeExtras+ (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap ->+ evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys+ liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x ->+ foldl' (flip HSet.insert) x garbage+ t <- liftIO start+ when (n>0) $ liftIO $ do+ logDebug (logger extras) $ T.pack $+ label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"+ when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $+ LSP.sendNotification (SCustomMethod "ghcide/GC")+ (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)+ return garbage++ where+ showKey = show . Q+ removeDirtyKey st@(vmap,(!counter, keys)) (k, age)+ | age > maxAge+ , Just (kt,_) <- fromKeyType k+ , not(kt `HSet.member` preservedKeys checkParents)+ , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap+ = (vmap', (counter+1, k:keys))+ | otherwise = st++countRelevantKeys :: CheckParents -> [Key] -> Int+countRelevantKeys checkParents =+ Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType)++preservedKeys :: CheckParents -> HashSet TypeRep+preservedKeys checkParents = HSet.fromList $+ -- always preserved+ [ typeOf GetFileExists+ , typeOf GetModificationTime+ , typeOf IsFileOfInterest+ , typeOf GhcSessionIO+ , typeOf GetClientSettings+ , typeOf AddWatchedFile+ , typeOf GetKnownTargets+ ]+ ++ concat+ -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph+ [ [ typeOf GetModSummary+ , typeOf GetModSummaryWithoutTimestamps+ , typeOf GetLocatedImports+ ]+ | checkParents /= NeverCheck+ ]+ -- | Define a new Rule without early cutoff define :: IdeRule k v@@ -863,17 +946,37 @@ data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v))-+ | RuleWithCustomNewnessCheck+ { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool+ , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)+ } -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v => RuleBody k v -> Rules ()-defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode isSuccess $ do- defineEarlyCutoff' True key file old mode $ op key file-defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode isSuccess $ do- defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file+defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do+ extras <- getShakeExtras+ let diagnostics diags = do+ traceDiagnostics diags+ updateFileDiagnostics file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags+ defineEarlyCutoff' diagnostics (==) key file old mode $ op key file+defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do+ ShakeExtras{logger} <- getShakeExtras+ let diagnostics diags = do+ traceDiagnostics diags+ mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags+ defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file+defineEarlyCutoff RuleWithCustomNewnessCheck{..} =+ addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode ->+ otTracedAction key file mode traceA $ \ traceDiagnostics -> do+ ShakeExtras{logger} <- getShakeExtras+ let diagnostics diags = do+ mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags+ traceDiagnostics diags+ defineEarlyCutoff' diagnostics newnessCheck key file old mode $+ second (mempty,) <$> build key file defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = defineNoDiagnostics $ \k file -> do@@ -887,15 +990,17 @@ defineEarlyCutoff' :: IdeRule k v- => Bool -- ^ update diagnostics+ => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics+ -- | compare current and previous for freshness+ -> (BS.ByteString -> BS.ByteString -> Bool) -> k -> NormalizedFilePath -> Maybe BS.ByteString -> RunMode -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k)))-defineEarlyCutoff' doDiagnostics key file old mode action = do- extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras+defineEarlyCutoff' doDiagnostics cmp key file old mode action = do+ ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of@@ -903,19 +1008,22 @@ v <- liftIO $ getValues state key file case v of -- No changes in the dependencies and we have- -- an existing result.- Just (v, diags) -> do- when doDiagnostics $- updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags+ -- an existing successful result.+ Just (v@Succeeded{}, diags) -> do+ doDiagnostics $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing- _ -> return Nothing+ _ ->+ -- assert that a "clean" rule is never a cache miss+ -- as this is likely a bug in the dirty key tracking+ assert (mode /= RunDependenciesSame) $ return Nothing res <- case val of Just res -> return res Nothing -> do (bs, (diags, res)) <- actionCatch (do v <- action; liftIO $ evaluate $ force v) $- \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))+ \(e :: SomeException) -> do+ pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) modTime <- liftIO $ (currentValue . fst =<<) <$> getValues state GetModificationTime file (bs, res) <- case res of Nothing -> do@@ -931,12 +1039,10 @@ (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) liftIO $ setValues state key file res (Vector.fromList diags)- if doDiagnostics- then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags- else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]+ doDiagnostics diags let eq = case (bs, fmap decodeShakeValue old) of- (ShakeResult a, Just (ShakeResult b)) -> a == b- (ShakeStale a, Just (ShakeStale b)) -> a == b+ (ShakeResult a, Just (ShakeResult b)) -> cmp a b+ (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result -- or we got ShakeNoCutoff we always return False. _ -> False@@ -947,9 +1053,10 @@ liftIO $ atomicModifyIORef'_ dirtyKeys (HSet.delete $ toKey key file) return res -isSuccess :: A v -> Bool-isSuccess (A Failed{}) = False-isSuccess _ = True+traceA :: A v -> String+traceA (A Failed{}) = "Failed"+traceA (A Stale{}) = "Stale"+traceA (A Succeeded{}) = "Success" -- | Rule type, input file data QDisk k = QDisk k NormalizedFilePath@@ -959,8 +1066,6 @@ instance NFData k => NFData (QDisk k) -instance Binary k => Binary (QDisk k)- instance Show k => Show (QDisk k) where show (QDisk k file) = show k ++ "; " ++ fromNormalizedFilePath file@@ -1106,20 +1211,6 @@ getUriDiagnostics uri ds = maybe [] getDiagnosticsFromStore $ HMap.lookup uri ds--filterDiagnostics ::- (NormalizedFilePath -> Bool) ->- DiagnosticStore ->- DiagnosticStore-filterDiagnostics keep =- HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)--filterVersionMap- :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)- -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)- -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)-filterVersionMap =- HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
src/Development/IDE/Core/Tracing.hs view
@@ -1,13 +1,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoApplicativeDo #-}+{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction- , startTelemetry+ , startProfilingTelemetry , measureMemory , getInstrumentCached , otTracedProvider , otSetUri+ , otTracedGarbageCollection+ , withTrace+ , withEventTrace+ , withTelemetryLogger ) where @@ -15,30 +20,38 @@ import Control.Concurrent.Extra (Var, modifyVar_, newVar, readVar, threadDelay) import Control.Exception (evaluate)-import Control.Exception.Safe (SomeException, catch)-import Control.Monad (forM_, forever, unless, void,- when, (>=>))+import Control.Exception.Safe (SomeException, catch,+ generalBracket)+import Control.Monad (forM_, forever, void, when,+ (>=>))+import Control.Monad.Catch (ExitCase (..), MonadMask) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift import Control.Seq (r0, seqList, seqTuple2, using) import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack) import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as HMap import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.String (IsString (fromString))+import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8)+import Data.Typeable (TypeRep, typeOf)+import Data.Word (Word16) import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionDeps (GhcSessionDeps), GhcSessionIO (GhcSessionIO))-import Development.IDE.Graph (Action, actionBracket)+import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule+import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..))-import Development.IDE.Types.Logger (Logger, logDebug, logInfo)-import Development.IDE.Types.Shake (Key (..), Value,+import Development.IDE.Types.Logger (Logger (Logger), logDebug,+ logInfo)+import Development.IDE.Types.Shake (Value, ValueWithDiagnostics (..),- Values)+ Values, fromKeyType) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler)@@ -46,12 +59,48 @@ import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural)-import OpenTelemetry.Eventlog (Instrument, SpanInFlight (..),- Synchronicity (Asynchronous),- addEvent, beginSpan, endSpan,+import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent,+ beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) +#if MIN_VERSION_ghc(8,8,0)+otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a+otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]+withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a+#else+otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a+otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a]+withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a+#endif++withTrace :: (MonadMask m, MonadIO m) =>+ String -> ((String -> String -> m ()) -> m a) -> m a+withTrace name act+ | userTracingEnabled+ = withSpan (fromString name) $ \sp -> do+ let setSpan' k v = setTag sp (fromString k) (fromString v)+ act setSpan'+ | otherwise = act (\_ _ -> pure ())++withEventTrace name act+ | userTracingEnabled+ = withSpan (fromString name) $ \sp -> do+ act (addEvent sp)+ | otherwise = act (\_ _ -> pure ())++-- | Returns a logger that produces telemetry events in a single span+withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a+withTelemetryLogger k = withSpan "Logger" $ \sp ->+ -- Tracy doesn't like when we create a new span for every log line.+ -- To workaround that, we create a single span for all log events.+ -- This is fine since we don't care about the span itself, only about the events+ k $ Logger $ \p m ->+ addEvent sp (fromString $ show p) (encodeUtf8 $ trim m)+ where+ -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX+ trim = T.take (fromIntegral(maxBound :: Word16) - 10)+ -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler :: MonadUnliftIO m@@ -79,32 +128,43 @@ => k -- ^ The Action's Key -> NormalizedFilePath -- ^ Path to the file the action was run for -> RunMode- -> (a -> Bool)- -> Action (RunResult a) -- ^ The action+ -> (a -> String)+ -> (([FileDiagnostic] -> Action ()) -> Action (RunResult a)) -- ^ The action -> Action (RunResult a)-otTracedAction key file mode success act- | userTracingEnabled =- actionBracket+otTracedAction key file mode result act+ | userTracingEnabled = fst <$>+ generalBracket (do sp <- beginSpan (fromString (show key)) setTag sp "File" (fromString $ fromNormalizedFilePath file) setTag sp "Mode" (fromString $ show mode) return sp )- endSpan- (\sp -> do- res <- act- unless (success $ runValue res) $ setTag sp "error" "1"- setTag sp "changed" $ case res of- RunResult x _ _ -> fromString $ show x- return res)+ (\sp ec -> do+ case ec of+ ExitCaseAbort -> setTag sp "aborted" "1"+ ExitCaseException e -> setTag sp "exception" (pack $ show e)+ ExitCaseSuccess res -> do+ setTag sp "result" (pack $ result $ runValue res)+ setTag sp "changed" $ case res of+ RunResult x _ _ -> fromString $ show x+ endSpan sp)+ (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics ))+ | otherwise = act (\_ -> return ())++otTracedGarbageCollection label act+ | userTracingEnabled = fst <$>+ generalBracket+ (beginSpan label)+ (\sp ec -> do+ case ec of+ ExitCaseAbort -> setTag sp "aborted" "1"+ ExitCaseException e -> setTag sp "exception" (pack $ show e)+ ExitCaseSuccess res -> setTag sp "keys" (pack $ unlines $ map show res)+ endSpan sp)+ (const act) | otherwise = act -#if MIN_VERSION_ghc(8,8,0)-otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a-#else-otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a-#endif otTracedProvider (PluginId pluginName) provider act | userTracingEnabled = do runInIO <- askRunInIO@@ -113,17 +173,17 @@ runInIO act | otherwise = act -startTelemetry :: Bool -> Logger -> Var Values -> IO ()-startTelemetry allTheTime logger stateRef = do++startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO ()+startProfilingTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached- mapCountInstrument <- mkValueObserver "values map count" installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement"- performMeasurement logger stateRef instrumentFor mapCountInstrument+ performMeasurement logger stateRef instrumentFor when allTheTime $ void $ regularly (1 * seconds) $- performMeasurement logger stateRef instrumentFor mapCountInstrument+ performMeasurement logger stateRef instrumentFor where seconds = 1000000 @@ -134,21 +194,23 @@ performMeasurement :: Logger -> Var Values ->- (Maybe Key -> IO OurValueObserver) ->- Instrument 'Asynchronous a m' ->+ (Maybe String -> IO OurValueObserver) -> IO ()-performMeasurement logger stateRef instrumentFor mapCountInstrument = do- withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length+performMeasurement logger stateRef instrumentFor = do values <- readVar stateRef- let keys = Key GhcSession- : Key GhcSessionDeps- : [ k | (_,k) <- HMap.keys values- -- do GhcSessionIO last since it closes over stateRef itself- , k /= Key GhcSession- , k /= Key GhcSessionDeps- , k /= Key GhcSessionIO- ] ++ [Key GhcSessionIO]+ let keys = typeOf GhcSession+ : typeOf GhcSessionDeps+ -- TODO restore+ : [ kty+ | k <- HMap.keys values+ , Just (kty,_) <- [fromKeyType k]+ -- do GhcSessionIO last since it closes over stateRef itself+ , kty /= typeOf GhcSession+ , kty /= typeOf GhcSessionDeps+ , kty /= typeOf GhcSessionIO+ ]+ ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) measureMemory logger [groupedForSharing] instrumentFor stateRef `catch` \(e::SomeException) ->@@ -157,7 +219,7 @@ type OurValueObserver = Int -> IO () -getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)+getInstrumentCached :: IO (Maybe String -> IO OurValueObserver) getInstrumentCached = do instrumentMap <- newVar HMap.empty mapBytesInstrument <- mkValueObserver "value map size_bytes"@@ -179,8 +241,8 @@ measureMemory :: Logger- -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis- -> (Maybe Key -> IO OurValueObserver)+ -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis+ -> (Maybe String -> IO OurValueObserver) -> Var Values -> IO () measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do@@ -195,7 +257,7 @@ repeatUntilJust 3 $ do -- logDebug logger (fromString $ show $ map fst groupedValues) runHeapsize 25000000 $- forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do+ forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do acc <- liftIO $ newIORef 0 observe <- liftIO $ instrumentFor $ Just k mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v@@ -215,12 +277,13 @@ logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where- groupValues :: Values -> [ [(Key, [Value Dynamic])] ]+ groupValues :: Values -> [ [(String, [Value Dynamic])] ] groupValues values = let !groupedValues =- [ [ (k, vv)- | k <- groupKeys- , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k']+ [ [ (show ty, vv)+ | ty <- groupKeys+ , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values+ , kty == ty] ] | groupKeys <- groups ]@@ -234,3 +297,4 @@ case res of Nothing -> repeatUntilJust (nattempts-1) action Just{} -> return res+
src/Development/IDE/Core/UseStale.hs view
@@ -29,6 +29,9 @@ import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import Data.String (fromString)+import Development.IDE.GHC.Compat (RealSrcSpan,+ srcSpanFile)+import Development.IDE.GHC.Compat.Util (unpackFS) import Development.IDE (Action, IdeRule, NormalizedFilePath, Range,@@ -36,8 +39,6 @@ realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.Shake as IDE-import qualified FastString as FS-import SrcLoc ------------------------------------------------------------------------------@@ -113,7 +114,7 @@ instance MapAge RealSrcSpan where mapAgeFrom =- invMapAge (\fs -> rangeToRealSrcSpan (fromString $ FS.unpackFS fs))+ invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) (srcSpanFile &&& realSrcSpanToRange) . mapAgeFrom
src/Development/IDE/GHC/CPP.hs view
@@ -1,17 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019--- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.--- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.--{- HLINT ignore -} -- since copied from upstream- {-# LANGUAGE CPP #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- --@@ -24,149 +15,26 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where +import GHC import Development.IDE.GHC.Compat as Compat-import FileCleanup-import Packages-import Panic-import SysTools-#if MIN_VERSION_ghc(8,8,2)-import LlvmCodeGen (llvmVersionList)-#elif MIN_VERSION_ghc(8,8,0)-import LlvmCodeGen (LlvmVersion (..))+#if !MIN_VERSION_ghc(8,10,0)+import qualified Development.IDE.GHC.Compat.CPP as CPP+#else+import Development.IDE.GHC.Compat.Util #endif++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Driver.Pipeline as Pipeline+import GHC.Settings+#else #if MIN_VERSION_ghc (8,10,0)-import Fingerprint+import qualified DriverPipeline as Pipeline import ToolSettings-#endif--import Control.Monad-import Data.List (intercalate)-import Data.Maybe-import Data.Version-import System.Directory-import System.FilePath-import System.Info----doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()-doCpp dflags raw input_fn output_fn = do- let hscpp_opts = picPOpts dflags- let cmdline_include_paths = includePaths dflags-- pkg_include_dirs <- getPackageIncludePath dflags []- let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []- (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)- let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []- (includePathsQuote cmdline_include_paths)- let include_paths = include_paths_quote ++ include_paths_global-- let verbFlags = getVerbFlags dflags-- let cpp_prog args | raw = SysTools.runCpp dflags args-#if MIN_VERSION_ghc(8,10,0)- | otherwise = SysTools.runCc Nothing #else- | otherwise = SysTools.runCc+import DynFlags #endif- dflags (SysTools.Option "-E" : args)-- let target_defs =- -- NEIL: Patched to use System.Info instead of constants from CPP- [ "-D" ++ os ++ "_BUILD_OS",- "-D" ++ arch ++ "_BUILD_ARCH",- "-D" ++ os ++ "_HOST_OS",- "-D" ++ arch ++ "_HOST_ARCH" ]- -- remember, in code we *compile*, the HOST is the same our TARGET,- -- and BUILD is the same as our HOST.-- let sse_defs =- [ "-D__SSE__" | isSseEnabled dflags ] ++- [ "-D__SSE2__" | isSse2Enabled dflags ] ++- [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]-- let avx_defs =- [ "-D__AVX__" | isAvxEnabled dflags ] ++- [ "-D__AVX2__" | isAvx2Enabled dflags ] ++- [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++- [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++- [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++- [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]-- backend_defs <- getBackendDefs dflags-- let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]- -- Default CPP defines in Haskell source- ghcVersionH <- getGhcVersionPathName dflags- let hsSourceCppOpts = [ "-include", ghcVersionH ]-- -- MIN_VERSION macros- let uids = explicitPackages (pkgState dflags)- pkgs = catMaybes (map (lookupPackage dflags) uids)- mb_macro_include <-- if not (null pkgs) && gopt Opt_VersionMacros dflags- then do macro_stub <- newTempName dflags TFL_CurrentModule "h"- writeFile macro_stub (generatePackageVersionMacros pkgs)- -- Include version macros for every *exposed* package.- -- Without -hide-all-packages and with a package database- -- size of 1000 packages, it takes cpp an estimated 2- -- milliseconds to process this file. See #10970- -- comment 8.- return [SysTools.FileOption "-include" macro_stub]- else return []-- cpp_prog ( map SysTools.Option verbFlags- ++ map SysTools.Option include_paths- ++ map SysTools.Option hsSourceCppOpts- ++ map SysTools.Option target_defs- ++ map SysTools.Option backend_defs- ++ map SysTools.Option th_defs- ++ map SysTools.Option hscpp_opts- ++ map SysTools.Option sse_defs- ++ map SysTools.Option avx_defs- ++ mb_macro_include- -- Set the language mode to assembler-with-cpp when preprocessing. This- -- alleviates some of the C99 macro rules relating to whitespace and the hash- -- operator, which we tend to abuse. Clang in particular is not very happy- -- about this.- ++ [ SysTools.Option "-x"- , SysTools.Option "assembler-with-cpp"- , SysTools.Option input_fn- -- We hackily use Option instead of FileOption here, so that the file- -- name is not back-slashed on Windows. cpp is capable of- -- dealing with / in filenames, so it works fine. Furthermore- -- if we put in backslashes, cpp outputs #line directives- -- with *double* backslashes. And that in turn means that- -- our error messages get double backslashes in them.- -- In due course we should arrange that the lexer deals- -- with these \\ escapes properly.- , SysTools.Option "-o"- , SysTools.FileOption "" output_fn- ])--getBackendDefs :: DynFlags -> IO [String]-getBackendDefs dflags | hscTarget dflags == HscLlvm = do- llvmVer <- figureLlvmVersion dflags- return $ case llvmVer of-#if MIN_VERSION_ghc(8,8,2)- Just v- | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]- | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]-#elif MIN_VERSION_ghc(8,8,0)- Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]- Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-#else- Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] #endif- _ -> []- where- format (major, minor)- | minor >= 100 = error "getBackendDefs: Unsupported minor version"- | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ =- return []- addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s@@ -183,47 +51,13 @@ onOptP f x = x{sOpt_P = f $ sOpt_P x} #endif --- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [Compat.PackageConfig] -> String-generatePackageVersionMacros pkgs = concat- -- Do not add any C-style comments. See #3389.- [ generateMacros "" pkgname version- | pkg <- pkgs- , let version = packageVersion pkg- pkgname = map fixchar (packageNameString pkg)- ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =- concat- ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"- ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"- ," (major1) < ",major1," || \\\n"- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"- ,"\n\n"- ]- where- (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)----- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> IO FilePath-getGhcVersionPathName dflags = do- candidates <- case ghcVersionFile dflags of- Just path -> return [path]- Nothing -> (map (</> "ghcversion.h")) <$>- (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit])+doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp env raw input_fn output_fn =+#if MIN_VERSION_ghc (9,2,0)+ Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn+#elif MIN_VERSION_ghc (8,10,0)+ Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn+#else+ CPP.doCpp (hsc_dflags env) raw input_fn output_fn+#endif - found <- filterM doesFileExist candidates- case found of- [] -> throwGhcExceptionIO (InstallationError- ("ghcversion.h missing; tried: "- ++ intercalate ", " candidates))- (x:_) -> return x
src/Development/IDE/GHC/Compat.hs view
@@ -4,248 +4,144 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms #-}-{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-}-{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove!+{-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(- HieFileResult(..),- HieFile(..), NameCacheUpdater(..),- hieExportNames,- mkHieFile',- enrichHie,- writeHieFile,- readHieFile,- supportsHieFiles,- setHieDir,- dontWriteHieFiles,-#if !MIN_VERSION_ghc(8,8,0)- ml_hie_file,- addBootSuffixLocnOut,- getRealSrcSpan,-#endif hPutStringBuffer, addIncludePathsQuote, getModuleHash,- getPackageName, setUpTypedHoles,- GHC.ModLocation,- Module.addBootSuffix,- pattern ModLocation,- pattern ExposePackage,- HasSrcSpan,- getLoc, upNameCache, disableWarningsAsErrors,- AvailInfo,- tcg_exports,- pattern FunTy, -#if MIN_VERSION_ghc(8,10,0)- module GHC.Hs.Extension,- module LinkerTypes,-#else- module HsExtension,- noExtField,- linkableTime,-#endif--#if MIN_VERSION_ghc(9,0,1)- -- Reexports from GHC- UnitId,- moduleUnitId,- pkgState,- thisInstalledUnitId,- -- Reexports from DynFlags- thisPackage,- writeIfaceFile,-- gcatch,-#else+#if !MIN_VERSION_ghc(9,0,1) RefMap,- Unit, #endif- -- Linear- Scaled,- scaledThing, - lookupUnit',- preloadClosureUs,- -- Reexports from Package- InstalledUnitId,- PackageConfig,- getPackageConfigMap,- getPackageIncludePath,- installedModule,-- pattern DefiniteUnitId,- packageName,- packageNameString,- packageVersion,- toInstalledUnitId,- lookupPackage,- -- lookupPackage',- explicitPackages,- exposedModules,- packageConfigId,- setThisInstalledUnitId,- initUnits,- lookupInstalledPackage,- oldLookupInstalledPackage,- unitDepends,-- haddockInterfaces,-- oldUnhelpfulSpan ,- pattern IsBoot,- pattern NotBoot,- pattern OldRealSrcSpan,-- oldRenderWithStyle,- oldMkUserStyle,- oldMkErrStyle,- oldFormatErrDoc,- oldListVisibleModuleNames,- oldLookupModuleWithSuggestions,- nodeInfo', getNodeIds,- stringToUnit,- rtsUnit,- unitString, - LogActionCompat,- logActionCompat,-- pprSigmaType,-- module GHC,- module DynFlags,- initializePlugins,- applyPluginsParsedResultAction,- module Compat.HieTypes,- module Compat.HieUtils,- dropForAll, isQualifiedImport, GhcVersion(..), ghcVersion,- ghcVersionStr+ ghcVersionStr,+ -- * HIE Compat+ HieFileResult(..),+ HieFile(..),+ hieExportNames,+ mkHieFile',+ enrichHie,+ writeHieFile,+ readHieFile,+ supportsHieFiles,+ setHieDir,+ dontWriteHieFiles,+ module Compat.HieTypes,+ module Compat.HieUtils,+ -- * Compat modules+ module Development.IDE.GHC.Compat.Core,+ module Development.IDE.GHC.Compat.Env,+ module Development.IDE.GHC.Compat.Iface,+ module Development.IDE.GHC.Compat.Logger,+ module Development.IDE.GHC.Compat.Outputable,+ module Development.IDE.GHC.Compat.Parser,+ module Development.IDE.GHC.Compat.Plugins,+ module Development.IDE.GHC.Compat.Units,+ -- * Extras that rely on compat modules+ -- * SysTools+ Option (..),+ runUnlit,+ runPp, ) where -#if MIN_VERSION_ghc(8,10,0)-import LinkerTypes-#endif+import GHC hiding (HasSrcSpan, ModLocation, getLoc,+ lookupName, RealSrcSpan)+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env+import Development.IDE.GHC.Compat.Iface+import Development.IDE.GHC.Compat.Logger+import Development.IDE.GHC.Compat.Outputable+import Development.IDE.GHC.Compat.Parser+import Development.IDE.GHC.Compat.Plugins+import Development.IDE.GHC.Compat.Units+import Development.IDE.GHC.Compat.Util -import DynFlags hiding (ExposePackage)-import qualified DynFlags-import qualified ErrUtils as Err-import Fingerprint (Fingerprint)-import qualified Module-import qualified Outputable as Out-import StringBuffer-#if MIN_VERSION_ghc(9,0,1)-import Control.Exception.Safe as Safe (Exception, MonadCatch, catch)-import qualified Data.Set as S-import GHC.Core.TyCo.Ppr (pprSigmaType)-import GHC.Core.TyCo.Rep (Scaled, scaledThing)-import GHC.Iface.Load-import GHC.Types.Unique.Set (emptyUniqSet)-import Module (unitString)-import qualified SrcLoc+#if MIN_VERSION_ghc(9,0,0)+import GHC.Data.StringBuffer+import GHC.Driver.Session hiding (ExposePackage)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Env as Env+import GHC.Unit.Module.ModIface #else-import Module (InstalledUnitId,- UnitId (DefiniteUnitId),- toInstalledUnitId)-import TcType (pprSigmaType)+import GHC.Driver.Types #endif-import Compat.HieAst (enrichHie)-import Compat.HieBin-import Compat.HieTypes-import Compat.HieUtils-import qualified Data.ByteString as BS-import Data.IORef-import HscTypes-import MkIface-import NameCache-import Packages-import TcRnTypes--#if MIN_VERSION_ghc(8,10,0)-import GHC.Hs.Extension+import GHC.Iface.Env+import GHC.Iface.Make (mkIfaceExports)+import qualified GHC.SysTools.Tasks as SysTools+import qualified GHC.Types.Avail as Avail #else-import HsExtension-#endif+import DynFlags hiding (ExposePackage)+import HscTypes+import MkIface hiding (writeIfaceFile)+import qualified Avail -import Avail-import GHC hiding (HasSrcSpan, ModLocation, getLoc,- lookupName)-import qualified GHC-import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0)-import Data.List (foldl')-#else-import Data.List (foldl', isSuffixOf)+import StringBuffer (hPutStringBuffer) #endif--import qualified Data.Map as M-import DynamicLoading-import Plugins (Plugin (parsedResultAction),- withPlugins)+import qualified SysTools #if !MIN_VERSION_ghc(8,8,0) import SrcLoc (RealLocated)-import System.FilePath ((-<.>))-#endif--#if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import Foreign.ForeignPtr import System.IO+#endif+#endif +import Compat.HieAst (enrichHie)+import Compat.HieBin+import Compat.HieTypes+import Compat.HieUtils+import qualified Data.ByteString as BS+import Data.IORef +import qualified Data.Map as Map+import Data.List (foldl')++#if MIN_VERSION_ghc(9,0,0)+import qualified Data.Set as S+#endif++#if !MIN_VERSION_ghc(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len- #endif -#if !MIN_VERSION_ghc(8,10,0)-noExtField :: NoExt-noExtField = noExt-#endif- supportsHieFiles :: Bool supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if !MIN_VERSION_ghc(8,8,0)-ml_hie_file :: GHC.ModLocation -> FilePath-ml_hie_file ml- | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot"- | otherwise = ml_hi_file ml -<.> ".hie"-#endif- upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c-#if !MIN_VERSION_ghc(8,8,0)+#if MIN_VERSION_ghc(8,8,0)+upNameCache = updNameCache+#else upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn-#else-upNameCache = updNameCache #endif - #if !MIN_VERSION_ghc(9,0,1)-type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]+type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] #endif mkHieFile' :: ModSummary- -> [AvailInfo]+ -> [Avail.AvailInfo] -> HieASTs Type -> BS.ByteString -> Hsc HieFile@@ -266,15 +162,6 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} -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- setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_VERSION_ghc(8,8,0)@@ -312,46 +199,11 @@ } -nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]+nameListFromAvails :: [Avail.AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as =- map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)+ map (\n -> (nameSrcSpan n, n)) (concatMap Avail.availNames as) -#if MIN_VERSION_ghc(9,0,0)--- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x)--- type HasSrcSpan x = () :: Constraint -class HasSrcSpan a where- getLoc :: a -> SrcSpan--instance HasSrcSpan (GenLocated SrcSpan a) where- getLoc = GHC.getLoc---- getLoc :: GenLocated l a -> l--- getLoc = GHC.getLoc--#elif MIN_VERSION_ghc(8,8,0)-type HasSrcSpan = GHC.HasSrcSpan-getLoc :: HasSrcSpan a => a -> SrcSpan-getLoc = GHC.getLoc--#else--class HasSrcSpan a where- getLoc :: a -> SrcSpan-instance HasSrcSpan Name where- getLoc = nameSrcSpan-instance HasSrcSpan (GenLocated SrcSpan a) where- getLoc = GHC.getLoc---- | Add the @-boot@ suffix to all output file paths associated with the--- module, not including the input file itself-addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation-addBootSuffixLocnOut locn- = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn)- , ml_obj_file = Module.addBootSuffix (ml_obj_file locn)- }-#endif- getModuleHash :: ModIface -> Fingerprint #if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts@@ -359,138 +211,7 @@ getModuleHash = mi_mod_hash #endif --- type PackageName = Packages.PackageName-#if MIN_VERSION_ghc(9,0,0)--- NOTE: Since both the new and old version uses UnitId with different meaning,--- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous.-type UnitId = Module.Unit-type InstalledUnitId = Module.UnitId-type PackageConfig = Packages.UnitInfo-pattern DefiniteUnitId x = Module.RealUnit x-definiteUnitId = Module.RealUnit-defUnitId = Module.Definite-installedModule = Module.Module--- pattern InstalledModule a b = Module.Module a b-packageName = Packages.unitPackageName-lookupPackage = Packages.lookupUnit . unitState--- lookupPackage' = undefined--- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u--- lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct?--- lookupPackage' = fmap Packages.lookupUnit' . unitState-getPackageConfigMap = Packages.unitInfoMap . unitState-preloadClosureUs = Packages.preloadClosure . unitState--- getPackageConfigMap = unitState--- getPackageIncludePath = undefined-getPackageIncludePath = Packages.getUnitIncludePath-explicitPackages = Packages.explicitUnits-pkgState = GHC.unitState-packageNameString = Packages.unitPackageNameString-packageVersion = Packages.unitPackageVersion--- toInstalledUnitId = id -- Module.toUnitId -- TODO: This is probably wrong-toInstalledUnitId = Module.toUnitId-exposedModules = Packages.unitExposedModules-packageConfigId = Packages.mkUnit-moduleUnitId = Module.moduleUnit-lookupInstalledPackage = Packages.lookupUnitId-oldLookupInstalledPackage = Packages.lookupUnitId . unitState--- initUnits = Packages.initUnits--- initPackages = initPackagesx-haddockInterfaces = unitHaddockInterfaces -thisInstalledUnitId = GHC.homeUnitId-thisPackage = DynFlags.homeUnit-setThisInstalledUnitId uid df = df { homeUnitId = uid}--oldUnhelpfulSpan = UnhelpfulSpan . SrcLoc.UnhelpfulOther--- unhelpfulOther = unhelpfulOther . _-pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan-pattern OldRealSrcSpan x <- RealSrcSpan x _ where- OldRealSrcSpan x = RealSrcSpan x Nothing-{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}--oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState-oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState--- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState--oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc-oldMkUserStyle _ = Out.mkUserStyle-oldMkErrStyle _ = Out.mkErrStyle---- TODO: This is still a mess!-oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc-oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext- where dummySDocContext = initSDocContext dflags Out.defaultUserStyle--- oldFormatErrDoc = Err.formatErrDoc . undefined-writeIfaceFile = writeIface--type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO ()---- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test.-logActionCompat :: LogActionCompat -> LogAction-logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify---- We are using Safe here, which is not equivalent, but probably what we want.-gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a-gcatch = Safe.catch--#else--type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO ()--logActionCompat :: LogActionCompat -> LogAction-logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style)--type Unit = Module.UnitId--- type PackageConfig = Packages.PackageConfig-definiteUnitId :: Module.DefUnitId -> UnitId-definiteUnitId = Module.DefiniteUnitId-defUnitId :: InstalledUnitId -> Module.DefUnitId-defUnitId = Module.DefUnitId-installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule-installedModule = Module.InstalledModule-oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig-oldLookupInstalledPackage = Packages.lookupInstalledPackage--- packageName = Packages.packageName--- lookupPackage = Packages.lookupPackage--- getPackageConfigMap = Packages.getPackageConfigMap-setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags-setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid}--lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig-lookupUnit' b pcm _ = Packages.lookupPackage' b pcm-preloadClosureUs = const ()--oldUnhelpfulSpan = UnhelpfulSpan-pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan-pattern OldRealSrcSpan x = RealSrcSpan x-{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-}--pattern NotBoot, IsBoot :: IsBootInterface-pattern NotBoot = False-pattern IsBoot = True--initUnits = fmap fst . Packages.initPackages--unitDepends = depends--oldListVisibleModuleNames = Packages.listVisibleModuleNames-oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions--- oldLookupInPackageDB = Packages.lookupInPackageDB--oldRenderWithStyle = Out.renderWithStyle-oldMkUserStyle = Out.mkUserStyle-oldMkErrStyle = Out.mkErrStyle-oldFormatErrDoc = Err.formatErrDoc---- Linear Haskell-type Scaled a = a-scaledThing :: Scaled a -> a-scaledThing = id-#endif--getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName-getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i))- disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]@@ -499,42 +220,8 @@ wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }--getRealSrcSpan :: RealLocated a -> RealSrcSpan-getRealSrcSpan = GHC.getLoc #endif -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource-applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do- -- Apply parsedResultAction of plugins- let applyPluginAction p opts = parsedResultAction p opts ms- fmap hpm_module $- runHsc env $ withPlugins dflags applyPluginAction- (HsParsedModule parsed [] hpm_annotations)--pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag--- https://github.com/facebook/fbghc-#ifdef __FACEBOOK_HASKELL__-pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr-#else-pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr-#endif---- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body-dropForAll :: LHsType pass -> LHsType pass-#if MIN_VERSION_ghc(8,10,0)-dropForAll = snd . GHC.splitLHsForAllTyInvis-#else-dropForAll = snd . GHC.splitLHsForAllTy-#endif--pattern FunTy :: Type -> Type -> Type-#if MIN_VERSION_ghc(8,10,0)-pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res}-#else-pattern FunTy arg res <- TyCoRep.FunTy arg res-#endif- isQualifiedImport :: ImportDecl a -> Bool #if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False@@ -547,19 +234,21 @@ #if MIN_VERSION_ghc(9,0,0)-getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a)-getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo+getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a)+getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo -ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd+combineNodeIds :: Map.Map Identifier (IdentifierDetails a)+ -> NodeInfo a -> Map.Map Identifier (IdentifierDetails a)+ad `combineNodeIds` (NodeInfo _ _ bd) = Map.unionWith (<>) ad bd -- Copied from GHC and adjusted to accept TypeIndex instead of Type -- nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex-nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo+nodeInfo' = Map.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a (NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) =- NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+ NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] mergeSorted la@(a:as) lb@(b:bs) = case compare a b of@@ -569,10 +258,9 @@ mergeSorted as [] = as mergeSorted [] bs = bs -stringToUnit = Module.stringToUnit-rtsUnit = Module.rtsUnit #else +getNodeIds :: HieAST a -> NodeIdentifiers a getNodeIds = nodeIdentifiers . nodeInfo -- import qualified FastString as FS @@ -580,15 +268,10 @@ nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId-unitString :: Unit -> String-unitString = Module.unitIdString-stringToUnit :: String -> Unit-stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit -- moduleUnit = moduleUnitId -- unhelpfulSpanFS :: FS.FastString -> FS.FastString -- unhelpfulSpanFS = id-rtsUnit = Module.rtsUnitId #endif data GhcVersion@@ -596,13 +279,16 @@ | GHC88 | GHC810 | GHC90+ | GHC92 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+ghcVersion = GHC92+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810@@ -610,4 +296,20 @@ ghcVersion = GHC88 #elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) ghcVersion = GHC86+#endif++runUnlit :: Logger -> DynFlags -> [Option] -> IO ()+runUnlit =+#if MIN_VERSION_ghc(9,2,0)+ SysTools.runUnlit+#else+ const SysTools.runUnlit+#endif++runPp :: Logger -> DynFlags -> [Option] -> IO ()+runPp =+#if MIN_VERSION_ghc(9,2,0)+ SysTools.runPp+#else+ const SysTools.runPp #endif
+ src/Development/IDE/GHC/Compat/CPP.hs view
@@ -0,0 +1,204 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019+-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944.+-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed.++{- HLINT ignore -} -- since copied from upstream++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+-- | Re-export 'doCpp' for GHC < 8.10.+--+-- Later versions export what we need.+module Development.IDE.GHC.Compat.CPP (+ doCpp+ ) where++import FileCleanup+import Packages+import Panic+import SysTools+#if MIN_VERSION_ghc(8,8,2)+import LlvmCodeGen (llvmVersionList)+#elif MIN_VERSION_ghc(8,8,0)+import LlvmCodeGen (LlvmVersion (..))+#endif+import DynFlags+import Module (toInstalledUnitId, rtsUnitId)+import Control.Monad+import Data.List (intercalate)+import Data.Maybe+import Data.Version+import System.Directory+import System.FilePath+import System.Info++import Development.IDE.GHC.Compat as Compat++doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags raw input_fn output_fn = do+ let hscpp_opts = picPOpts dflags+ let cmdline_include_paths = includePaths dflags++ pkg_include_dirs <- getPackageIncludePath dflags []+ let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+ let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+ (includePathsQuote cmdline_include_paths)+ let include_paths = include_paths_quote ++ include_paths_global++ let verbFlags = getVerbFlags dflags++ let cpp_prog args | raw = SysTools.runCpp dflags args+#if MIN_VERSION_ghc(8,10,0)+ | otherwise = SysTools.runCc Nothing+#else+ | otherwise = SysTools.runCc+#endif+ dflags (SysTools.Option "-E" : args)++ let target_defs =+ -- NEIL: Patched to use System.Info instead of constants from CPP+ [ "-D" ++ os ++ "_BUILD_OS",+ "-D" ++ arch ++ "_BUILD_ARCH",+ "-D" ++ os ++ "_HOST_OS",+ "-D" ++ arch ++ "_HOST_ARCH" ]+ -- remember, in code we *compile*, the HOST is the same our TARGET,+ -- and BUILD is the same as our HOST.++ let sse_defs =+ [ "-D__SSE__" | isSseEnabled dflags ] +++ [ "-D__SSE2__" | isSse2Enabled dflags ] +++ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]++ let avx_defs =+ [ "-D__AVX__" | isAvxEnabled dflags ] +++ [ "-D__AVX2__" | isAvx2Enabled dflags ] +++ [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++ [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++ [ "-D__AVX512F__" | isAvx512fEnabled dflags ] +++ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++ backend_defs <- getBackendDefs dflags++ let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+ -- Default CPP defines in Haskell source+ ghcVersionH <- getGhcVersionPathName dflags+ let hsSourceCppOpts = [ "-include", ghcVersionH ]++ -- MIN_VERSION macros+ let uids = explicitPackages (pkgState dflags)+ pkgs = catMaybes (map (lookupPackage dflags) uids)+ mb_macro_include <-+ if not (null pkgs) && gopt Opt_VersionMacros dflags+ then do macro_stub <- newTempName dflags TFL_CurrentModule "h"+ writeFile macro_stub (generatePackageVersionMacros pkgs)+ -- Include version macros for every *exposed* package.+ -- Without -hide-all-packages and with a package database+ -- size of 1000 packages, it takes cpp an estimated 2+ -- milliseconds to process this file. See #10970+ -- comment 8.+ return [SysTools.FileOption "-include" macro_stub]+ else return []++ cpp_prog ( map SysTools.Option verbFlags+ ++ map SysTools.Option include_paths+ ++ map SysTools.Option hsSourceCppOpts+ ++ map SysTools.Option target_defs+ ++ map SysTools.Option backend_defs+ ++ map SysTools.Option th_defs+ ++ map SysTools.Option hscpp_opts+ ++ map SysTools.Option sse_defs+ ++ map SysTools.Option avx_defs+ ++ mb_macro_include+ -- Set the language mode to assembler-with-cpp when preprocessing. This+ -- alleviates some of the C99 macro rules relating to whitespace and the hash+ -- operator, which we tend to abuse. Clang in particular is not very happy+ -- about this.+ ++ [ SysTools.Option "-x"+ , SysTools.Option "assembler-with-cpp"+ , SysTools.Option input_fn+ -- We hackily use Option instead of FileOption here, so that the file+ -- name is not back-slashed on Windows. cpp is capable of+ -- dealing with / in filenames, so it works fine. Furthermore+ -- if we put in backslashes, cpp outputs #line directives+ -- with *double* backslashes. And that in turn means that+ -- our error messages get double backslashes in them.+ -- In due course we should arrange that the lexer deals+ -- with these \\ escapes properly.+ , SysTools.Option "-o"+ , SysTools.FileOption "" output_fn+ ])++getBackendDefs :: DynFlags -> IO [String]+getBackendDefs dflags | hscTarget dflags == HscLlvm = do+ llvmVer <- figureLlvmVersion dflags+ return $ case llvmVer of+#if MIN_VERSION_ghc(8,8,2)+ Just v+ | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]+ | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]+#elif MIN_VERSION_ghc(8,8,0)+ Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]+ Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+#else+ Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+#endif+ _ -> []+ where+ format (major, minor)+ | minor >= 100 = error "getBackendDefs: Unsupported minor version"+ | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ =+ return []++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [Compat.UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+ -- Do not add any C-style comments. See #3389.+ [ generateMacros "" pkgname version+ | pkg <- pkgs+ , let version = packageVersion pkg+ pkgname = map fixchar (packageNameString pkg)+ ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+ concat+ ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+ ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+ ," (major1) < ",major1," || \\\n"+ ," (major1) == ",major1," && (major2) < ",major2," || \\\n"+ ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+ ,"\n\n"+ ]+ where+ (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> IO FilePath+getGhcVersionPathName dflags = do+ candidates <- case ghcVersionFile dflags of+ Just path -> return [path]+ Nothing -> (map (</> "ghcversion.h")) <$>+ (getPackageIncludePath dflags [toInstalledUnitId rtsUnit])++ found <- filterM doesFileExist candidates+ case found of+ [] -> throwGhcExceptionIO (InstallationError+ ("ghcversion.h missing; tried: "+ ++ intercalate ", " candidates))+ (x:_) -> return x++rtsUnit :: UnitId+rtsUnit = Module.rtsUnitId
+ src/Development/IDE/GHC/Compat/Core.hs view
@@ -0,0 +1,860 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+-- TODO: remove+{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-}++-- | Compat Core module that handles the GHC module hierarchy re-organisation+-- by re-exporting everything we care about.+--+-- This module provides no other compat mechanisms, except for simple+-- backward-compatible pattern synonyms.+module Development.IDE.GHC.Compat.Core (+ -- * Session+ DynFlags,+ extensions,+ extensionFlags,+ targetPlatform,+ packageFlags,+ generalFlags,+ warningFlags,+ topDir,+ hiDir,+ tmpDir,+ importPaths,+ useColor,+ canUseColor,+ useUnicode,+ objectDir,+ flagsForCompletion,+ setImportPaths,+ outputFile,+ pluginModNames,+ refLevelHoleFits,+ maxRefHoleFits,+ maxValidHoleFits,+#if MIN_VERSION_ghc(8,8,0)+ CommandLineOption,+#if !MIN_VERSION_ghc(9,2,0)+ staticPlugins,+#endif+#endif+ sPgm_F,+ settings,+ gopt,+ gopt_set,+ gopt_unset,+ wopt,+ wopt_set,+ xFlags,+ xopt,+ xopt_unset,+ xopt_set,+ FlagSpec(..),+ WarningFlag(..),+ GeneralFlag(..),+ PackageFlag,+ PackageArg(..),+ ModRenaming(..),+ pattern ExposePackage,+ parseDynamicFlagsCmdLine,+ parseDynamicFilePragma,+ WarnReason(..),+ wWarningFlags,+ updOptLevel,+ -- slightly unsafe+ setUnsafeGlobalDynFlags,+ -- * Linear Haskell+ Scaled,+ scaledThing,+ -- * Interface Files+ IfaceExport,+ IfaceTyCon(..),+#if MIN_VERSION_ghc(8,10,0)+ ModIface,+ ModIface_(..),+#else+ ModIface(..),+#endif+ HscSource(..),+ WhereFrom(..),+ loadInterface,+ SourceModified(..),+ loadModuleInterface,+ RecompileRequired(..),+#if MIN_VERSION_ghc(8,10,0)+ mkPartialIface,+ mkFullIface,+#else+ mkIface,+#endif+ checkOldIface,+#if MIN_VERSION_ghc(9,0,0)+ IsBootInterface(..),+#else+ pattern IsBoot,+ pattern NotBoot,+#endif+ -- * Fixity+ LexicalFixity(..),+ -- * ModSummary+ ModSummary(..),+ -- * HomeModInfo+ HomeModInfo(..),+ -- * ModGuts+ ModGuts(..),+ CgGuts(..),+ -- * ModDetails+ ModDetails(..),+ -- * Var+ Type (+ TyCoRep.TyVarTy,+ TyCoRep.AppTy,+ TyCoRep.TyConApp,+ TyCoRep.ForAllTy,+ -- Omitted on purpose+ -- pattern Synonym right below it+ -- TyCoRep.FunTy,+ TyCoRep.LitTy,+ TyCoRep.CastTy,+ TyCoRep.CoercionTy+ ),+ pattern FunTy,+ Development.IDE.GHC.Compat.Core.splitForAllTyCoVars,+ Development.IDE.GHC.Compat.Core.mkVisFunTys,+ Development.IDE.GHC.Compat.Core.mkInfForAllTys,+ -- * Specs+ ImpDeclSpec(..),+ ImportSpec(..),+ -- * SourceText+ SourceText(..),+ -- * Name+ tyThingParent_maybe,+ -- * Ways+ Way,+ wayGeneralFlags,+ wayUnsetGeneralFlags,+ -- * AvailInfo+ Avail.AvailInfo,+ pattern AvailName,+ pattern AvailFL,+ pattern AvailTC,+ Avail.availName,+ Avail.availNames,+ Avail.availNamesWithSelectors,+ Avail.availsToNameSet,+ -- * TcGblEnv+ TcGblEnv(..),+ -- * Parsing and LExer types+ HsParsedModule(..),+ GHC.ParsedModule(..),+ GHC.ParsedSource,+ GHC.RenamedSource,+ -- * Compilation Main+ HscEnv,+ GHC.runGhc,+ unGhc,+ Session(..),+ modifySession,+ getSession,+ GHC.setSessionDynFlags,+ getSessionDynFlags,+ GhcMonad,+ Ghc,+ runHsc,+ compileFile,+ Phase(..),+ hscDesugar,+ hscGenHardCode,+ hscInteractive,+ hscSimplify,+ hscTypecheckRename,+ makeSimpleDetails,+ -- * Typecheck utils+ Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars,+ Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe,+ typecheckIface,+ mkIfaceTc,+ ImportedModsVal(..),+ importedByUser,+ GHC.TypecheckedSource,+ -- * Source Locations+ HasSrcSpan,+ SrcLoc.Located,+ SrcLoc.unLoc,+ getLoc,+ SrcLoc.RealLocated,+ SrcLoc.GenLocated(..),+ SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan),+ SrcLoc.RealSrcSpan,+ pattern RealSrcSpan,+ SrcLoc.RealSrcLoc,+ pattern RealSrcLoc,+ SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc),+ BufSpan,+ SrcLoc.leftmost_smallest,+ SrcLoc.containsSpan,+ SrcLoc.mkGeneralSrcSpan,+ SrcLoc.mkRealSrcSpan,+ SrcLoc.mkRealSrcLoc,+ getRealSrcSpan,+ SrcLoc.realSrcLocSpan,+ SrcLoc.realSrcSpanStart,+ SrcLoc.realSrcSpanEnd,+ SrcLoc.isSubspanOf,+ SrcLoc.wiredInSrcSpan,+ SrcLoc.mkSrcSpan,+ SrcLoc.srcSpanStart,+ SrcLoc.srcSpanStartLine,+ SrcLoc.srcSpanStartCol,+ SrcLoc.srcSpanEnd,+ SrcLoc.srcSpanEndLine,+ SrcLoc.srcSpanEndCol,+ SrcLoc.srcSpanFile,+ SrcLoc.srcLocCol,+ SrcLoc.srcLocFile,+ SrcLoc.srcLocLine,+ SrcLoc.noSrcSpan,+ SrcLoc.noSrcLoc,+ SrcLoc.noLoc,+#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0)+ SrcLoc.dL,+#endif+ -- * Finder+ FindResult(..),+ mkHomeModLocation,+ addBootSuffixLocnOut,+ findObjectLinkableMaybe,+ InstalledFindResult(..),+ -- * Module and Package+ ModuleOrigin(..),+ PackageName(..),+ -- * Linker+ Unlinked(..),+ Linkable(..),+ unload,+ initDynLinker,+ -- * Hooks+ Hooks,+ runMetaHook,+ MetaHook,+ MetaRequest(..),+ metaRequestE,+ metaRequestP,+ metaRequestT,+ metaRequestD,+ metaRequestAW,+ -- * HPT+ addToHpt,+ addListToHpt,+ -- * Driver-Make+ Target(..),+ TargetId(..),+ mkModuleGraph,+ -- * GHCi+ initObjLinker,+ loadDLL,+ InteractiveImport(..),+ GHC.getContext,+ GHC.setContext,+ GHC.parseImportDecl,+ GHC.runDecls,+ Warn(..),+ -- * ModLocation+ GHC.ModLocation,+ pattern ModLocation,+ Module.ml_hs_file,+ Module.ml_obj_file,+ Module.ml_hi_file,+ Development.IDE.GHC.Compat.Core.ml_hie_file,+ -- * DataCon+ Development.IDE.GHC.Compat.Core.dataConExTyCoVars,+ -- * Role+ Role(..),+ -- * Panic+ PlainGhcException,+ panic,+ -- * Util Module re-exports+#if MIN_VERSION_ghc(9,0,0)+ module GHC.Builtin.Names,+ module GHC.Builtin.Types,+ module GHC.Builtin.Types.Prim,+ module GHC.Builtin.Utils,+ module GHC.Core.Class,+ module GHC.Core.Coercion,+ module GHC.Core.ConLike,+ module GHC.Core.DataCon,+ module GHC.Core.FamInstEnv,+ module GHC.Core.InstEnv,+#if !MIN_VERSION_ghc(9,2,0)+ module GHC.Core.Ppr.TyThing,+#endif+ module GHC.Core.PatSyn,+ module GHC.Core.Predicate,+ module GHC.Core.TyCon,+ module GHC.Core.TyCo.Ppr,+ module GHC.Core.Type,+ module GHC.Core.Unify,+ module GHC.Core.Utils,++ module GHC.HsToCore.Docs,+ module GHC.HsToCore.Expr,+ module GHC.HsToCore.Monad,++ module GHC.Iface.Tidy,+ module GHC.Iface.Syntax,++#if MIN_VERSION_ghc(9,2,0)+ module Language.Haskell.Syntax.Expr,+#endif++ module GHC.Rename.Names,+ module GHC.Rename.Splice,++ module GHC.Tc.Instance.Family,+ module GHC.Tc.Module,+ module GHC.Tc.Types,+ module GHC.Tc.Types.Evidence,+ module GHC.Tc.Utils.Env,+ module GHC.Tc.Utils.Monad,++ module GHC.Types.Basic,+ module GHC.Types.Id,+ module GHC.Types.Name ,+ module GHC.Types.Name.Set,++ module GHC.Types.Name.Cache,+ module GHC.Types.Name.Env,+ module GHC.Types.Name.Reader,+#if MIN_VERSION_ghc(9,2,0)+ module GHC.Types.SourceFile,+ module GHC.Types.SourceText,+ module GHC.Types.TyThing,+ module GHC.Types.TyThing.Ppr,+#endif+ module GHC.Types.Unique.Supply,+ module GHC.Types.Var,+ module GHC.Unit.Module,+ module GHC.Utils.Error,+#else+ module BasicTypes,+ module Class,+#if MIN_VERSION_ghc(8,10,0)+ module Coercion,+ module Predicate,+#endif+ module ConLike,+ module CoreUtils,+ module DataCon,+ module DsExpr,+ module DsMonad,+ module ErrUtils,+ module FamInst,+ module FamInstEnv,+ module HeaderInfo,+ module Id,+ module InstEnv,+ module IfaceSyn,+ module Module,+ module Name,+ module NameCache,+ module NameEnv,+ module NameSet,+ module PatSyn,+ module PprTyThing,+ module PrelInfo,+ module PrelNames,+ module RdrName,+ module RnSplice,+ module RnNames,+ module TcEnv,+ module TcEvidence,+ module TcType,+ module TcRnTypes,+ module TcRnDriver,+ module TcRnMonad,+ module TidyPgm,+ module TyCon,+ module TysPrim,+ module TysWiredIn,+ module Type,+ module Unify,+ module UniqSupply,+ module Var,+#endif+ -- * Syntax re-exports+#if MIN_VERSION_ghc(9,0,0)+ module GHC.Hs,+ module GHC.Parser,+ module GHC.Parser.Header,+ module GHC.Parser.Lexer,+#else+#if MIN_VERSION_ghc(8,10,0)+ module GHC.Hs,+#else+ module HsBinds,+ module HsDecls,+ module HsDoc,+ module HsExtension,+ noExtField,+ module HsExpr,+ module HsImpExp,+ module HsLit,+ module HsPat,+ module HsSyn,+ module HsTypes,+ module HsUtils,+#endif+ module ExtractDocs,+ module Parser,+ module Lexer,+#endif+ ) where++import qualified GHC++#if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Names hiding (Unique, printName)+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Utils+import GHC.Core.Class+import GHC.Core.Coercion+import GHC.Core.ConLike+import GHC.Core.DataCon hiding (dataConExTyCoVars)+import qualified GHC.Core.DataCon as DataCon+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv+#if MIN_VERSION_ghc(9,2,0)+import GHC.Core.Multiplicity (scaledThing)+#else+import GHC.Core.Ppr.TyThing hiding (pprFamInst)+import GHC.Core.TyCo.Rep (scaledThing)+#endif+import GHC.Core.PatSyn+import GHC.Core.Predicate+import GHC.Core.TyCo.Ppr+import qualified GHC.Core.TyCo.Rep as TyCoRep+import GHC.Core.TyCon+import GHC.Core.Type hiding (mkInfForAllTys, mkVisFunTys)+import GHC.Core.Unify+import GHC.Core.Utils++#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Env+#else+import GHC.Driver.Finder+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.Monad+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Plugins+import GHC.Driver.Session hiding (ExposePackage)+import qualified GHC.Driver.Session as DynFlags+#if !MIN_VERSION_ghc(9,2,0)+import GHC.Hs+#endif+import GHC.HsToCore.Docs+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.Iface.Load+import GHC.Iface.Make (mkFullIface, mkIfaceTc,+ mkPartialIface)+import GHC.Iface.Recomp+import GHC.Iface.Syntax+import GHC.Iface.Tidy+import GHC.IfaceToCore+import GHC.Parser+import GHC.Parser.Header hiding (getImports)+import GHC.Parser.Lexer+#if MIN_VERSION_ghc(9,2,0)+import GHC.Linker.Loader+import GHC.Linker.Types+import GHC.Platform.Ways+#else+import GHC.Runtime.Linker+#endif+import GHC.Rename.Names+import GHC.Rename.Splice+import GHC.Runtime.Interpreter+import GHC.Tc.Instance.Family+import GHC.Tc.Module+import GHC.Tc.Types+import GHC.Tc.Types.Evidence hiding ((<.>))+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef,+ MonadFix (..), MonadIO (..), allM,+ anyM, concatMapM, mapMaybeM, (<$>))+import GHC.Tc.Utils.TcType as TcType+import qualified GHC.Types.Avail as Avail+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.Meta+#endif+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Name hiding (varName)+import GHC.Types.Name.Cache+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.Name.Set+import GHC.Types.SourceFile (HscSource (..),+ SourceModified (..))+import GHC.Types.SourceText+import GHC.Types.TyThing+import GHC.Types.TyThing.Ppr+#else+import GHC.Types.Name.Set+#endif+import GHC.Types.SrcLoc (BufPos, BufSpan, SrcSpan (UnhelpfulSpan), SrcLoc(UnhelpfulLoc))+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique.Supply+import GHC.Types.Var (Var (varName), setTyVarUnique,+ setVarUnique)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Unit.Finder+import GHC.Unit.Home.ModInfo+#endif+import GHC.Unit.Info (PackageName (..))+import GHC.Unit.Module hiding (ModLocation (..), UnitId,+ addBootSuffixLocnOut, moduleUnit,+ toUnitId)+import qualified GHC.Unit.Module as Module+#if MIN_VERSION_ghc(9,2,0)+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface (IfaceExport)+#endif+import GHC.Unit.State (ModuleOrigin (..))+import GHC.Utils.Error (Severity (..))+import GHC.Utils.Panic hiding (try)+import qualified GHC.Utils.Panic.Plain as Plain+#else+import qualified Avail+import BasicTypes hiding (Version)+import Class+import CmdLineParser (Warn (..))+import ConLike+import CoreUtils+import DataCon hiding (dataConExTyCoVars)+import qualified DataCon+import DriverPhases+import DriverPipeline+import DsExpr+import DsMonad hiding (foldrM)+import DynFlags hiding (ExposePackage)+import qualified DynFlags+import ErrUtils hiding (logInfo, mkWarnMsg)+import ExtractDocs+import FamInst+import FamInstEnv+import Finder+#if MIN_VERSION_ghc(8,10,0)+import GHC.Hs+#endif+import GHCi+import GhcMonad+import HeaderInfo hiding (getImports)+import Hooks+import HscMain+import HscTypes+#if !MIN_VERSION_ghc(8,10,0)+-- Syntax imports+import HsBinds+import HsDecls+import HsDoc+import HsExpr+import HsExtension+import HsImpExp+import HsLit+import HsPat+import HsSyn hiding (wildCardName)+import HsTypes hiding (wildCardName)+import HsUtils+#endif+import Id+import IfaceSyn+import InstEnv+import Lexer hiding (getSrcLoc)+import Linker+import LoadIface+import MkIface+import Module hiding (ModLocation (..), UnitId,+ addBootSuffixLocnOut, moduleUnitId)+import qualified Module+import Name hiding (varName)+import NameCache+import NameEnv+import NameSet+import Packages+#if MIN_VERSION_ghc(8,8,0)+import Panic hiding (try)+import qualified PlainPanic as Plain+#else+import Panic hiding (GhcException, try)+import qualified Panic as Plain+#endif+import Parser+import PatSyn+#if MIN_VERSION_ghc(8,8,0)+import Plugins+#endif+import PprTyThing hiding (pprFamInst)+import PrelInfo+import PrelNames hiding (Unique, printName)+import RdrName+import RnNames+import RnSplice+import qualified SrcLoc+import TcEnv+import TcEvidence hiding ((<.>))+import TcIface+import TcRnDriver+import TcRnMonad hiding (Applicative (..), IORef,+ MonadFix (..), MonadIO (..), allM,+ anyM, concatMapM, foldrM,+ mapMaybeM, (<$>))+import TcRnTypes+import TcType hiding (mkVisFunTys)+import qualified TcType+import TidyPgm+import qualified TyCoRep+import TyCon+import Type hiding (mkVisFunTys)+import TysPrim+import TysWiredIn+import Unify+import UniqSupply+import Var (Var (varName), setTyVarUnique,+ setVarUnique, varType)++#if MIN_VERSION_ghc(8,10,0)+import Coercion (coercionKind)+import Predicate+import SrcLoc (SrcSpan (UnhelpfulSpan), SrcLoc (UnhelpfulLoc))+#else+import SrcLoc (RealLocated,+ SrcSpan (UnhelpfulSpan),+ SrcLoc (UnhelpfulLoc))+#endif+#endif++#if !MIN_VERSION_ghc(8,8,0)+import Data.List (isSuffixOf)+import System.FilePath+#endif++#if !MIN_VERSION_ghc(9,0,0)+type BufSpan = ()+type BufPos = ()+#endif++pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan+#if 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+ RealSrcSpan x _ = SrcLoc.RealSrcSpan x+#endif+{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}++pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc+#if MIN_VERSION_ghc(9,0,0)+pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y+#else+pattern RealSrcLoc x y <- ((,Nothing) -> (SrcLoc.RealSrcLoc x, y)) where+ RealSrcLoc x _ = SrcLoc.RealSrcLoc x+#endif+{-# COMPLETE RealSrcLoc, UnhelpfulLoc #-}+++pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo+#if __GLASGOW_HASKELL__ >= 902+pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of+ Avail.NormalGreName name -> (name: names, pieces)+ Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces))+#else+pattern AvailTC n names pieces <- Avail.AvailTC n names pieces+#endif++pattern AvailName :: Name -> Avail.AvailInfo+#if __GLASGOW_HASKELL__ >= 902+pattern AvailName n <- Avail.Avail (Avail.NormalGreName n)+#else+pattern AvailName n <- Avail.Avail n+#endif++pattern AvailFL :: FieldLabel -> Avail.AvailInfo+#if __GLASGOW_HASKELL__ >= 902+pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl)+#else+-- pattern synonym that is never populated+pattern AvailFL x <- Avail.Avail (const (True, undefined) -> (False, x))+#endif++{-# COMPLETE AvailTC, AvailName, AvailFL #-}++setImportPaths :: [FilePath] -> DynFlags -> DynFlags+setImportPaths importPaths flags = flags { importPaths = importPaths }++pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag+-- https://github.com/facebook/fbghc+#ifdef __FACEBOOK_HASKELL__+pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr+#else+pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr+#endif++pattern FunTy :: Type -> Type -> Type+#if MIN_VERSION_ghc(8,10,0)+pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res}+#else+pattern FunTy arg res <- TyCoRep.FunTy arg res+#endif++#if MIN_VERSION_ghc(9,0,0)+-- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x)+-- type HasSrcSpan x = () :: Constraint++class HasSrcSpan a where+ getLoc :: a -> SrcSpan++instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where+ getLoc = GHC.getLoc++-- getLoc :: GenLocated l a -> l+-- getLoc = GHC.getLoc++#elif MIN_VERSION_ghc(8,8,0)+type HasSrcSpan = SrcLoc.HasSrcSpan+getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan+getLoc = SrcLoc.getLoc++#else++class HasSrcSpan a where+ getLoc :: a -> SrcSpan+instance HasSrcSpan Name where+ getLoc = nameSrcSpan+instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where+ getLoc = SrcLoc.getLoc++#endif++getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan+#if !MIN_VERSION_ghc(8,8,0)+getRealSrcSpan = SrcLoc.getLoc+#else+getRealSrcSpan = SrcLoc.getRealSrcSpan+#endif+++-- | Add the @-boot@ suffix to all output file paths associated with the+-- module, not including the input file itself+addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation+#if !MIN_VERSION_ghc(8,8,0)+addBootSuffixLocnOut locn+ = locn { Module.ml_hi_file = Module.addBootSuffix (Module.ml_hi_file locn)+ , Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn)+ }+#else+addBootSuffixLocnOut = Module.addBootSuffixLocnOut+#endif+++dataConExTyCoVars :: DataCon -> [TyCoVar]+#if __GLASGOW_HASKELL__ >= 808+dataConExTyCoVars = DataCon.dataConExTyCoVars+#else+dataConExTyCoVars = DataCon.dataConExTyVars+#endif++#if !MIN_VERSION_ghc(9,0,0)+-- Linear Haskell+type Scaled a = a+scaledThing :: Scaled a -> a+scaledThing = id+#endif++mkVisFunTys :: [Scaled Type] -> Type -> Type+mkVisFunTys =+#if __GLASGOW_HASKELL__ <= 808+ mkFunTys+#else+ TcType.mkVisFunTys+#endif++mkInfForAllTys :: [TyVar] -> Type -> Type+mkInfForAllTys =+#if MIN_VERSION_ghc(9,0,0)+ TcType.mkInfForAllTys+#else+ mkInvForAllTys+#endif++splitForAllTyCoVars :: Type -> ([TyCoVar], Type)+splitForAllTyCoVars =+#if MIN_VERSION_ghc(9,2,0)+ TcType.splitForAllTyCoVars+#else+ splitForAllTys+#endif++tcSplitForAllTyVars :: Type -> ([TyVar], Type)+tcSplitForAllTyVars =+#if MIN_VERSION_ghc(9,2,0)+ TcType.tcSplitForAllTyVars+#else+ tcSplitForAllTys+#endif+++tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)+tcSplitForAllTyVarBinder_maybe =+#if MIN_VERSION_ghc(9,2,0)+ TcType.tcSplitForAllTyVarBinder_maybe+#else+ 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+noExtField = GHC.noExt+#endif++ml_hie_file :: GHC.ModLocation -> FilePath+#if !MIN_VERSION_ghc(8,8,0)+ml_hie_file ml+ | "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot"+ | otherwise = Module.ml_hi_file ml -<.> ".hie"+#else+ml_hie_file = Module.ml_hie_file+#endif++#if !MIN_VERSION_ghc(9,0,0)+pattern NotBoot, IsBoot :: IsBootInterface+pattern NotBoot = False+pattern IsBoot = True+#endif++#if MIN_VERSION_ghc(8,8,0)+type PlainGhcException = Plain.PlainGhcException+#else+type PlainGhcException = Plain.GhcException+#endif
+ src/Development/IDE/GHC/Compat/Env.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE CPP #-}++-- | 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),+ InteractiveContext(..),+ setInteractivePrintName,+ setInteractiveDynFlags,+ Env.hsc_dflags,+ hsc_EPS,+ hsc_logger,+ hsc_tmpfs,+ hsc_unit_env,+ hsc_hooks,+ hscSetHooks,+ TmpFs,+ -- * HomeUnit+ hscHomeUnit,+ HomeUnit,+ setHomeUnitId_,+ Development.IDE.GHC.Compat.Env.mkHomeModule,+ -- * Provide backwards Compatible+ -- types and helper functions.+ Logger(..),+ UnitEnv,+ hscSetUnitEnv,+ hscSetFlags,+ initTempFs,+ -- * Home Unit+ Development.IDE.GHC.Compat.Env.homeUnitId_,+ -- * DynFlags Helper+ setBytecodeLinkerOptions,+ setInterpreterLinkerOptions,+ -- * Ways+ Ways,+ Way,+ hostFullWays,+ setWays,+ wayGeneralFlags,+ wayUnsetGeneralFlags,+ -- * Backend, backwards compatible+ Backend,+ setBackend,+ Development.IDE.GHC.Compat.Env.platformDefaultBackend,+ ) where++import GHC (setInteractiveDynFlags)++#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Backend as Backend+import GHC.Driver.Env (HscEnv, hsc_EPS)+import qualified GHC.Driver.Env as Env+import qualified GHC.Driver.Session as Session+import GHC.Platform.Ways hiding (hostFullWays)+import qualified GHC.Platform.Ways as Ways+import GHC.Runtime.Context+import GHC.Unit.Env (UnitEnv)+import GHC.Unit.Home as Home+import GHC.Utils.Logger+import GHC.Utils.TmpFs+#else+import qualified GHC.Driver.Session as DynFlags+import GHC.Driver.Types (HscEnv, InteractiveContext (..), hsc_EPS,+ setInteractivePrintName)+import qualified GHC.Driver.Types as Env+import GHC.Driver.Ways hiding (hostFullWays)+import qualified GHC.Driver.Ways as Ways+#endif+import GHC.Driver.Hooks (Hooks)+import GHC.Driver.Session hiding (mkHomeModule)+import GHC.Unit.Module.Name+import GHC.Unit.Types (Module, Unit, UnitId, mkModule)+#else+import DynFlags+import Hooks+import HscTypes as Env+import Module+#endif++#if MIN_VERSION_ghc(9,0,0)+import qualified Data.Set as Set+#endif+#if !MIN_VERSION_ghc(9,2,0)+import Data.IORef+#endif++#if !MIN_VERSION_ghc(9,2,0)+type UnitEnv = ()+newtype Logger = Logger { log_action :: LogAction }+type TmpFs = ()+#endif++setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags+#if MIN_VERSION_ghc(9,2,0)+setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid }+#elif MIN_VERSION_ghc(9,0,0)+setHomeUnitId_ uid df = df { homeUnitId = uid }+#else+setHomeUnitId_ uid df = df { thisInstalledUnitId = toInstalledUnitId uid }+#endif++hscSetFlags :: DynFlags -> HscEnv -> HscEnv+hscSetFlags df env =+#if MIN_VERSION_ghc(9,2,0)+ hscSetFlags df env+#else+ env { Env.hsc_dflags = df }+#endif++initTempFs :: HscEnv -> IO HscEnv+initTempFs env = do+#if MIN_VERSION_ghc(9,2,0)+ tmpFs <- initTmpFs+ pure env { Env.hsc_tmpfs = tmpFs }+#else+ filesToClean <- newIORef emptyFilesToClean+ dirsToClean <- newIORef mempty+ let dflags = (Env.hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}+ pure $ hscSetFlags dflags env+#endif++hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv+#if MIN_VERSION_ghc(9,2,0)+hscSetUnitEnv ue env = env { Env.hsc_unit_env = ue }+#else+hscSetUnitEnv _ env = env+#endif++hsc_unit_env :: HscEnv -> UnitEnv+hsc_unit_env =+#if MIN_VERSION_ghc(9,2,0)+ Env.hsc_unit_env+#else+ const ()+#endif++hsc_tmpfs :: HscEnv -> TmpFs+hsc_tmpfs =+#if MIN_VERSION_ghc(9,2,0)+ Env.hsc_tmpfs+#else+ const ()+#endif++hsc_logger :: HscEnv -> Logger+hsc_logger =+#if MIN_VERSION_ghc(9,2,0)+ Env.hsc_logger+#else+ Logger . DynFlags.log_action . Env.hsc_dflags+#endif++hsc_hooks :: HscEnv -> Hooks+hsc_hooks =+#if MIN_VERSION_ghc(9,2,0)+ Env.hsc_hooks+#else+ hooks . Env.hsc_dflags+#endif++hscSetHooks :: Hooks -> HscEnv -> HscEnv+hscSetHooks hooks env =+#if MIN_VERSION_ghc(9,2,0)+ env { Env.hsc_hooks = hooks }+#else+ hscSetFlags ((Env.hsc_dflags env) { hooks = hooks}) env+#endif++homeUnitId_ :: DynFlags -> UnitId+homeUnitId_ =+#if MIN_VERSION_ghc(9,2,0)+ Session.homeUnitId_+#elif MIN_VERSION_ghc(9,0,0)+ homeUnitId+#else+ thisPackage+#endif+++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+type HomeUnit = Unit+#elif !MIN_VERSION_ghc(9,0,0)+type HomeUnit = UnitId+#endif++hscHomeUnit :: HscEnv -> HomeUnit+hscHomeUnit =+#if MIN_VERSION_ghc(9,2,0)+ Env.hsc_home_unit+#elif MIN_VERSION_ghc(9,0,0)+ homeUnit . Env.hsc_dflags+#else+ homeUnitId_ . hsc_dflags+#endif++mkHomeModule :: HomeUnit -> ModuleName -> Module+mkHomeModule =+#if MIN_VERSION_ghc(9,2,0)+ Home.mkHomeModule+#else+ mkModule+#endif++-- | We don't want to generate object code so we compile to bytecode+-- (HscInterpreted) which implies LinkInMemory+-- HscInterpreted+setBytecodeLinkerOptions :: DynFlags -> DynFlags+setBytecodeLinkerOptions df = df {+ ghcLink = LinkInMemory+#if MIN_VERSION_ghc(9,2,0)+ , backend = NoBackend+#else+ , hscTarget = HscNothing+#endif+ , ghcMode = CompManager+ }++setInterpreterLinkerOptions :: DynFlags -> DynFlags+setInterpreterLinkerOptions df = df {+ ghcLink = LinkInMemory+#if MIN_VERSION_ghc(9,2,0)+ , backend = Interpreter+#else+ , hscTarget = HscInterpreted+#endif+ , ghcMode = CompManager+ }++-- -------------------------------------------------------+-- Ways helpers+-- -------------------------------------------------------++#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,0)+type Ways = Set.Set Way+#elif !MIN_VERSION_ghc(9,0,0)+type Ways = [Way]+#endif++hostFullWays :: Ways+hostFullWays =+#if MIN_VERSION_ghc(9,0,0)+ Ways.hostFullWays+#else+ interpWays+#endif++setWays :: Ways -> DynFlags -> DynFlags+setWays ways flags =+#if MIN_VERSION_ghc(9,2,0)+ flags { Session.targetWays_ = ways}+#elif MIN_VERSION_ghc(9,0,0)+ flags {ways = ways}+#else+ updateWays $ flags {ways = ways}+#endif++-- -------------------------------------------------------+-- Backend helpers+-- -------------------------------------------------------++#if !MIN_VERSION_ghc(9,2,0)+type Backend = HscTarget+#endif++platformDefaultBackend :: DynFlags -> Backend+platformDefaultBackend =+#if MIN_VERSION_ghc(9,2,0)+ Backend.platformDefaultBackend . targetPlatform+#elif MIN_VERSION_ghc(8,10,0)+ defaultObjectTarget+#else+ defaultObjectTarget . DynFlags.targetPlatform+#endif++setBackend :: Backend -> DynFlags -> DynFlags+setBackend backend flags =+#if MIN_VERSION_ghc(9,2,0)+ flags { backend = backend }+#else+ flags { hscTarget = backend }+#endif+
+ src/Development/IDE/GHC/Compat/Iface.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}++-- | Compat module Interface file relevant code.+module Development.IDE.GHC.Compat.Iface (+ writeIfaceFile,+ cannotFindModule,+ ) where++import GHC+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Iface.Load as Iface+import GHC.Unit.Finder.Types (FindResult)+#elif MIN_VERSION_ghc(9,0,0)+import qualified GHC.Driver.Finder as Finder+import GHC.Driver.Types (FindResult)+import qualified GHC.Iface.Load as Iface+#else+import Finder (FindResult)+import qualified Finder+import qualified MkIface+#endif++import Development.IDE.GHC.Compat.Env+import Development.IDE.GHC.Compat.Outputable++writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO ()+#if 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)+#else+writeIfaceFile env = MkIface.writeIfaceFile (hsc_dflags env)+#endif++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule env modname fr =+#if MIN_VERSION_ghc(9,2,0)+ Iface.cannotFindModule env modname fr+#else+ Finder.cannotFindModule (hsc_dflags env) modname fr+#endif
+ src/Development/IDE/GHC/Compat/Logger.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+-- | Compat module for GHC 9.2 Logger infrastructure.+module Development.IDE.GHC.Compat.Logger (+ putLogHook,+ Development.IDE.GHC.Compat.Logger.pushLogHook,+ -- * Logging stuff+ LogActionCompat,+ logActionCompat,+ defaultLogActionHPutStrDoc,+ ) where++import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env as Env+import Development.IDE.GHC.Compat.Outputable++#if MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Session as DynFlags+import GHC.Utils.Outputable+#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Env (hsc_logger)+import GHC.Utils.Logger as Logger+#endif+#else+import DynFlags+import Outputable (queryQual)+#endif++putLogHook :: Logger -> HscEnv -> HscEnv+putLogHook logger env =+#if MIN_VERSION_ghc(9,2,0)+ env { hsc_logger = logger }+#else+ hscSetFlags ((hsc_dflags env) { DynFlags.log_action = Env.log_action logger }) env+#endif++pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger+pushLogHook f logger =+#if MIN_VERSION_ghc(9,2,0)+ Logger.pushLogHook f logger+#else+ logger { Env.log_action = f (Env.log_action logger) }+#endif++#if MIN_VERSION_ghc(9,0,0)+type LogActionCompat = DynFlags -> WarnReason -> 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 dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify++#else+type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO ()++logActionCompat :: LogActionCompat -> LogAction+logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style)+#endif
+ src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}++module Development.IDE.GHC.Compat.Outputable (+ SDoc,+ Outputable,+ showSDoc,+ showSDocUnsafe,+ showSDocForUser,+ ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest,+ printSDocQualifiedUnsafe,+ printNameWithoutUniques,+ printSDocAllTheWay,+ mkPrintUnqualified,+ mkPrintUnqualifiedDefault,+ PrintUnqualified(..),+ -- * Parser errors+ PsWarning,+ PsError,+ pprWarning,+ pprError,+ -- * Error infrastructure+ DecoratedSDoc,+ MsgEnvelope,+ errMsgSpan,+ errMsgSeverity,+ formatErrorWithQual,+ mkWarnMsg,+ mkSrcErr,+ srcErrorMessages,+ ) where+++#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Parser.Errors+import qualified GHC.Parser.Errors.Ppr as Ppr+import qualified GHC.Types.Error as Error+import GHC.Types.Name.Ppr+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Unit.State+import GHC.Utils.Error hiding (mkWarnMsg)+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Panic+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Session+import GHC.Driver.Types as HscTypes+import GHC.Types.Name.Reader (GlobalRdrEnv)+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+#else+import Development.IDE.GHC.Compat.Core (GlobalRdrEnv)+import DynFlags+import ErrUtils hiding (mkWarnMsg)+import qualified ErrUtils as Err+import HscTypes+import Outputable as Out+import SrcLoc+#endif++printNameWithoutUniques :: Outputable a => a -> String+printNameWithoutUniques =+#if MIN_VERSION_ghc(9,2,0)+ renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) . ppr+#else+ printSDocAllTheWay dyn . ppr+ where+ dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques+#endif++printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String+#if MIN_VERSION_ghc(9,2,0)+printSDocQualifiedUnsafe unqual doc =+ -- Taken from 'showSDocForUser'+ renderWithContext (defaultSDocContext { sdocStyle = sty }) doc'+ where+ sty = mkUserStyle unqual AllTheWay+ doc' = pprWithUnitState emptyUnitState doc+#else+printSDocQualifiedUnsafe unqual doc =+ showSDocForUser unsafeGlobalDynFlags unqual doc+#endif++printSDocAllTheWay :: DynFlags -> SDoc -> String+#if MIN_VERSION_ghc(9,2,0)+printSDocAllTheWay dflags sdoc = renderWithContext ctxt sdoc+ where+ ctxt = initSDocContext dflags (mkUserStyle neverQualify AllTheWay)+#else+printSDocAllTheWay dflags sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags Out.neverQualify Out.AllTheWay)++#if MIN_VERSION_ghc(9,0,0)+oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc+oldMkUserStyle _ = Out.mkUserStyle+oldMkErrStyle _ = Out.mkErrStyle++oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc+oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext+ where dummySDocContext = initSDocContext dflags Out.defaultUserStyle++#else+oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String+oldRenderWithStyle = Out.renderWithStyle++oldMkUserStyle :: DynFlags -> Out.PrintUnqualified -> Out.Depth -> Out.PprStyle+oldMkUserStyle = Out.mkUserStyle++oldMkErrStyle :: DynFlags -> Out.PrintUnqualified -> Out.PprStyle+oldMkErrStyle = Out.mkErrStyle++oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc+oldFormatErrDoc = Err.formatErrDoc+#endif+#endif++pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc+pprWarning =+#if MIN_VERSION_ghc(9,2,0)+ Ppr.pprWarning+#else+ id+#endif++pprError :: PsError -> MsgEnvelope DecoratedSDoc+pprError =+#if MIN_VERSION_ghc(9,2,0)+ Ppr.pprError+#else+ id+#endif++formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String+formatErrorWithQual dflags e =+#if MIN_VERSION_ghc(9,2,0)+ showSDoc dflags (pprLocMsgEnvelope e)+#else+ Out.showSDoc dflags+ $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e)+ $ oldFormatErrDoc dflags+ $ Err.errMsgDoc e+#endif++#if !MIN_VERSION_ghc(9,2,0)+type DecoratedSDoc = ()+type MsgEnvelope e = ErrMsg++type PsWarning = ErrMsg+type PsError = ErrMsg+#endif++mkPrintUnqualifiedDefault :: GlobalRdrEnv -> PrintUnqualified+mkPrintUnqualifiedDefault =+ HscTypes.mkPrintUnqualified unsafeGlobalDynFlags++mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc+mkWarnMsg =+#if MIN_VERSION_ghc(9,2,0)+ const Error.mkWarnMsg+#else+ Err.mkWarnMsg+#endif
+ src/Development/IDE/GHC/Compat/Parser.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}++-- | Parser compaibility module.+module Development.IDE.GHC.Compat.Parser (+ initParserOpts,+ initParserState,+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+ -- in GHC == 9.2 the type doesn't exist+ -- In GHC == 9.0 it is a data-type+ -- and GHC < 9.0 it is type-def+ --+ -- Export data-type here, otherwise only the simple type.+ Anno.ApiAnns(..),+#else+ ApiAnns,+#endif+ mkHsParsedModule,+ mkParsedModule,+ mkApiAnns,+ -- * API Annotations+ Anno.AnnKeywordId(..),+ Anno.AnnotationComment(..),+ ) where++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Parser.Lexer as Lexer+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Driver.Config as Config+import GHC.Parser.Lexer hiding (initParserState)+#else+import qualified GHC.Parser.Annotation as Anno+#endif+#else+import qualified ApiAnnotation as Anno+import Lexer+import qualified SrcLoc+#endif+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Util++#if !MIN_VERSION_ghc(9,2,0)+import qualified Data.Map as Map+#endif++#if !MIN_VERSION_ghc(9,0,0)+type ParserOpts = DynFlags+#elif !MIN_VERSION_ghc(9,2,0)+type ParserOpts = Lexer.ParserFlags+#endif++initParserOpts :: DynFlags -> ParserOpts+initParserOpts =+#if MIN_VERSION_ghc(9,2,0)+ Config.initParserOpts+#elif MIN_VERSION_ghc(9,0,0)+ Lexer.mkParserFlags+#else+ id+#endif++initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initParserState =+#if MIN_VERSION_ghc(9,2,0)+ Lexer.initParserState+#elif MIN_VERSION_ghc(9,0,0)+ Lexer.mkPStatePure+#else+ Lexer.mkPState+#endif++#if MIN_VERSION_ghc(9,2,0)+type ApiAnns = ()+#else+type ApiAnns = Anno.ApiAnns+#endif+++mkHsParsedModule :: ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule+mkHsParsedModule parsed fps hpm_annotations =+ HsParsedModule+ parsed+ fps+#if !MIN_VERSION_ghc(9,2,0)+ hpm_annotations+#endif+++mkParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule+mkParsedModule ms parsed extra_src_files _hpm_annotations =+ ParsedModule {+ pm_mod_summary = ms+ , pm_parsed_source = parsed+ , pm_extra_src_files = extra_src_files+#if !MIN_VERSION_ghc(9,2,0)+ , pm_annotations = _hpm_annotations+#endif+ }++mkApiAnns :: PState -> ApiAnns+#if MIN_VERSION_ghc(9,2,0)+mkApiAnns = const ()+#else+mkApiAnns pst =+#if MIN_VERSION_ghc(9,0,1)+ -- Copied from GHC.Driver.Main+ Anno.ApiAnns {+ apiAnnItems = Map.fromListWith (++) $ annotations pst,+ apiAnnEofPos = eof_pos pst,+ apiAnnComments = Map.fromList (annotations_comments pst),+ apiAnnRogueComments = comment_q pst+ }+#else+ (Map.fromListWith (++) $ annotations pst,+ Map.fromList ((SrcLoc.noSrcSpan,comment_q pst)+ :annotations_comments pst))+#endif+#endif
+ src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}++-- | Plugin Compat utils.+module Development.IDE.GHC.Compat.Plugins (+ Plugin(..),+ defaultPlugin,+#if __GLASGOW_HASKELL__ >= 808+ PluginWithArgs(..),+#endif+ applyPluginsParsedResultAction,+ initializePlugins,++ -- * Static plugins+#if MIN_VERSION_ghc(8,8,0)+ StaticPlugin(..),+ hsc_static_plugins,+#endif+ ) where++import GHC+#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Driver.Env as Env+#endif+import GHC.Driver.Plugins (Plugin (..),+ PluginWithArgs (..),+ StaticPlugin (..),+ defaultPlugin, withPlugins)+import qualified GHC.Runtime.Loader as Loader+#elif MIN_VERSION_ghc(8,8,0)+import qualified DynamicLoading as Loader+import Plugins+#else+import qualified DynamicLoading as Loader+import Plugins (Plugin (..), defaultPlugin,+ withPlugins)+#endif+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags)+import Development.IDE.GHC.Compat.Parser as Parser++applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource+applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do+ -- Apply parsedResultAction of plugins+ let applyPluginAction p opts = parsedResultAction p opts ms+ fmap hpm_module $+ runHsc env $ withPlugins+#if MIN_VERSION_ghc(9,2,0)+ env+#else+ dflags+#endif+ applyPluginAction+ (mkHsParsedModule parsed [] hpm_annotations)++initializePlugins :: HscEnv -> IO HscEnv+initializePlugins env = do+#if MIN_VERSION_ghc(9,2,0)+ Loader.initializePlugins env+#else+ newDf <- Loader.initializePlugins env (hsc_dflags env)+ pure $ hscSetFlags newDf env+#endif+++#if MIN_VERSION_ghc(8,8,0)+hsc_static_plugins :: HscEnv -> [StaticPlugin]+#if MIN_VERSION_ghc(9,2,0)+hsc_static_plugins = Env.hsc_static_plugins+#else+hsc_static_plugins = staticPlugins . hsc_dflags+#endif+#endif
+ src/Development/IDE/GHC/Compat/Units.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Compat module for 'UnitState' and 'UnitInfo'.+module Development.IDE.GHC.Compat.Units (+ -- * UnitState+ UnitState,+ initUnits,+ unitState,+ getUnitName,+ explicitUnits,+ preloadClosureUs,+ listVisibleModuleNames,+ LookupResult(..),+ lookupModuleWithSuggestions,+ -- * UnitInfoMap+ UnitInfoMap,+ getUnitInfoMap,+ lookupUnit,+ lookupUnit',+ -- * UnitInfo+ UnitInfo,+ unitExposedModules,+ unitDepends,+ unitHaddockInterfaces,+ unitInfoId,+ unitPackageNameString,+ unitPackageVersion,+ -- * UnitId helpers+ UnitId,+ Unit,+ unitString,+ stringToUnit,+#if !MIN_VERSION_ghc(9,0,0)+ pattern RealUnit,+#endif+ definiteUnitId,+ defUnitId,+ installedModule,+ -- * Module+ toUnitId,+ moduleUnitId,+ moduleUnit,+ -- * ExternalPackageState+ ExternalPackageState(..),+ -- * Utils+ filterInplaceUnits,+ FinderCache,+ ) where++#if MIN_VERSION_ghc(9,0,0)+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Data.ShortText as ST+import GHC.Driver.Env (hsc_unit_dbs)+import GHC.Unit.Env+import GHC.Unit.External+import GHC.Unit.Finder+#else+import GHC.Driver.Types+#endif+import GHC.Data.FastString+import qualified GHC.Driver.Session as DynFlags+import GHC.Types.Unique.Set+import qualified GHC.Unit.Info as UnitInfo+import GHC.Unit.State (LookupResult, UnitInfo,+ UnitState (unitInfoMap))+import qualified GHC.Unit.State as State+import GHC.Unit.Types hiding (moduleUnit, toUnitId)+import qualified GHC.Unit.Types as Unit+#else+import qualified DynFlags+import FastString+import HscTypes+import Module hiding (moduleUnitId)+import qualified Module+import Packages (InstalledPackageInfo (haddockInterfaces, packageName),+ LookupResult, PackageConfig,+ PackageConfigMap,+ PackageState,+ getPackageConfigMap,+ lookupPackage')+import qualified Packages+#endif++import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import Data.Map (Map)+#endif+import Data.Either+import Data.Version++#if MIN_VERSION_ghc(9,0,0)+type PreloadUnitClosure = UniqSet UnitId+#if MIN_VERSION_ghc(9,2,0)+type UnitInfoMap = State.UnitInfoMap+#else+type UnitInfoMap = Map UnitId UnitInfo+#endif+#else+type UnitState = PackageState+type UnitInfo = PackageConfig+type UnitInfoMap = PackageConfigMap+type PreloadUnitClosure = ()+type Unit = UnitId+#endif+++#if !MIN_VERSION_ghc(9,0,0)+unitString :: Unit -> String+unitString = Module.unitIdString++stringToUnit :: String -> Unit+stringToUnit = Module.stringToUnitId+#endif++unitState :: HscEnv -> UnitState+#if MIN_VERSION_ghc(9,2,0)+unitState = ue_units . hsc_unit_env+#elif MIN_VERSION_ghc(9,0,0)+unitState = DynFlags.unitState . hsc_dflags+#else+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++ dflags <- updatePlatformConstants dflags1 mconstants+++ let unit_env = UnitEnv+ { ue_platform = targetPlatform dflags+ , ue_namever = ghcNameVersion dflags+ , ue_home_unit = home_unit+ , ue_units = unit_state+ }+ pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env+ { hsc_unit_dbs = Just dbs+ }+#elif MIN_VERSION_ghc(9,0,0)+ newFlags <- State.initUnits $ hsc_dflags env+ pure $ hscSetFlags newFlags env+#else+ newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env+ pure $ hscSetFlags newFlags env+#endif++explicitUnits :: UnitState -> [Unit]+explicitUnits ue =+#if MIN_VERSION_ghc(9,0,0)+ State.explicitUnits ue+#else+ Packages.explicitPackages ue+#endif++listVisibleModuleNames :: HscEnv -> [ModuleName]+listVisibleModuleNames env =+#if MIN_VERSION_ghc(9,0,0)+ State.listVisibleModuleNames $ unitState env+#else+ Packages.listVisibleModuleNames $ hsc_dflags env+#endif++getUnitName :: HscEnv -> UnitId -> Maybe PackageName+getUnitName env i =+#if MIN_VERSION_ghc(9,0,0)+ State.unitPackageName <$> State.lookupUnitId (unitState env) i+#else+ packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i))+#endif++lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult+lookupModuleWithSuggestions env modname mpkg =+#if MIN_VERSION_ghc(9,0,0)+ State.lookupModuleWithSuggestions (unitState env) modname mpkg+#else+ Packages.lookupModuleWithSuggestions (hsc_dflags env) modname mpkg+#endif++getUnitInfoMap :: HscEnv -> UnitInfoMap+getUnitInfoMap =+#if MIN_VERSION_ghc(9,2,0)+ unitInfoMap . ue_units . hsc_unit_env+#elif MIN_VERSION_ghc(9,0,0)+ unitInfoMap . unitState+#else+ Packages.getPackageConfigMap . hsc_dflags+#endif++lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo+#if MIN_VERSION_ghc(9,0,0)+lookupUnit env pid = State.lookupUnit (unitState env) pid+#else+lookupUnit env pid = Packages.lookupPackage (hsc_dflags env) pid+#endif++lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo+#if MIN_VERSION_ghc(9,0,0)+lookupUnit' = State.lookupUnit'+#else+lookupUnit' b pcm _ u = Packages.lookupPackage' b pcm u+#endif++preloadClosureUs :: HscEnv -> PreloadUnitClosure+#if MIN_VERSION_ghc(9,2,0)+preloadClosureUs = State.preloadClosure . unitState+#elif MIN_VERSION_ghc(9,0,0)+preloadClosureUs = State.preloadClosure . unitState+#else+preloadClosureUs = const ()+#endif++unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)]+unitExposedModules ue =+#if MIN_VERSION_ghc(9,0,0)+ UnitInfo.unitExposedModules ue+#else+ Packages.exposedModules ue+#endif++unitDepends :: UnitInfo -> [UnitId]+#if MIN_VERSION_ghc(9,0,0)+unitDepends = State.unitDepends+#else+unitDepends = fmap (Module.DefiniteUnitId. defUnitId') . Packages.depends+#endif++unitPackageNameString :: UnitInfo -> String+unitPackageNameString =+#if MIN_VERSION_ghc(9,0,0)+ UnitInfo.unitPackageNameString+#else+ Packages.packageNameString+#endif++unitPackageVersion :: UnitInfo -> Version+unitPackageVersion =+#if MIN_VERSION_ghc(9,0,0)+ UnitInfo.unitPackageVersion+#else+ Packages.packageVersion+#endif++unitInfoId :: UnitInfo -> Unit+unitInfoId =+#if MIN_VERSION_ghc(9,0,0)+ UnitInfo.mkUnit+#else+ Packages.packageConfigId+#endif++unitHaddockInterfaces :: UnitInfo -> [FilePath]+unitHaddockInterfaces =+#if MIN_VERSION_ghc(9,2,0)+ fmap ST.unpack . UnitInfo.unitHaddockInterfaces+#elif MIN_VERSION_ghc(9,0,0)+ UnitInfo.unitHaddockInterfaces+#else+ haddockInterfaces+#endif++-- ------------------------------------------------------------------+-- Backwards Compatible UnitState+-- ------------------------------------------------------------------++-- ------------------------------------------------------------------+-- Patterns and helpful definitions+-- ------------------------------------------------------------------++#if MIN_VERSION_ghc(9,2,0)+definiteUnitId = RealUnit+defUnitId = Definite+installedModule = Module++#elif MIN_VERSION_ghc(9,0,0)+definiteUnitId = RealUnit+defUnitId = Definite+installedModule = Module++#else+pattern RealUnit :: Module.DefUnitId -> UnitId+pattern RealUnit x = Module.DefiniteUnitId x++definiteUnitId :: Module.DefUnitId -> UnitId+definiteUnitId = Module.DefiniteUnitId++defUnitId :: UnitId -> Module.DefUnitId+defUnitId = Module.DefUnitId . Module.toInstalledUnitId++defUnitId' :: Module.InstalledUnitId -> Module.DefUnitId+defUnitId' = Module.DefUnitId++installedModule :: UnitId -> ModuleName -> Module.InstalledModule+installedModule uid modname = Module.InstalledModule (Module.toInstalledUnitId uid) modname+#endif++toUnitId :: Unit -> UnitId+toUnitId =+#if MIN_VERSION_ghc(9,0,0)+ Unit.toUnitId+#else+ id+#endif++moduleUnitId :: Module -> UnitId+moduleUnitId =+#if MIN_VERSION_ghc(9,0,0)+ Unit.toUnitId . Unit.moduleUnit+#else+ Module.moduleUnitId+#endif++moduleUnit :: Module -> Unit+moduleUnit =+#if MIN_VERSION_ghc(9,0,0)+ Unit.moduleUnit+#else+ Module.moduleUnitId+#endif++filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag])+filterInplaceUnits us packageFlags =+ partitionEithers (map isInplace packageFlags)+ where+ isInplace :: PackageFlag -> Either UnitId PackageFlag+ isInplace p@(ExposePackage _ (UnitIdArg u) _) =+#if MIN_VERSION_ghc(9,0,0)+ if toUnitId u `elem` us+ then Left $ toUnitId u+ else Right p+#else+ if u `elem` us+ then Left u+ else Right p+#endif+ isInplace p = Right p
+ src/Development/IDE/GHC/Compat/Util.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+-- | GHC Utils and Datastructures re-exports.+--+-- Mainly handles module hierarchy re-organisation of GHC+-- from version < 9.0 to >= 9.0.+--+-- Some Functions, such as 'toList' shadow other function-names.+-- This way this module can be imported qualified more naturally.+module Development.IDE.GHC.Compat.Util (+ -- * Exception handling+ MonadCatch,+ GhcException,+ handleGhcException,+ catch,+ try,+ -- * Bags+ Bag,+ bagToList,+ listToBag,+ unionBags,+ isEmptyBag,+ -- * Boolean Formula+ LBooleanFormula,+ BooleanFormula(..),+ -- * OverridingBool+ OverridingBool(..),+ -- * Maybes+ MaybeErr(..),+ orElse,+#if MIN_VERSION_ghc(8,10,0)+ -- * Pair+ Pair(..),+#endif+ -- * EnumSet+ EnumSet,+ toList,+ -- * FastString exports+ FastString,+#if MIN_VERSION_ghc(9,2,0)+ -- Export here, so we can coerce safely on consumer sites+ LexicalFastString(..),+#endif+ uniq,+ unpackFS,+ mkFastString,+ fsLit,+ pprHsString,+ -- * Fingerprint+ Fingerprint(..),+ getFileHash,+ fingerprintData,+ fingerprintString,+ fingerprintFingerprints,+ -- * Unique+ Uniquable,+ nonDetCmpUnique,+ getUnique,+ Unique,+ mkUnique,+ newTagUnique,+ -- * UniqDFM+ emptyUDFM,+ plusUDFM,+ -- * String Buffer+ StringBuffer(..),+ hGetStringBuffer,+ stringToStringBuffer,+ ) where++#if MIN_VERSION_ghc(9,0,0)+import Control.Exception.Safe (MonadCatch, catch, try)+import GHC.Data.Bag+import GHC.Data.BooleanFormula+import GHC.Data.EnumSet++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.Pair+import GHC.Data.StringBuffer+import GHC.Types.Unique+import GHC.Types.Unique.DFM+import GHC.Utils.Fingerprint+import GHC.Utils.Misc+import GHC.Utils.Outputable (pprHsString)+import GHC.Utils.Panic hiding (try)+#else+import Bag+import BooleanFormula+import EnumSet+import qualified Exception+import FastString+import Fingerprint+import Maybes+#if MIN_VERSION_ghc(8,10,0)+import Pair+#endif+import Outputable (pprHsString)+import Panic hiding (try)+import StringBuffer+import UniqDFM+import Unique+import Util+#endif++#if !MIN_VERSION_ghc(9,0,0)+type MonadCatch = Exception.ExceptionMonad++-- We are using Safe here, which is not equivalent, but probably what we want.+catch :: (Exception.ExceptionMonad m, Exception e) => m a -> (e -> m a) -> m a+catch = Exception.gcatch++try :: (Exception.ExceptionMonad m, Exception e) => m a -> m (Either e a)+try = Exception.gtry+#endif
src/Development/IDE/GHC/Error.hs view
@@ -29,24 +29,21 @@ , toDSeverity ) where -import Bag import Data.Maybe import Data.String (fromString) import qualified Data.Text as T-import qualified Development.IDE.GHC.Compat as GHC+import Development.IDE.GHC.Compat (DecoratedSDoc, MsgEnvelope,+ errMsgSeverity, errMsgSpan,+ formatErrorWithQual,+ srcErrorMessages)+import qualified Development.IDE.GHC.Compat as Compat+import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location-import ErrUtils-import qualified FastString as FS import GHC-import HscTypes-import qualified Outputable as Out-import Panic-import SrcLoc - diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) Diagnostic@@ -60,32 +57,25 @@ } -- | Produce a GHC-style error from a source span and a message.-diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]+diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] diagFromErrMsg diagSource dflags e = [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ formatErrorWithQual dflags e | Just sev <- [toDSeverity $ errMsgSeverity e]] -formatErrorWithQual :: DynFlags -> ErrMsg -> String-formatErrorWithQual dflags e =- Out.showSDoc dflags- $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e)- $ GHC.oldFormatErrDoc dflags- $ ErrUtils.errMsgDoc e--diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]-diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList+diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]+diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range-srcSpanToRange (UnhelpfulSpan _) = Nothing-srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real+srcSpanToRange (UnhelpfulSpan _) = Nothing+srcSpanToRange (Compat.RealSrcSpan real _) = Just $ realSrcSpanToRange real -- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real =- Range (realSrcLocToPosition $ realSrcSpanStart real)- (realSrcLocToPosition $ realSrcSpanEnd real)+ Range (realSrcLocToPosition $ Compat.realSrcSpanStart real)+ (realSrcLocToPosition $ Compat.realSrcSpanEnd real) realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real =@@ -95,12 +85,12 @@ -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing-srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real+srcSpanToFilename (Compat.RealSrcSpan real _) = Just $ Compat.unpackFS $ srcSpanFile real -- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real)- where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real+ where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ Compat.unpackFS $ srcSpanFile real srcSpanToLocation :: SrcSpan -> Maybe Location srcSpanToLocation src = do@@ -110,18 +100,18 @@ pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan-rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan+rangeToSrcSpan = fmap (\x -> Compat.RealSrcSpan x Nothing) . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan rangeToRealSrcSpan nfp =- mkRealSrcSpan+ Compat.mkRealSrcSpan <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)=- mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1)+ Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of@@ -152,19 +142,19 @@ -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan-noSpan = GHC.oldUnhelpfulSpan . FS.fsLit+noSpan = Compat.mkGeneralSrcSpan . Compat.fsLit -- | creates a span with zero length in the filename of the argument passed-zeroSpan :: FS.FastString -- ^ file path of span+zeroSpan :: Compat.FastString -- ^ file path of span -> RealSrcSpan-zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1)+zeroSpan file = Compat.realSrcLocSpan (Compat.mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case- GHC.OldRealSrcSpan r -> Just r- UnhelpfulSpan _ -> Nothing+ Compat.RealSrcSpan r _ -> Just r+ UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and@@ -172,7 +162,7 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do- handleGhcException (ghcExceptionToDiagnostics dflags) $+ Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ handleSourceError (sourceErrorToDiagnostics dflags) $ Right <$> ghcM where@@ -192,14 +182,14 @@ -> unwords ["Compilation Issue:", s, "\n", requestReport] PprPanic s sdoc -> unlines ["Compilation Issue", s,""- , Out.showSDoc dflags sdoc+ , Compat.showSDoc dflags sdoc , requestReport ] Sorry s -> "Unsupported feature: " <> s PprSorry s sdoc -> unlines ["Unsupported feature: ", s,""- , Out.showSDoc dflags sdoc]+ , Compat.showSDoc dflags sdoc] ---------- errors below should not happen at all --------@@ -216,6 +206,6 @@ -> "Program error: " <> str PprProgramError str sdoc -> unlines ["Program error:", str,""- , Out.showSDoc dflags sdoc]+ , Compat.showSDoc dflags sdoc] where requestReport = "Please report this bug to the compiler authors."
src/Development/IDE/GHC/ExactPrint.hs view
@@ -29,10 +29,11 @@ Anns, Annotate, setPrecedingLinesT,+ -- * Helper function+ eqSrcSpan, ) where -import BasicTypes (appPrec) import Control.Applicative (Alternative) import Control.Arrow import Control.Monad@@ -53,7 +54,9 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake-import Development.IDE.GHC.Compat hiding (parseExpr)+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@@ -65,9 +68,6 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities)-import Outputable (Outputable, ppr,- showSDoc)-import Parser (parseIdentifier) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern,@@ -81,7 +81,6 @@ instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource-instance Binary GetAnnotatedParsedSource type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource -- | Get the latest version of the annotated parse source with comments.@@ -233,8 +232,9 @@ everywhere' ( mkT $ \case- (L src _ :: Located ast) | src == dst -> val'- l -> l+ (L src _ :: Located ast)+ | src `eqSrcSpan` dst -> val'+ l -> l ) a @@ -267,7 +267,7 @@ let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of- (L src _ :: LHsExpr GhcPs) | src == dst ->+ (L src _ :: LHsExpr GhcPs) | src `eqSrcSpan` dst -> (s, s) L _ x' -> (mempty, Just *** Just $ needsParensSpace x') ) a@@ -291,7 +291,7 @@ ( mkM $ \case val@(L src _ :: LHsExpr GhcPs)- | src == dst -> do+ | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do@@ -316,7 +316,7 @@ ( mkM $ \case val@(L src _ :: Located ast)- | src == dst -> do+ | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do@@ -368,7 +368,7 @@ annotateDecl dflags decl let go [] = DL.empty go (L src e : rest)- | src == dst = DL.fromList decs <> DL.fromList rest+ | src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a @@ -399,7 +399,7 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest)- | src == dst = toDecls e >>= \case+ | src `eqSrcSpan` dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $@@ -519,3 +519,9 @@ 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
src/Development/IDE/GHC/Orphans.hs view
@@ -9,21 +9,35 @@ -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where +#if MIN_VERSION_ghc(9,0,0)+import GHC.Data.Bag+import GHC.Data.FastString+import qualified GHC.Data.StringBuffer as SB+import GHC.Types.Name.Occurrence+import GHC.Types.SrcLoc+import GHC.Types.Unique (getKey)+import GHC.Unit.Info+import GHC.Utils.Outputable+#else import Bag+import GhcPlugins+import qualified StringBuffer as SB+import Unique (getKey)+#endif++import GHC++import Retrie.ExactPrint (Annotated)++import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util+ import Control.DeepSeq import Data.Aeson import Data.Hashable import Data.String (IsString (fromString)) import Data.Text (Text)-import Development.IDE.GHC.Compat-import Development.IDE.GHC.Util-import GHC ()-import GhcPlugins-import Retrie.ExactPrint (Annotated)-import qualified StringBuffer as SB-import Unique (getKey) - -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint instance NFData CoreModule where rnf = rwhnf@@ -50,7 +64,7 @@ instance Hashable GhcPlugins.InstalledUnitId where hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else-instance Show InstalledUnitId where show = prettyPrint+instance Show UnitId where show = prettyPrint deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif@@ -93,8 +107,10 @@ instance NFData SourceModified where rnf = rwhnf +#if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where show = moduleNameString+#endif instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show
src/Development/IDE/GHC/Util.hs view
@@ -10,7 +10,7 @@ prettyPrint, unsafePrintSDoc, printRdrName,- printName,+ Development.IDE.GHC.Util.printName, ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer,@@ -30,48 +30,78 @@ disableWarningsAsErrors, ) where +#if MIN_VERSION_ghc(9,2,0)+import GHC+import GHC.Core.Multiplicity+import qualified GHC.Core.TyCo.Rep as TyCoRep+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Driver.Env+import GHC.Driver.Env.Types+import GHC.Driver.Monad+import GHC.Driver.Session hiding (ExposePackage)+import qualified GHC.Driver.Session as DynFlags+import GHC.Hs.Extension+import qualified GHC.Hs.Type as GHC+import GHC.Iface.Env (updNameCache)+import GHC.Iface.Make (mkIfaceExports)+import qualified GHC.Linker.Types as LinkerTypes+import GHC.Parser.Lexer+import GHC.Runtime.Context+import GHC.Tc.Types (TcGblEnv (tcg_exports))+import GHC.Tc.Utils.TcType (pprSigmaType)+import GHC.Types.Avail+import GHC.Types.Name.Cache+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Unit.Env+import GHC.Unit.Info (PackageName)+import qualified GHC.Unit.Info as Packages+import qualified GHC.Unit.Module.Location as Module+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface (mi_mod_hash)+import GHC.Unit.Module.Name (moduleNameSlashes)+import qualified GHC.Unit.State as Packages+import GHC.Unit.Types (IsBootInterface (..),+ unitString)+import qualified GHC.Unit.Types as Module+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import qualified GHC.Utils.Outputable as Outputable+#endif import Control.Concurrent-import Control.Exception-import Data.Binary.Put (Put, runPut)-import qualified Data.ByteString as BS-import Data.ByteString.Internal (ByteString (..))-import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString.Lazy as LBS+import Control.Exception as E+import Data.Binary.Put (Put, runPut)+import qualified Data.ByteString as BS+import Data.ByteString.Internal (ByteString (..))+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Lazy as LBS import Data.IORef import Data.List.Extra import Data.Maybe-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Encoding.Error as T+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T import Data.Typeable-import Development.IDE.GHC.Compat as GHC+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.Compat.Util import Development.IDE.Types.Location-import FastString (mkFastString)-import FileCleanup-import Fingerprint import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable-import GHC.IO.BufferedIO (BufferedIO)-import GHC.IO.Device as IODevice+import GHC+import GHC.IO.BufferedIO (BufferedIO)+import GHC.IO.Device as IODevice import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types-import GhcMonad-import HscTypes (CgGuts, HscEnv (hsc_dflags),- ModDetails, cg_binds,- cg_module, hsc_IC, ic_dflags,- md_types)-import Lexer-import Module (moduleNameSlashes)-import OccName (parenSymOcc)-import Outputable (Depth (..), Outputable, SDoc,- neverQualify, ppr,- showSDocUnsafe)-import RdrName (nameRdrName, rdrNameOcc)-import SrcLoc (mkRealSrcLoc)-import StringBuffer+ import System.FilePath @@ -86,19 +116,15 @@ -- We do not use setSessionDynFlags here since we handle package -- initialization separately. modifySession $ \h ->- h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }+ hscSetFlags newFlags h { hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } -- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment.-lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig+lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.UnitInfo lookupPackageConfig unit env =- -- GHC.lookupPackage' False pkgConfigMap unit- GHC.lookupUnit' False pkgConfigMap prClsre unit+ Compat.lookupUnit' False unitState prClsre unit where- pkgConfigMap =- -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap- -- from PackageState so we have to wrap it in DynFlags first.- getPackageConfigMap $ hsc_dflags env- prClsre = preloadClosureUs $ hsc_dflags env+ unitState = Compat.getUnitInfoMap env+ prClsre = preloadClosureUs env -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.@@ -112,7 +138,7 @@ filename = "<interactive>" location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str- parseState = mkPState flags buffer location+ parseState = Compat.initParserState (Compat.initParserOpts flags) buffer location stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len@@ -125,9 +151,7 @@ prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String-unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay)- where- dflags = unsafeGlobalDynFlags+unsafePrintSDoc sdoc = showSDocUnsafe sdoc -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String@@ -148,13 +172,9 @@ -- pieces, but designed to be more efficient than a standard 'runGhc'. runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) runGhcEnv env act = do- filesToClean <- newIORef emptyFilesToClean- dirsToClean <- newIORef mempty- let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}- ref <- newIORef env{hsc_dflags=dflags}- res <- unGhc act (Session ref) `finally` do- cleanTempFiles dflags- cleanTempDirs dflags+ hsc_env <- initTempFs env+ ref <- newIORef hsc_env+ res <- unGhc (withCleanupSession act) (Session ref) (,res) <$> readIORef ref -- | Given a module location, and its parse tree, figure out what is the include directory implied by it.@@ -218,7 +238,7 @@ -- _ <- hClose_help h2_ -- hClose_help does two things: -- 1. It flushes the buffer, we replicate this here- _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure ()+ _ <- flushWriteBuffer h2_ `E.catch` \(_ :: IOException) -> pure () -- 2. It closes the handle. This is redundant since dup2 takes care of that -- but even worse it is actively harmful! Once the handle has been closed -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY
src/Development/IDE/GHC/Warnings.hs view
@@ -4,15 +4,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where -import Data.List-import ErrUtils-import GhcPlugins as GHC hiding (Var, (<>))- import Control.Concurrent.Strict+import Data.List import qualified Data.Text as T -import Development.IDE.GHC.Compat (LogActionCompat,- logActionCompat)+import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..))@@ -27,16 +23,20 @@ -- 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-withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)+withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) 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 modifyVar_ warnings $ return . (wr_d:)- res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}}+ newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env)+ res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res)+ where+ third3 :: (c -> d) -> (a, b, c) -> (a, b, d)+ third3 f (a, b, c) = (a, b, f c) attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr}
src/Development/IDE/Import/DependencyInformation.hs view
@@ -327,6 +327,7 @@ FilePathId cur_id <- lookupPathToId depPathIdMap file return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps)) +-- | returns all transitive dependencies in topological order. transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do let !fileId = pathToId depPathIdMap file
src/Development/IDE/Import/FindImports.hs view
@@ -13,25 +13,19 @@ , mkImportDirs ) where +import Control.DeepSeq import Development.IDE.GHC.Compat as Compat+import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location--- GHC imports-import Control.DeepSeq-import FastString-import Finder-import qualified Module as M-import Outputable (ppr, pprPanic, showSDoc)-import Packages -- standard imports import Control.Monad.Extra import Control.Monad.IO.Class import Data.List (isSuffixOf) import Data.Maybe-import DriverPhases import System.FilePath data Import@@ -75,7 +69,7 @@ -> m (Maybe NormalizedFilePath) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs =- [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)+ [ toNormalizedFilePath' (prefix </> moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] firstJustM (targetFor modName) (concatMap candidates import_dirss) where@@ -87,22 +81,22 @@ -- 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 :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])-mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i+mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath])+mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m- => DynFlags- -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories+ => HscEnv+ -> [(UnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> Maybe FastString -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import)-locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do+locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do@@ -111,7 +105,7 @@ Just pkgName | Just dirs <- lookup (PackageName pkgName) import_paths -> lookupLocal [dirs]- | otherwise -> lookupInPackageDB dflags+ | otherwise -> lookupInPackageDB env Nothing -> do -- first try to find the module as a file. If we can't find it try to find it in the package -- database.@@ -120,10 +114,11 @@ -- 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 case mbFile of- Nothing -> lookupInPackageDB dflags+ Nothing -> lookupInPackageDB env Just file -> toModLocation file where- import_paths = mapMaybe (mkImportDirs dflags) comp_info+ dflags = hsc_dflags env+ import_paths = mapMaybe (mkImportDirs env) comp_info toModLocation file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource)@@ -131,20 +126,21 @@ lookupLocal dirs = do mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of- Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []+ Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] Just file -> toModLocation file - lookupInPackageDB dfs =- case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of+ lookupInPackageDB env =+ case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport- reason -> return $ Left $ notFoundErr dfs modName reason+ reason -> return $ Left $ notFoundErr env modName reason -- | Don't call this on a found module.-notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic]-notFoundErr dfs modName reason =- mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason+notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic]+notFoundErr env modName reason =+ mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where- mkError' = diagFromString "not found" DsError (getLoc modName)+ dfs = hsc_dflags env+ mkError' = diagFromString "not found" DsError (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer.@@ -155,12 +151,12 @@ LookupMultiple rs -> FoundMultiple rs LookupHidden pkg_hiddens mod_hiddens -> notFound- { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens- , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens+ { fr_pkgs_hidden = map (moduleUnit . fst) pkg_hiddens+ , fr_mods_hidden = map (moduleUnit . fst) mod_hiddens } LookupUnusable unusable -> let unusables' = map get_unusable unusable- get_unusable (m, ModUnusable r) = (moduleUnitId m, r)+ get_unusable (m, ModUnusable r) = (moduleUnit m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'}
src/Development/IDE/LSP/LanguageServer.hs view
@@ -141,7 +141,8 @@ T.pack $ "Fatal error in server thread: " <> show e exitClientMsg handleServerException _ = pure ()- _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do+ logger = ideLogger ide+ _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) forever $ do msg <- readChan clientMsgChan
src/Development/IDE/LSP/Notifications.hs view
@@ -14,29 +14,25 @@ import Language.LSP.Types import qualified Language.LSP.Types as LSP -import Development.IDE.Core.IdeConfiguration-import Development.IDE.Core.Service-import Development.IDE.Core.Shake-import Development.IDE.Types.Location-import Development.IDE.Types.Logger-import Development.IDE.Types.Options- import Control.Monad.Extra+import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as S import qualified Data.Text as Text--import Control.Monad.IO.Class import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.FileStore (registerFileWatches, resetFileStore, setFileModified,- setSomethingModified,- typecheckParents)+ setSomethingModified)+import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..))+import Development.IDE.Core.Service+import Development.IDE.Core.Shake+import Development.IDE.Types.Location+import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey)-import Ide.Plugin.Config (CheckParents (CheckOnClose)) import Ide.Types whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()@@ -73,20 +69,30 @@ \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file- -- Refresh all the files that depended on this- checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)- when (checkParents >= CheckOnClose) $ typecheckParents ide file- logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri+ let msg = "Closed text document: " <> getUri _uri+ scheduleGarbageCollection ide+ setSomethingModified ide [] $ Text.unpack msg+ logDebug (ideLogger ide) msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and -- what we do with them- let msg = Text.pack $ show fileEvents- logDebug (ideLogger ide) $ "Watched file events: " <> msg- modifyFileExists ide fileEvents- resetFileStore ide fileEvents- setSomethingModified ide []+ -- filter out files of interest, since we already know all about those+ -- filter also uris that do not map to filenames, since we cannot handle them+ filesOfInterest <- getFilesOfInterest ide+ let fileEvents' =+ [ (nfp, event) | (FileEvent uri event) <- fileEvents+ , Just fp <- [uriToFilePath uri]+ , let nfp = toNormalizedFilePath fp+ , not $ HM.member nfp filesOfInterest+ ]+ unless (null fileEvents') $ do+ let msg = show fileEvents'+ logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg+ modifyFileExists ide fileEvents'+ resetFileStore ide fileEvents'+ setSomethingModified ide [] msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do@@ -101,7 +107,7 @@ let msg = Text.pack $ show cfg logDebug (ideLogger ide) $ "Configuration changed: " <> msg modifyClientSettings ide (const $ Just cfg)- setSomethingModified ide [toKey GetClientSettings emptyFilePath ]+ setSomethingModified ide [toKey GetClientSettings emptyFilePath] "config change" , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do --------- Initialize Shake session --------------------------------------------------------------------
src/Development/IDE/LSP/Outline.hs view
@@ -29,8 +29,6 @@ SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL), uriToFilePath)-import Outputable (Outputable, ppr,- showSDocUnsafe) moduleOutline :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))@@ -44,7 +42,7 @@ -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case- (L (OldRealSrcSpan l) m) -> Just $+ (L (RealSrcSpan l _) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile@@ -73,7 +71,7 @@ Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))+documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of@@ -83,7 +81,7 @@ , _detail = Just $ pprText fdInfo , _kind = SkFunction }-documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))+documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of@@ -99,11 +97,11 @@ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' }- | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs- , L (OldRealSrcSpan l') n <- names+ | L (RealSrcSpan l _) (ClassOpSig _ False names _) <- tcdSigs+ , L (RealSrcSpan l' _) n <- names ] }-documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))+documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct@@ -115,8 +113,8 @@ , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) }- | L (OldRealSrcSpan l ) x <- dd_cons- , L (OldRealSrcSpan l') n <- getConNames' x+ | L (RealSrcSpan l _ ) x <- dd_cons+ , L (RealSrcSpan l' _) n <- getConNames' x ] } where@@ -127,48 +125,48 @@ , _kind = SkField } | L _ cdf <- lcdfs- , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf+ , L (RealSrcSpan l _) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing-documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just+documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l' _) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' }-documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))+documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface }-documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface }-documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))+documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface }-documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) =+documentSymbolForDecl (L (RealSrcSpan l _) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface }-documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just+documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction }-documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just+documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just+documentSymbolForDecl (L (RealSrcSpan l _) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name@@ -202,7 +200,7 @@ } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol-documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just+documentSymbolForImport (L (RealSrcSpan l _) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule
src/Development/IDE/Main.hs view
@@ -1,14 +1,16 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main (Arguments(..)+,defaultArguments ,Command(..) ,IdeCommand(..) ,isLSP ,commandP ,defaultMain-) where+,testing) where import Control.Concurrent.Extra (newLock, readVar,- withLock)+ withLock,+ withNumCapabilities) import Control.Exception.Safe (Exception (displayException), catchAny) import Control.Monad.Extra (concatMapM, unless,@@ -25,8 +27,10 @@ import qualified Data.Text.IO 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 (..),- Rules, ghcVersion,+ Priority (Debug), Rules,+ ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer)@@ -54,6 +58,7 @@ import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide+import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, loadSessionWithOptions,@@ -61,24 +66,31 @@ setInitialDynFlags) import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath')-import Development.IDE.Types.Logger (Logger (Logger))+import Development.IDE.Types.Logger (Logger (Logger),+ Priority (Info),+ logDebug, logInfo) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),+ IdeTesting (IdeTesting), clientSupportsProgress, defaultIdeOptions,- optModifyDynFlags)-import Development.IDE.Types.Shake (Key (Key))+ 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,+ Config, checkParents,+ checkProject, getConfigFromNotification) import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (allLspCmdIds', getProcessID,+ idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types (IdeCommand (IdeCommand), IdePlugins,@@ -86,6 +98,7 @@ PluginId (PluginId), ipMap) import qualified Language.LSP.Server as LSP+import Numeric.Natural (Natural) import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure),@@ -163,22 +176,30 @@ , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics , argsHandleIn :: IO Handle , argsHandleOut :: IO Handle+ , argsThreads :: Maybe Natural } instance Default Arguments where- def = Arguments+ def = defaultArguments Info++defaultArguments :: Priority -> Arguments+defaultArguments priority = Arguments { argsOTMemoryProfiling = False , argCommand = LSP- , argsLogger = stderrLogger- , argsRules = mainRule >> action kick+ , argsLogger = stderrLogger priority+ , argsRules = mainRule def >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors , argsSessionLoadingOptions = def- , argsIdeOptions = const defaultIdeOptions+ , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession)+ { optCheckProject = pure $ checkProject config+ , optCheckParents = pure $ checkParents config+ } , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer+ , argsThreads = Nothing , argsHandleIn = pure stdin , argsHandleOut = do -- Move stdout to another file descriptor and duplicate stderr@@ -196,11 +217,23 @@ return newStdout } +testing :: Arguments+testing = (defaultArguments Debug) {+ argsHlsPlugins = pluginDescToIdePlugins $+ idePluginsToPluginDesc (argsHlsPlugins def)+ ++ [Test.blockCommandDescriptor "block-command", Test.plugin],+ argsIdeOptions = \config sessionLoader ->+ let defOptions = argsIdeOptions def config sessionLoader+ in defOptions {+ optTesting = IdeTesting True+ }+}+ -- | Cheap stderr logger that relies on LineBuffering-stderrLogger :: IO Logger-stderrLogger = do+stderrLogger :: Priority -> IO Logger+stderrLogger logLevel = do lock <- newLock- return $ Logger $ \p m -> withLock lock $+ return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m defaultMain :: Arguments -> IO ()@@ -221,27 +254,29 @@ inH <- argsHandleIn outH <- argsHandleOut + numProcessors <- getNumProcessors+ case argCommand of PrintExtensionSchema -> LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins PrintDefaultConfig -> LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins- LSP -> do+ LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do t <- offsetTime- hPutStrLn stderr "Starting LSP server..."- hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"+ logInfo logger "Starting LSP server..."+ logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t- hPutStrLn stderr $ "Started LSP server in " ++ showDuration t+ logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t 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 dir argsSessionLoadingOptions- `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)+ setInitialDynFlags logger dir argsSessionLoadingOptions+ `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir@@ -250,6 +285,7 @@ -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported+ logDebug logger $ T.pack $ "runSubset: " <> show runSubset let options = def_options { optReportProgress = clientSupportsProgress caps@@ -275,7 +311,7 @@ Check argFiles -> do dir <- IO.getCurrentDirectory dbLoc <- getHieDbLoc dir- runWithDb dbLoc $ \hiedb hieChan -> do+ runWithDb logger dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8@@ -329,24 +365,24 @@ printf "# Shake value store contents(%d):\n" (length values) let keys = nub $- Key GhcSession :- Key GhcSessionDeps :- [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO]- ++ [Key GhcSessionIO]+ typeOf GhcSession :+ typeOf GhcSessionDeps :+ [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] +++ [typeOf GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) Db dir opts cmd -> do dbLoc <- getHieDbLoc dir hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc- mlibdir <- setInitialDynFlags dir def+ mlibdir <- setInitialDynFlags logger dir def case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd Custom projectRoot (IdeCommand c) -> do dbLoc <- getHieDbLoc projectRoot- runWithDb dbLoc $ \hiedb hieChan -> do+ runWithDb logger dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
src/Development/IDE/Plugin/CodeAction.hs view
@@ -18,8 +18,6 @@ , matchRegExMultipleImports ) where -import Bag (bagToList,- isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>))@@ -44,6 +42,7 @@ 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.Util (prettyPrint, printRdrName,@@ -57,8 +56,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified GHC.LanguageExtensions as Lang-import HscTypes (ImportedModsVal (..),- importedByUser) import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP@@ -77,18 +74,6 @@ type (|?) (InR), uriToFilePath) import Language.LSP.VFS-import Module (moduleEnvElts)-import OccName-import Outputable (Outputable,- ppr,- showSDoc,- showSDocUnsafe)-import RdrName (GlobalRdrElt (..),- lookupGlobalRdrEnv)-import SrcLoc (realSrcSpanEnd,- realSrcSpanStart)-import TcRnTypes (ImportAvails (..),- TcGblEnv (..)) import Text.Regex.TDFA (mrAfter, (=~), (=~~)) @@ -256,7 +241,7 @@ | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s],- isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan 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@@ -440,10 +425,10 @@ findRelatedSpans indexedContent name- (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) =+ (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc ->- let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig+ let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) :@@ -466,7 +451,7 @@ let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int- Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused+ Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match@@ -517,10 +502,10 @@ indexedContent name lsigs- (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) =+ (L (RealSrcSpan l _) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then- let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig+ let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches@@ -562,7 +547,7 @@ -- 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 (OldRealSrcSpan l) exports) =+ needsComma source (L (RealSrcSpan l _) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of@@ -690,7 +675,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp- | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls+ | (L l@(RealSrcSpan sp _) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig@@ -897,8 +882,9 @@ "Ambiguous occurrence ‘([^’]+)’" , Just modules <- map last- <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" =- suggestions ambiguous modules+ <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’"+ , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" =+ suggestions ambiguous modules (isJust local) | otherwise = [] where locDic =@@ -921,16 +907,16 @@ -- > 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+ suggestions symbol mods local | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of- Just targets -> suggestionsImpl symbol (map (, []) targets)+ Just targets -> suggestionsImpl symbol (map (, []) targets) local Nothing -> [] | otherwise = case mapM toModuleTarget mods of- Just targets -> suggestionsImpl symbol (oneAndOthers targets)+ Just targets -> suggestionsImpl symbol (oneAndOthers targets) local Nothing -> []- suggestionsImpl symbol targetsWithRestImports =+ suggestionsImpl symbol targetsWithRestImports local = sortOn fst- [ ( renderUniquify mode modNameText symbol+ [ ( renderUniquify mode modNameText symbol False , disambiguateSymbol ps fileContents diag symbol mode ) | (modTarget, restImports) <- targetsWithRestImports@@ -957,10 +943,14 @@ _ -> 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 =- "Use " <> modName <> " for " <> symbol <> ", hiding other imports"- renderUniquify (ToQualified _ qual) _ symbol =+ 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) <> "."@@ -1015,12 +1005,11 @@ liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $- L (oldUnhelpfulSpan "") rdr+ L (mkGeneralSrcSpan "") rdr else Rewrite (rangeToSrcSpan "<dummy>" _range) $ \df -> liftParseAST @RdrName df $- prettyPrint $ L (oldUnhelpfulSpan "") rdr+ prettyPrint $ L (mkGeneralSrcSpan "") rdr ]- findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs @@ -1316,7 +1305,7 @@ findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int) findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of- OldRealSrcSpan s ->+ RealSrcSpan s _ -> let col = calcCol s in Just ((srcLocLine (realSrcSpanEnd s), col), col) _ -> Nothing
src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -29,21 +29,17 @@ import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T-import Development.IDE.GHC.Compat hiding (parseExpr)+import Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), Annotate) import Development.IDE.Spans.Common-import FieldLabel (flLabel) import GHC.Exts (IsList (fromList))-import GhcPlugins (mkRdrUnqual, sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.LSP.Types-import OccName-import Outputable (ppr, showSDocUnsafe)-import Retrie.GHC (rdrNameOcc, unpackFS) ------------------------------------------------------------------------------ @@ -453,5 +449,5 @@ ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons)- (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds)+ (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) killLie v = Just v
src/Development/IDE/Plugin/Completions.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +30,6 @@ import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes-import Development.IDE.Import.FindImports import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint@@ -40,6 +38,7 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports), hscEnv)+import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location import GHC.Exts (fromList, toList) import GHC.Generics@@ -48,11 +47,7 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS-#if MIN_VERSION_ghc(9,0,0)-import GHC.Tc.Module (tcRnImportDecls)-#else-import TcRnDriver (tcRnImportDecls)-#endif+import Text.Fuzzy.Parallel (Scored (..)) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)@@ -111,13 +106,11 @@ deriving (Eq, Show, Typeable, Generic) instance Hashable LocalCompletions instance NFData LocalCompletions-instance Binary LocalCompletions data NonLocalCompletions = NonLocalCompletions deriving (Eq, Show, Typeable, Generic) instance Hashable NonLocalCompletions instance NFData NonLocalCompletions-instance Binary NonLocalCompletions -- | Generate code actions. getCompletionsLSP@@ -139,7 +132,9 @@ nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath-+ knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets+ let localModules = maybe [] Map.keys knownTargets+ let lModules = mempty{importableModules = map toModueNameText localModules} -- set up the exports map including both package and project-level identifiers packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath packageExportsMap <- mapM liftIO packageExportsMapIO@@ -149,7 +144,7 @@ let moduleExports = getModuleExportsMap exportsMap exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap exportsCompls = mempty{anyQualCompls = exportsCompItems}- let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls+ let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules pure (opts, fmap (,pm,binds) compls, moduleExports) case compls of@@ -162,12 +157,50 @@ let clientCaps = clientCapabilities $ shakeExtras ide config <- getCompletionsConfig plId allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports- pure $ InL (List allCompletions)+ pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) _ -> return (InL $ List []) +{- COMPLETION SORTING+ We return an ordered set of completions (local -> nonlocal -> global).+ Ordering is important because local/nonlocal are import aware, whereas+ global are not and will always insert import statements, potentially redundant.++ Moreover, the order prioritizes qualifiers, for instance, given:++ import qualified MyModule+ foo = MyModule.<complete>++ The identifiers defined in MyModule will be listed first, followed by other+ identifiers in importable modules.++ According to the LSP specification, if no sortText is provided, the label is used+ to sort alphabetically. Alphabetical ordering is almost never what we want,+ so we force the LSP client to respect our ordering by using a numbered sequence.+-}++orderedCompletions :: [Scored CompletionItem] -> [CompletionItem]+orderedCompletions [] = []+orderedCompletions xx = zipWith addOrder [0..] xx+ where+ lxx = digits $ Prelude.length xx+ digits = Prelude.length . show++ addOrder :: Int -> Scored CompletionItem -> CompletionItem+ addOrder n Scored{original = it@CompletionItem{_label,_sortText}} =+ it{_sortText = Just $+ T.pack(pad lxx n)+ }++ pad n x = let sx = show x in replicate (n - Prelude.length sx) '0' <> sx+ ----------------------------------------------------------------------------------------------------++toModueNameText :: KT.Target -> T.Text+toModueNameText target = case target of+ KT.TargetModule m -> T.pack $ moduleNameString m+ _ -> T.empty extendImportCommand :: PluginCommand IdeState extendImportCommand =
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -20,33 +20,24 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust,- isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy -import HscTypes-import Name-import RdrName-import Type-#if MIN_VERSION_ghc(8,10,0)-import Coercion-import Pair-import Predicate (isDictTy)-#endif--import ConLike import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Either (fromRight)+import Data.Function (on) import Data.Functor import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet+import Data.Ord (Down (Down)) import qualified Data.Set as Set import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping-import Development.IDE.GHC.Compat as GHC+import Development.IDE.GHC.Compat as GHC hiding (ppr)+import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types@@ -56,15 +47,14 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options-import GhcPlugins (flLabel, unpackFS) import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS-import Outputable (Outputable)-import TyCoRep+import Text.Fuzzy.Parallel (Scored (score_),+ original) -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int@@ -161,13 +151,6 @@ showModName :: ModuleName -> T.Text showModName = T.pack . moduleNameString --- mkCompl :: IdeOptions -> CompItem -> CompletionItem--- mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs} =--- CompletionItem label kind (List []) ((colon <>) <$> typeText)--- (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')--- Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)--- Nothing Nothing Nothing Nothing Nothing- mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem mkCompl pId@@ -176,7 +159,7 @@ { compKind, isInfix, insertText,- importedFrom,+ provenance, typeText, label, docs,@@ -187,7 +170,12 @@ {_label = label, _kind = kind, _tags = Nothing,- _detail = (colon <>) <$> typeText,+ _detail =+ case (typeText, provenance) of+ (Just t,_) | not(T.null t) -> Just $ colon <> t+ (_, ImportedFrom mod) -> Just $ "from " <> mod+ (_, DefinedIn mod) -> Just $ "from " <> mod+ _ -> Nothing, _documentation = documentation, _deprecated = Nothing, _preselect = Nothing,@@ -205,23 +193,28 @@ where kind = Just compKind docs' = imported : spanDocToMarkdown docs- imported = case importedFrom of- Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"- Right mod -> "*Defined in '" <> mod <> "'*\n"+ imported = case provenance of+ Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n'"+ ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"+ DefinedIn mod -> "*Defined in '" <> mod <> "'*\n" colon = if optNewColonConvention then ": " else ":: " documentation = Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs'+ pprLineCol :: SrcLoc -> T.Text+ pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs+ pprLineCol (RealSrcLoc loc _) =+ "line " <> ppr(srcLocLine loc) <> ", column " <> ppr(srcLocCol loc) + mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command mkAdditionalEditsCommand pId edits = mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) -mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem-mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..}+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 {..} where compKind = occNameToComKind typeText origName- importedFrom = Right $ showModName origMod isTypeCompl = isTcOcc origName label = stripPrefix $ showGhc origName insertText = case isInfix of@@ -270,7 +263,7 @@ getArgs t | isPredTy t = [] | isDictTy t = []- | isForAllTy t = getArgs $ snd (splitForAllTys t)+ | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) | isFunTy t = let (args, ret) = splitFunTys t in if isForAllTy ret@@ -316,7 +309,7 @@ fromIdentInfo doc IdentInfo{..} q = CI { compKind= occNameToComKind Nothing name , insertText=rendered- , importedFrom=Right moduleNameText+ , provenance = DefinedIn moduleNameText , typeText=Nothing , label=rendered , isInfix=Nothing@@ -337,8 +330,9 @@ let packageState = hscEnv env curModName = moduleName curMod+ curModNameText = ppr curModName - importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ]+ importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName@@ -363,7 +357,7 @@ getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) getComplsForOne (GRE n par True _) =- (, mempty) <$> toCompItem par curMod curModName n Nothing+ (, mempty) <$> toCompItem par curMod curModNameText n Nothing getComplsForOne (GRE n par False prov) = flip foldMapM (map is_decl prov) $ \spec -> do let originalImportDecl = do@@ -372,7 +366,7 @@ -- or if it doesn't have a real location loc <- realSpan $ is_dloc spec Map.lookup loc importMap- compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl+ compItem <- toCompItem par curMod (ppr $ is_mod spec) n originalImportDecl let unqual | is_qual spec = [] | otherwise = compItem@@ -383,7 +377,7 @@ origMod = showModName (is_mod spec) return (unqual,QualCompls qual) - toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]+ toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] toCompItem par m mn n imp' = do docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of@@ -399,10 +393,10 @@ let recordCompls = case record_ty of Just (ctxStr, flds) | not (null flds) ->- [mkRecordSnippetCompItem uri mbParent ctxStr flds (ppr mn) docs imp']+ [mkRecordSnippetCompItem uri mbParent ctxStr flds (ImportedFrom mn) docs imp'] _ -> [] - return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp'+ return $ mkNameCompItem uri mbParent originName (ImportedFrom mn) ty Nothing docs imp' : recordCompls (unquals,quals) <- getCompls rdrElts@@ -420,7 +414,7 @@ -- | Produces completions from the top level declarations of a module. localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions-localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =+localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = CC { allModNamesAsNS = mempty , unqualCompls = compls , qualCompls = mempty@@ -447,16 +441,16 @@ [mkComp id CiVariable Nothing | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs} ->- mkComp tcdLName CiInterface Nothing :+ mkComp tcdLName CiInterface (Just $ ppr tcdLName) : [ mkComp id CiFunction (Just $ ppr typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs , id <- ids] TyClD _ x ->- let generalCompls = [mkComp id cl Nothing+ let generalCompls = [mkComp id cl (Just $ ppr $ tcdLName x) | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] -- here we only have to look at the outermost type- recordCompls = findRecordCompl uri pm thisModName x+ recordCompls = findRecordCompl uri pm (Local pos) x in -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls@@ -465,18 +459,21 @@ ForD _ ForeignExport{fd_name,fd_sig_ty} -> [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] _ -> []- | L _ decl <- hsmodDecls+ | L pos decl <- hsmodDecls,+ let mkComp = mkLocalComp pos ] - mkComp n ctyp ty =- CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing+ mkLocalComp pos n ctyp ty =+ CI ctyp pn (Local pos) ensureTypeText pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing where+ -- when sorting completions, we use the presence of typeText+ -- to tell local completions and global completions apart+ -- instead of using the empty string here, we should probably introduce a new field...+ ensureTypeText = Just $ fromMaybe "" ty pn = ppr n doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) - thisModName = ppr hsmodName--findRecordCompl :: Uri -> ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]+findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result where result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName)@@ -538,13 +535,17 @@ -> ClientCapabilities -> CompletionsConfig -> HM.HashMap T.Text (HashSet.HashSet IdentInfo)- -> IO [CompletionItem]+ -> IO [Scored CompletionItem] getCompletions plId 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 <> "." fullPrefix = enteredQual <> prefixText + -- Boolean labels to tag suggestions as qualified (or not)+ qual = not(T.null prefixModule)+ notQual = False+ {- correct the position by moving 'foo :: Int -> String -> ' ^ to 'foo :: Int -> String -> '@@ -554,12 +555,14 @@ maxC = maxCompletions config + filtModNameCompls :: [Scored CompletionItem] filtModNameCompls =- map mkModCompl- $ mapMaybe (T.stripPrefix enteredQual)- $ Fuzzy.simpleFilter chunkSize maxC fullPrefix allModNamesAsNS+ (fmap.fmap) mkModCompl+ $ Fuzzy.simpleFilter chunkSize maxC fullPrefix+ $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual))+ allModNamesAsNS - filtCompls = map Fuzzy.original $ Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" label False+ filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" (label . snd) where mcc = case maybe_parsed of@@ -574,11 +577,11 @@ -- completions specific to the current context ctxCompls' = case mcc of Nothing -> compls- Just TypeContext -> filter isTypeCompl compls- Just ValueContext -> filter (not . isTypeCompl) compls- Just _ -> filter (not . isTypeCompl) compls+ Just TypeContext -> filter ( isTypeCompl . snd) compls+ Just ValueContext -> filter (not . isTypeCompl . snd) compls+ Just _ -> filter (not . isTypeCompl . snd) compls -- Add whether the text to insert has backticks- ctxCompls = map (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'+ ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls' infixCompls :: Maybe Backtick infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos@@ -595,19 +598,17 @@ ctyp = occNameToComKind Nothing occ pn = ppr name ty = ppr <$> typ- thisModName = case nameModule_maybe name of- Nothing -> Left $ nameSrcSpan name- Just m -> Right $ ppr m+ thisModName = Local $ nameSrcSpan name compls = if T.null prefixModule- then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls)- else Map.findWithDefault [] prefixModule (getQualCompls qualCompls)- ++ (($ Just prefixModule) <$> anyQualCompls)+ then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)+ else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))+ ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls) filtListWith f list =- [ f label+ [ fmap f label | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list- , enteredQual `T.isPrefixOf` label+ , enteredQual `T.isPrefixOf` original label ] filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules@@ -634,26 +635,53 @@ -> return [] | otherwise -> do -- assumes that nubOrdBy is stable- let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls- let compls = map (mkCompl plId ideOpts) uniqueFiltCompls- return $ filtModNameCompls- ++ filtKeywordCompls- ++ map (toggleSnippets caps config) compls+ let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls+ let compls = (fmap.fmap.fmap) (mkCompl plId ideOpts) uniqueFiltCompls+ return $+ (fmap.fmap) snd $+ sortBy (compare `on` lexicographicOrdering) $+ mergeListsBy (flip compare `on` score_)+ [ (fmap.fmap) (notQual,) filtModNameCompls+ , (fmap.fmap) (notQual,) filtKeywordCompls+ , (fmap.fmap.fmap) (toggleSnippets caps config) compls+ ]+ where+ -- We use this ordering to alphabetically sort suggestions while respecting+ -- all the previously applied ordering sources. These are:+ -- 1. Qualified suggestions go first+ -- 2. Fuzzy score ranks next+ -- 3. In-scope completions rank next+ -- 4. label alphabetical ordering next+ -- 4. detail alphabetical ordering (proxy for module)+ lexicographicOrdering Fuzzy.Scored{score_, original} =+ case original of+ (isQual, CompletionItem{_label,_detail}) -> do+ let isLocal = maybe False (":" `T.isPrefixOf`) _detail+ (Down isQual, Down score_, Down isLocal, _label, _detail) ++ uniqueCompl :: CompItem -> CompItem -> Ordering-uniqueCompl x y =- case compare (label x, importedFrom x, compKind x)- (label y, importedFrom y, compKind y) of+uniqueCompl candidate unique =+ case compare (label candidate, compKind candidate)+ (label unique, compKind unique) of EQ -> -- preserve completions for duplicate record fields where the only difference is in the type- -- remove redundant completions with less type info- if typeText x == typeText y- || isNothing (typeText x)- || isNothing (typeText y)+ -- remove redundant completions with less type info than the previous+ if (typeText candidate == typeText unique && isLocalCompletion unique)+ -- filter global completions when we already have a local one+ || not(isLocalCompletion candidate) && isLocalCompletion unique then EQ- else compare (insertText x) (insertText y)+ else compare (importedFrom candidate, insertText candidate) (importedFrom unique, insertText unique) other -> other+ where+ isLocalCompletion ci = isJust(typeText ci) + importedFrom :: CompItem -> T.Text+ importedFrom (provenance -> ImportedFrom m) = m+ importedFrom (provenance -> DefinedIn m) = m+ importedFrom (provenance -> Local _) = "local"+ -- --------------------------------------------------------------------- -- helper functions for infix backticks -- ---------------------------------------------------------------------@@ -758,13 +786,13 @@ Just (ctxStr, field_names) safeTyThingForRecord _ = Nothing -mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem-mkRecordSnippetCompItem uri parent ctxStr compl mn docs imp = r+mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r where r = CI { compKind = CiSnippet , insertText = buildSnippet- , importedFrom = importedFrom+ , provenance = importedFrom , typeText = Nothing , label = ctxStr , isInfix = Nothing@@ -784,9 +812,49 @@ snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs snippet = T.intercalate (T.pack ", ") snippet_parts buildSnippet = ctxStr <> " {" <> snippet <> "}"- importedFrom = Right mn getImportQual :: LImportDecl GhcPs -> Maybe T.Text getImportQual (L _ imp) | isQualifiedImport imp = Just $ T.pack $ moduleNameString $ maybe (unLoc $ ideclName imp) unLoc (ideclAs imp) | otherwise = Nothing++--------------------------------------------------------------------------------++-- This comes from the GHC.Utils.Misc module (not exported)+-- | Merge an unsorted list of sorted lists, for example:+--+-- > mergeListsBy compare [ [2,5,15], [1,10,100] ] = [1,2,5,10,15,100]+--+-- \( O(n \log{} k) \)+mergeListsBy :: forall a. (a -> a -> Ordering) -> [[a]] -> [a]+mergeListsBy cmp all_lists = merge_lists all_lists+ where+ -- Implements "Iterative 2-Way merge" described at+ -- https://en.wikipedia.org/wiki/K-way_merge_algorithm++ -- Merge two sorted lists into one in O(n).+ merge2 :: [a] -> [a] -> [a]+ merge2 [] ys = ys+ merge2 xs [] = xs+ merge2 (x:xs) (y:ys) =+ case cmp x y of+ Prelude.GT -> y : merge2 (x:xs) ys+ _ -> x : merge2 xs (y:ys)++ -- Merge the first list with the second, the third with the fourth, and so+ -- on. The output has half as much lists as the input.+ merge_neighbours :: [[a]] -> [[a]]+ merge_neighbours [] = []+ merge_neighbours [xs] = [xs]+ merge_neighbours (xs : ys : lists) =+ merge2 xs ys : merge_neighbours lists++ -- Since 'merge_neighbours' halves the amount of lists in each iteration,+ -- we perform O(log k) iteration. Each iteration is O(n). The total running+ -- time is therefore O(n log k).+ merge_lists :: [[a]] -> [a]+ merge_lists lists =+ case merge_neighbours lists of+ [] -> []+ [xs] -> xs+ lists' -> merge_lists lists'
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -9,10 +9,10 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T-import SrcLoc import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text)+import Development.IDE.GHC.Compat import Development.IDE.Spans.Common import GHC.Generics (Generic) import Ide.Plugin.Config (Config)@@ -66,10 +66,16 @@ deriving (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +data Provenance+ = ImportedFrom Text+ | DefinedIn Text+ | Local SrcSpan+ deriving (Eq, Ord, Show)+ data CompItem = CI { compKind :: CompletionItemKind , insertText :: T.Text -- ^ Snippet for the completion- , importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from.+ , provenance :: Provenance -- ^ From where this item is imported from. , typeText :: Maybe T.Text -- ^ Available type information. , label :: T.Text -- ^ Label to display to the user. , isInfix :: Maybe Backtick -- ^ Did the completion happen
src/Development/IDE/Plugin/Test.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test ( TestRequest(..)@@ -10,53 +11,68 @@ , blockCommandId ) where -import Control.Concurrent (threadDelay)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Data.Aeson import Data.Aeson.Types import Data.Bifunctor-import Data.CaseInsensitive (CI, original)-import Data.Default (def)-import Data.Maybe (isJust)+import Data.CaseInsensitive (CI, original)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (isJust) import Data.String-import Data.Text (Text, pack)+import Data.Text (Text, pack)+import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Compat-import Development.IDE.Graph (Action)-import Development.IDE.LSP.Server-import Development.IDE.Plugin-import qualified Development.IDE.Plugin as P+import Development.IDE.Graph (Action)+import qualified Development.IDE.Graph as Graph+import Development.IDE.Graph.Database (ShakeDatabase,+ shakeGetBuildEdges,+ shakeGetBuildStep,+ shakeGetCleanKeys)+import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),+ Step (Step))+import qualified Development.IDE.Graph.Internal.Types as Graph import Development.IDE.Types.Action-import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))-import Development.IDE.Types.Location (fromUri)-import GHC.Generics (Generic)-import GhcPlugins (HscEnv (hsc_dflags))+import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))+import Development.IDE.Types.Location (fromUri)+import GHC.Generics (Generic)+import Ide.Plugin.Config (CheckParents) import Ide.Types-import qualified Language.LSP.Server as LSP+import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra +type Age = Int data TestRequest = BlockSeconds Seconds -- ^ :: Null- | GetInterfaceFilesDir FilePath -- ^ :: String+ | GetInterfaceFilesDir Uri -- ^ :: String | GetShakeSessionQueueCount -- ^ :: Number | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult+ | GetBuildKeysVisited -- ^ :: [(String]+ | GetBuildKeysBuilt -- ^ :: [(String]+ | GetBuildKeysChanged -- ^ :: [(String]+ | GetBuildEdgesCount -- ^ :: Int+ | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected)+ | GetStoredKeys -- ^ :: [String] (list of keys in store)+ | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic deriving anyclass (FromJSON, ToJSON) newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} deriving newtype (FromJSON, ToJSON) -plugin :: Plugin c-plugin = def {- P.pluginRules = return (),- P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'-}+plugin :: PluginDescriptor IdeState+plugin = (defaultPluginDescriptor "test") {+ pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ ->+ testRequestHandler' st+ } where testRequestHandler' ide req | Just customReq <- parseMaybe parseJSON req@@ -74,8 +90,8 @@ toJSON secs liftIO $ sleep secs return (Right Null)-testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do- let nfp = toNormalizedFilePath fp+testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do+ let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp let hiPath = hiDir $ hsc_dflags $ hscEnv sess return $ Right (toJSON hiPath)@@ -92,7 +108,36 @@ success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success return $ bimap mkResponseError toJSON res+testRequestHandler s GetBuildKeysBuilt = liftIO $ do+ keys <- getDatabaseKeys resultBuilt $ shakeDb s+ return $ Right $ toJSON $ map show keys+testRequestHandler s GetBuildKeysChanged = liftIO $ do+ keys <- getDatabaseKeys resultChanged $ shakeDb s+ return $ Right $ toJSON $ map show keys+testRequestHandler s GetBuildKeysVisited = liftIO $ do+ keys <- getDatabaseKeys resultVisited $ shakeDb s+ return $ Right $ toJSON $ map show keys+testRequestHandler s GetBuildEdgesCount = liftIO $ do+ count <- shakeGetBuildEdges $ shakeDb s+ return $ Right $ toJSON count+testRequestHandler s (GarbageCollectDirtyKeys parents age) = do+ res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents+ return $ Right $ toJSON $ map show res+testRequestHandler s GetStoredKeys = do+ keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s)+ return $ Right $ toJSON $ map show keys+testRequestHandler s GetFilesOfInterest = do+ ff <- liftIO $ getFilesOfInterest s+ return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff +getDatabaseKeys :: (Graph.Result -> Step)+ -> ShakeDatabase+ -> IO [Graph.Key]+getDatabaseKeys field db = do+ keys <- shakeGetCleanKeys db+ step <- shakeGetBuildStep db+ return [ k | (k, res) <- keys, field res == Step step]+ mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing @@ -105,7 +150,6 @@ parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp-parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -12,7 +12,6 @@ GlobalBindingTypeSigsResult (..), ) where -import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe)@@ -42,13 +41,6 @@ toNormalizedFilePath', uriToFilePath') import GHC.Generics (Generic)-import GhcPlugins (GlobalRdrEnv,- HscEnv (hsc_dflags), SDoc,- elemNameSet, getSrcSpan,- idName, mkRealSrcLoc,- realSrcLocSpan,- tidyOpenType)-import HscTypes (mkPrintUnqualified) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties import Ide.PluginUtils (mkLspCommand,@@ -73,16 +65,6 @@ TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit))-import Outputable (showSDocForUser)-import PatSyn (PatSyn, mkPatSyn,- patSynBuilder,- patSynFieldLabels,- patSynIsInfix,- patSynMatcher, patSynName,- patSynSig, pprPatSynType)-import TcEnv (tcInitTidyEnv)-import TcRnMonad (initTcWithGbl)-import TcRnTypes (TcGblEnv (..)) import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text@@ -185,7 +167,7 @@ , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr , -- not a top-level thing, to avoid duplication not $ name `elemNameSet` tcg_sigs- , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty+ , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault tcg_rdr_env) $ pprSigmaType ty , signature <- T.pack $ printName name <> " :: " <> tyMsg , startCharacter <- _character _start , startOfLine <- Position (_line _start) startCharacter@@ -229,11 +211,11 @@ -------------------------------------------------------------------------------- -showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String-showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv)+showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String+showDocRdrEnv env rdrEnv = showSDocForUser (hsc_dflags env) (mkPrintUnqualified (hsc_dflags env) rdrEnv) data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs- deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary)+ deriving (Generic, Show, Eq, Ord, Hashable, NFData) data GlobalBindingTypeSig = GlobalBindingTypeSig { gbName :: Name@@ -269,9 +251,8 @@ sigs = tcg_sigs gblEnv binds = collectHsBindsBinders $ tcg_binds gblEnv patSyns = tcg_patsyns gblEnv- dflags = hsc_dflags hsc rdrEnv = tcg_rdr_env gblEnv- showDoc = showDocRdrEnv dflags rdrEnv+ showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f bindToSig id = do
src/Development/IDE/Spans/AtPoint.hs view
@@ -30,25 +30,16 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.Spans.Common import Development.IDE.Types.Options --- GHC API imports-import FastString (unpackFS)-import IfaceType-import Name-import NameEnv-import Outputable hiding ((<>))-import SrcLoc-import TyCoRep hiding (FunTy)-import TyCon-import qualified Var- import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe+import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import Data.Maybe@@ -130,12 +121,12 @@ Just mod -> do -- Look for references (strictly in project files, not dependencies), -- excluding the files in the FOIs (since those are in foiRefs)- rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude+ rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe rowToLoc rows typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do- refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude+ refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe typeRowToLoc refs _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs@@ -208,10 +199,10 @@ :: IdeOptions -> HieAstResult -> DocAndKindMap- -> DynFlags+ -> HscEnv -> Position -> Maybe (Maybe Range, [T.Text])-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo+atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes)@@ -240,10 +231,10 @@ prettyPackageName n = do m <- nameModule_maybe n- let pid = moduleUnitId m- conf <- lookupPackage df pid- let pkgName = T.pack $ packageNameString conf- version = T.pack $ showVersion (packageVersion conf)+ let pid = moduleUnit m+ conf <- lookupUnit env pid+ let pkgName = T.pack $ unitPackageNameString conf+ version = T.pack $ showVersion (unitPackageVersion conf) pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types@@ -300,10 +291,10 @@ in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) namesInType :: Type -> [Name]-namesInType (TyVarTy n) = [Var.varName n]+namesInType (TyVarTy n) = [varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts-namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t+namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t namesInType (FunTy a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = []@@ -333,9 +324,9 @@ nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of- sp@(OldRealSrcSpan rsp)+ sp@(RealSrcSpan rsp _) -- Lookup in the db if we got a location in a boot file- | fs <- unpackFS (srcSpanFile rsp)+ | fs <- Util.unpackFS (srcSpanFile rsp) , not $ "boot" `isSuffixOf` fs -> do itExists <- liftIO $ doesFileExist fs@@ -353,7 +344,7 @@ -- In this case the interface files contain garbage source spans -- so we instead read the .hie files to get useful source spans. mod <- MaybeT $ return $ nameModule_maybe name- erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)+ erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) case erow of [] -> do -- If the lookup failed, try again without specifying a unit-id.@@ -398,7 +389,17 @@ pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->- case selectSmallestContaining (sp fs) ast of+ -- Since GHC 9.2:+ -- getAsts :: Map HiePath (HieAst a)+ -- type HiePath = LexialFastString+ --+ -- but before:+ -- getAsts :: Map HiePath (HieAst a)+ -- type HiePath = FastString+ --+ -- 'coerce' here to avoid an additional function for maintaining+ -- backwards compatibility.+ case selectSmallestContaining (sp $ coerce fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where
src/Development/IDE/Spans/Common.hs view
@@ -23,20 +23,13 @@ import qualified Data.Text as T import GHC.Generics -import ConLike-import DynFlags import GHC-import NameEnv-import Outputable hiding ((<>))-import Var -import Development.IDE.GHC.Compat (oldMkUserStyle,- oldRenderWithStyle)+import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H-import RdrName (rdrNameOcc) type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing@@ -48,11 +41,7 @@ showSD = T.pack . unsafePrintSDoc showNameWithoutUniques :: Outputable a => a -> T.Text-showNameWithoutUniques = T.pack . prettyprint- where- dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques- prettyprint x = oldRenderWithStyle dyn (ppr x) style- style = oldMkUserStyle dyn neverQualify AllTheWay+showNameWithoutUniques = T.pack . printNameWithoutUniques -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text@@ -66,9 +55,9 @@ safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id-safeTyThingId (AnId i) = Just i-safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike-safeTyThingId _ = Nothing+safeTyThingId (AnId i) = Just i+safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon)+safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc
src/Development/IDE/Spans/Documentation.hs view
@@ -13,6 +13,7 @@ ) where import Control.Monad+import Control.Monad.IO.Class import Control.Monad.Extra (findM) import Data.Either import Data.Foldable@@ -24,20 +25,13 @@ import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.Spans.Common import System.Directory import System.FilePath -import ExtractDocs-import FastString-import GhcMonad-import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri)-import Name-import NameEnv-import SrcLoc (RealLocated)-import TcRnTypes mkDocMap :: HscEnv@@ -86,12 +80,11 @@ -- Get the uris to the documentation and source html pages if they exist getUris name = do- let df = hsc_dflags env (docFu, srcFu) <- case nameModule_maybe name of Just mod -> liftIO $ do- doc <- toFileUriText $ lookupDocHtmlForModule df mod- src <- toFileUriText $ lookupSrcHtmlForModule df mod+ doc <- toFileUriText $ lookupDocHtmlForModule env mod+ src <- toFileUriText $ lookupSrcHtmlForModule env mod return (doc, src) Nothing -> pure (Nothing, Nothing) let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu@@ -183,28 +176,28 @@ -- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@-lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)+lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupDocHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html") -- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@-lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)+lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupSrcHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html") -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath)-lookupHtmlForModule mkDocPath df m = do+lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath)+lookupHtmlForModule mkDocPath hscEnv m = do -- try all directories- let mfs = fmap (concatMap go) (lookupHtmls df ui)+ let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) html <- findM doesFileExist (concat . maybeToList $ mfs) -- canonicalize located html to remove /../ indirection which can break some clients -- (vscode on Windows at least) traverse canonicalizePath html where go pkgDocDir = map (mkDocPath pkgDocDir) mns- ui = moduleUnitId m+ ui = moduleUnit m -- try to locate html file from most to least specific name e.g. -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.@@ -213,8 +206,8 @@ -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath]+lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls df ui = -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows- map takeDirectory . haddockInterfaces <$> lookupPackage df ui+ map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui
src/Development/IDE/Spans/LocalBindings.hs view
@@ -20,12 +20,13 @@ import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, getBindSiteFromContext, getScopeFromContext, identInfo,- identType)+ identType, NameEnv, nameEnvElts,+ unitNameEnv, isSystemName,+ RealSrcSpan, realSrcSpanStart,+ realSrcSpanEnd)+ import Development.IDE.GHC.Error import Development.IDE.Types.Location-import Name (isSystemName)-import NameEnv-import SrcLoc ------------------------------------------------------------------------------ -- | Turn a 'RealSrcSpan' into an 'Interval'.
src/Development/IDE/Types/Diagnostics.hs view
@@ -14,21 +14,22 @@ ideErrorWithSource, showDiagnostics, showDiagnosticsColored,- ) where+ IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq import Data.Maybe as Maybe import qualified Data.Text as T-import Data.Text.Prettyprint.Doc-import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color)-import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal-import Data.Text.Prettyprint.Doc.Render.Text+import Prettyprinter+import Prettyprinter.Render.Terminal (Color (..), color)+import qualified Prettyprinter.Render.Terminal as Terminal+import Prettyprinter.Render.Text import Language.LSP.Diagnostics import Language.LSP.Types as LSP (Diagnostic (..), DiagnosticSeverity (..), DiagnosticSource, List (..)) +import Data.ByteString (ByteString) import Development.IDE.Types.Location @@ -43,6 +44,9 @@ -- A rule on a file should only return diagnostics for that given file. It should -- not propagate diagnostic errors through multiple phases. type IdeResult v = ([FileDiagnostic], Maybe v)++-- | an IdeResult with a fingerprint+type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
src/Development/IDE/Types/Exports.hs view
@@ -7,10 +7,12 @@ createExportsMap, createExportsMapMg, createExportsMapTc,- buildModuleExportMapFrom-,createExportsMapHieDb,size) where+ buildModuleExportMapFrom,+ createExportsMapHieDb,+ size,+ updateExportsMapMg+ ) where -import Avail (AvailInfo (..)) import Control.DeepSeq (NFData (..)) import Control.Monad import Data.Bifunctor (Bifunctor (second))@@ -24,20 +26,28 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util-import FieldLabel (flSelector) import GHC.Generics (Generic)-import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb-import Name-import TcRnTypes (TcGblEnv (..)) data ExportsMap = ExportsMap- {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)- , getModuleExportsMap :: Map.HashMap ModuleNameText (HashSet IdentInfo)+ { getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)+ , getModuleExportsMap :: HashMap ModuleNameText (HashSet IdentInfo) } deriving (Show) +deleteEntriesForModule :: ModuleNameText -> ExportsMap -> ExportsMap+deleteEntriesForModule m em = ExportsMap+ { getExportsMap =+ let moduleIds = Map.lookupDefault mempty m (getModuleExportsMap em)+ in deleteAll+ (rendered <$> Set.toList moduleIds)+ (getExportsMap em)+ , getModuleExportsMap = Map.delete m (getModuleExportsMap em)+ }+ where+ deleteAll keys map = foldr Map.delete map keys+ size :: ExportsMap -> Int size = sum . map length . elems . getExportsMap @@ -81,8 +91,12 @@ occ = occName n mkIdentInfos :: Text -> AvailInfo -> [IdentInfo]-mkIdentInfos mod (Avail n) =+mkIdentInfos mod (AvailName n) = [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]+mkIdentInfos mod (AvailFL fl) =+ [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod]+ where+ n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent@@ -117,6 +131,15 @@ doOne mi = do let getModuleName = moduleName $ mg_module mi concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi)++updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap+updateExportsMapMg modGuts old =+ old' <> new+ where+ new = createExportsMapMg modGuts+ old' = deleteAll old (Map.keys $ getModuleExportsMap new)+ deleteAll = foldr deleteEntriesForModule+ createExportsMapTc :: [TcGblEnv] -> ExportsMap createExportsMapTc modIface = do
src/Development/IDE/Types/HscEnvEq.hs view
@@ -11,37 +11,33 @@ ) where -import Control.Concurrent.Async (Async, async, waitCatch)-import Control.Concurrent.Strict (modifyVar, newVar)-import Control.DeepSeq (force)-import Control.Exception (evaluate, mask, throwIO)-import Control.Monad.Extra (eitherM, join, mapMaybeM)+import Control.Concurrent.Async (Async, async, waitCatch)+import Control.Concurrent.Strict (modifyVar, newVar)+import Control.DeepSeq (force)+import Control.Exception (evaluate, mask, throwIO)+import Control.Monad.Extra (eitherM, join, mapMaybeM) import Control.Monad.IO.Class-import Data.Either (fromRight)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Unique+import Data.Either (fromRight)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Unique (Unique)+import qualified Data.Unique as Unique import Development.IDE.GHC.Compat-import Development.IDE.GHC.Error (catchSrcErrors)-import Development.IDE.GHC.Util (lookupPackageConfig)+import qualified Development.IDE.GHC.Compat.Util as Maybes+import Development.IDE.GHC.Error (catchSrcErrors)+import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes-import Development.IDE.Types.Exports (ExportsMap, createExportsMap)-import GhcPlugins (HscEnv (hsc_dflags))-import LoadIface (loadInterface)-import qualified Maybes--- import Module (InstalledUnitId)-import OpenTelemetry.Eventlog (withSpan)-import System.Directory (canonicalizePath)+import Development.IDE.Types.Exports (ExportsMap, createExportsMap)+import OpenTelemetry.Eventlog (withSpan)+import System.Directory (canonicalizePath) import System.FilePath-import TcRnMonad (WhereFrom (ImportByUser),- initIfaceLoad) -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv- , deps :: [(InstalledUnitId, DynFlags)]+ , deps :: [(UnitId, DynFlags)] -- ^ In memory components for this HscEnv -- This is only used at the moment for the import dirs in -- the DynFlags@@ -57,7 +53,7 @@ } -- | Wrap an 'HscEnv' into an 'HscEnvEq'.-newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath </>) hscEnv = removeImportPaths hscEnv0@@ -68,29 +64,29 @@ newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do let dflags = hsc_dflags hscEnv - envUnique <- newUnique+ envUnique <- Unique.newUnique -- it's very important to delay the package exports computation envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports- let pkgst = pkgState dflags- depends = explicitPackages pkgst+ let pkgst = unitState hscEnv+ depends = explicitUnits pkgst targets = [ (pkg, mn) | d <- depends , Just pkg <- [lookupPackageConfig d hscEnv]- , (mn, _) <- exposedModules pkg+ , (mn, _) <- unitExposedModules pkg ] doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface ""- (mkModule (packageConfigId pkg) mn)+ (mkModule (unitInfoId pkg) mn) (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing@@ -104,13 +100,13 @@ <$> catchSrcErrors dflags "listVisibleModuleNames"- (evaluate . force . Just $ oldListVisibleModuleNames dflags)+ (evaluate . force . Just $ listVisibleModuleNames hscEnv) return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEqPreserveImportPaths- :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq+ :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing -- | Unwrap the 'HscEnv' with the original import paths.@@ -118,15 +114,15 @@ hscEnvWithImportPaths :: HscEnvEq -> HscEnv hscEnvWithImportPaths HscEnvEq{..} | Just imps <- envImportPaths- = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = Set.toList imps}}+ = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv | otherwise = hscEnv removeImportPaths :: HscEnv -> HscEnv-removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}}+removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc instance Show HscEnvEq where- show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique)+ show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) instance Eq HscEnvEq where a == b = envUnique a == envUnique b@@ -134,16 +130,10 @@ instance NFData HscEnvEq where rnf (HscEnvEq a b c d _ _) = -- deliberately skip the package exports map and visible module names- rnf (hashUnique a) `seq` b `seq` c `seq` rnf d+ rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique---- Fake instance needed to persuade Shake to accept this type as a key.--- No harm done as ghcide never persists these keys currently-instance Binary HscEnvEq where- put _ = error "not really"- get = error "not really" -- | Given an action, produce a wrapped action that runs at most once. -- The action is run in an async so it won't be killed by async exceptions
src/Development/IDE/Types/Location.hs view
@@ -31,11 +31,17 @@ import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String++#if MIN_VERSION_ghc(9,0,0)+import GHC.Data.FastString+import GHC.Types.SrcLoc as GHC+#else import FastString+import SrcLoc as GHC+#endif import Language.LSP.Types (Location (..), Position (..), Range (..)) import qualified Language.LSP.Types as LSP-import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
src/Development/IDE/Types/Logger.hs view
@@ -33,6 +33,11 @@ -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} +instance Semigroup Logger where+ l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t++instance Monoid Logger where+ mempty = Logger $ \_ _ -> pure () logError :: Logger -> T.Text -> IO () logError x = logPriority x Error
src/Development/IDE/Types/Options.hs view
@@ -50,6 +50,8 @@ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations.+ , optMaxDirtyAge :: Int+ -- ^ Age (in # builds) at which we collect dirty keys , optLanguageSyntax :: String -- ^ the ```language to use , optNewColonConvention :: Bool@@ -137,12 +139,13 @@ ,optDefer = IdeDefer True ,optTesting = IdeTesting False ,optCheckProject = pure True- ,optCheckParents = pure CheckOnSaveAndClose+ ,optCheckParents = pure CheckOnSave ,optHaddockParse = HaddockParse ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit- ,optRunSubset = False+ ,optRunSubset = True+ ,optMaxDirtyAge = 100 } defaultSkipProgress :: Typeable a => a -> Bool@@ -160,10 +163,10 @@ -- | The set of options used to locate files belonging to external packages. data IdePkgLocationOptions = IdePkgLocationOptions- { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath)+ { optLocateHieFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the HIE file for the given module. The PackageConfig can be -- used to lookup settings like importDirs.- , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath)+ , optLocateSrcFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the source file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. For DAML, we place them in the package DB. -- For cabal this could point somewhere in ~/.cabal/packages.
src/Development/IDE/Types/Shake.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..),@@ -8,12 +9,11 @@ ValueWithDiagnostics (..), Values, Key (..),- SomeShakeValue, BadDependency (..), ShakeValue(..), currentValue, isBadDependency,- toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey)+ toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType) where import Control.DeepSeq@@ -22,18 +22,20 @@ import Data.Dynamic import Data.HashMap.Strict import Data.Hashable-import Data.Typeable+import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping-import Development.IDE.Graph (RuleResult,- ShakeException (shakeExceptionInner))+import Development.IDE.Graph (Key (..), RuleResult) import qualified Development.IDE.Graph as Shake-import Development.IDE.Graph.Classes-import Development.IDE.Graph.Database (SomeShakeValue (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Types+import Type.Reflection (SomeTypeRep (SomeTypeRep),+ pattern App, pattern Con,+ typeOf, typeRep,+ typeRepTyCon)+import Unsafe.Coerce (unsafeCoerce) data Value v = Succeeded TextDocumentVersion v@@ -54,27 +56,7 @@ = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics-type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics---- | Key type-data Key = forall k . (Typeable k, Hashable k, Eq k, NFData k, Show k) => Key k--instance Show Key where- show (Key k) = show k--instance Eq Key where- Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'- | otherwise = False--instance Hashable Key where- hashWithSalt salt (Key key) = hashWithSalt salt key--instance Binary Key where- get = error "not really"- put _ = error "not really"--instance NFData Key where- rnf (Key k) = rnf k+type Values = HashMap Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action@@ -83,28 +65,30 @@ isBadDependency :: SomeException -> Bool isBadDependency x- | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x | Just (_ :: BadDependency) <- fromException x = True | otherwise = False +toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key+toKey = (Key.) . curry Q -toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> SomeShakeValue-toKey = (SomeShakeValue .) . curry Q+fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath)+fromKey (Key k)+ | Just (Q (k', f)) <- cast k = Just (k', f)+ | otherwise = Nothing -toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, Binary k, NFData k) => k -> SomeShakeValue-toNoFileKey k = toKey k emptyFilePath+-- | fromKeyType (Q (k,f)) = (typeOf k, f)+fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath)+fromKeyType (Key k) = case typeOf k of+ App (Con tc) a | tc == typeRepTyCon (typeRep @Q)+ -> case unsafeCoerce k of+ Q (_ :: (), f) -> Just (SomeTypeRep a, f)+ _ -> Nothing +toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key+toNoFileKey k = Key $ Q (k, emptyFilePath)+ newtype Q k = Q (k, NormalizedFilePath) deriving newtype (Eq, Hashable, NFData)--instance Binary k => Binary (Q k) where- put (Q (k, fp)) = put (k, fp)- get = do- (k, fp) <- get- -- The `get` implementation of NormalizedFilePath- -- does not handle empty file paths so we- -- need to handle this ourselves here.- pure (Q (k, toNormalizedFilePath' fp)) instance Show k => Show (Q k) where show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
src/Text/Fuzzy/Parallel.hs view
@@ -2,9 +2,9 @@ module Text.Fuzzy.Parallel ( filter, simpleFilter,+ Scored(..), -- reexports- Fuzzy(..),- match+ Fuzzy, ) where import Control.Monad.ST (runST)@@ -15,10 +15,59 @@ import qualified Data.Vector as V -- need to use a stable sort import Data.Bifunctor (second)-import Data.Maybe (fromJust)+import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import qualified Data.Monoid.Textual as T import Prelude hiding (filter)-import Text.Fuzzy (Fuzzy (..), match)+import Text.Fuzzy (Fuzzy (..)) +data Scored a = Scored {score_ :: !Int, original:: !a}+ deriving (Functor,Show)++-- | Returns the rendered output and the+-- matching score for a pattern and a text.+-- Two examples are given below:+--+-- >>> match "fnt" "infinite" "" "" id True+-- Just ("infinite",3)+--+-- >>> match "hsk" ("Haskell",1995) "<" ">" fst False+-- Just ("<h>a<s><k>ell",5)+--+{-# INLINABLE match #-}++match :: (T.TextualMonoid s)+ => s -- ^ Pattern in lowercase except for first character+ -> t -- ^ The value containing the text to search in.+ -> s -- ^ The text to add before each match.+ -> s -- ^ The text to add after each match.+ -> (t -> s) -- ^ The function to extract the text from the container.+ -> Maybe (Fuzzy t s) -- ^ The original value, rendered string and score.+match pattern t pre post extract =+ if null pat then Just (Fuzzy t result totalScore) else Nothing+ where+ null :: (T.TextualMonoid s) => s -> Bool+ null = not . T.any (const True)++ s = extract t+ (totalScore, _currScore, result, pat, _) =+ T.foldl'+ undefined+ (\(tot, cur, res, pat, isFirst) c ->+ case T.splitCharacterPrefix pat of+ Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst)+ Just (x, xs) ->+ -- the case of the first character has to match+ -- otherwise use lower case since the pattern is assumed lower+ let !c' = if isFirst then c else toLower c in+ if x == c' then+ let cur' = cur * 2 + 1 in+ (tot + cur', cur', res <> pre <> T.singleton c <> post, xs, False)+ else (tot, 0, res <> T.singleton c, pat, isFirst)+ ) ( 0+ , 1 -- matching at the start gives a bonus (cur = 1)+ , mempty, pattern, True) s+ -- | The function to filter a list of values by fuzzy search on the text extracted from them. filter :: (TextualMonoid s) => Int -- ^ Chunk size. 1000 works well.@@ -28,15 +77,20 @@ -> s -- ^ The text to add before each match. -> s -- ^ The text to add after each match. -> (t -> s) -- ^ The function to extract the text from the container.- -> Bool -- ^ Case sensitivity.- -> [Fuzzy t s] -- ^ The list of results, sorted, highest score first.-filter chunkSize maxRes pattern ts pre post extract caseSen = runST $ do+ -> [Scored t] -- ^ The list of results, sorted, highest score first.+filter chunkSize maxRes pattern ts pre post extract = runST $ do let v = V.mapMaybe id- (V.map (\t -> match pattern t pre post extract caseSen) (V.fromList ts)+ (V.map (\t -> match pattern' t pre post extract) (V.fromList ts) `using` parVectorChunk chunkSize (evalTraversable forceScore))- perfectScore = score $ fromJust $ match pattern pattern "" "" id False+ perfectScore = score $ fromMaybe (error $ T.toString undefined pattern) $+ match pattern' pattern' "" "" id return $ partialSortByAscScore maxRes perfectScore v+ where+ -- Preserve case for the first character, make all others lowercase+ pattern' = case T.splitCharacterPrefix pattern of+ Just (c, rest) -> T.singleton c <> T.map toLower rest+ _ -> pattern -- | Return all elements of the list that have a fuzzy -- match against the pattern. Runs with default settings where@@ -50,9 +104,9 @@ -> Int -- ^ Max. number of results wanted -> s -- ^ Pattern to look for. -> [s] -- ^ List of texts to check.- -> [s] -- ^ The ones that match.+ -> [Scored s] -- ^ The ones that match. simpleFilter chunk maxRes pattern xs =- map original $ filter chunk maxRes pattern xs mempty mempty id False+ filter chunk maxRes pattern xs mempty mempty id -------------------------------------------------------------------------------- @@ -102,7 +156,7 @@ => Int -- ^ Number of items needed -> Int -- ^ Value of a perfect score -> Vector (Fuzzy t s)- -> [Fuzzy t s]+ -> [Scored t] partialSortByAscScore wantedCount perfectScore v = loop 0 (SortState minBound perfectScore 0) [] where l = V.length v loop index st@SortState{..} acc@@ -115,11 +169,14 @@ | otherwise = case v!index of x | score x == scoreWanted- -> loop (index+1) st{foundCount = foundCount+1} (x:acc)+ -> loop (index+1) st{foundCount = foundCount+1} (toScored x:acc) | score x < scoreWanted && score x > bestScoreSeen -> loop (index+1) st{bestScoreSeen = score x} acc | otherwise -> loop (index+1) st acc++toScored :: TextualMonoid s => Fuzzy t s -> Scored t+toScored Fuzzy{..} = Scored score original data SortState a = SortState { bestScoreSeen :: !Int
+ test/data/hiding/HideFunctionWithoutLocal.expected.hs view
@@ -0,0 +1,14 @@+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 view
@@ -0,0 +1,13 @@+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/HidePreludeLocalInfix.expected.hs view
@@ -0,0 +1,9 @@+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 view
@@ -0,0 +1,8 @@+module HidePreludeLocalInfix where++infixed xs ys = xs ++ ys++data Vec a++(++) :: Vec a -> Vec a -> Vec a+(++) = undefined
test/exe/Main.hs view
@@ -21,7 +21,6 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (fromJSON, toJSON) import qualified Data.Aeson as A-import qualified Data.Binary as Binary import Data.Default import Data.Foldable import Data.List.Extra@@ -34,7 +33,6 @@ fromCurrent, positionResultToMaybe, toCurrent)-import Development.IDE.Core.Shake (Q (..)) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Util@@ -52,10 +50,14 @@ expectNoMoreDiagnostics, flushMessages, standardizeQuotes,- waitForAction)+ getInterfaceFilesDir,+ waitForAction,+ getStoredKeys,+ waitForTypecheck, waitForGC) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location+import qualified Language.LSP.Types.Lens as Lens (label) import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench import Ide.Plugin.Config@@ -96,7 +98,7 @@ 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, GetInterfaceFilesDir),+import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) import Ide.PluginUtils (pluginDescToIdePlugins)@@ -113,16 +115,32 @@ import Text.Printf (printf) import Text.Regex.TDFA ((=~)) +-- | 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 -- We mess with env vars so run single-threaded.@@ -162,6 +180,7 @@ , clientSettingsTest , codeActionHelperFunctionTests , referenceTests+ , garbageCollectionTests ] initializeResponseTests :: TestTree@@ -391,6 +410,30 @@ , [(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+ [ ( "ModuleA.hs"+ , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+ )+ , ( "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"@@ -650,9 +693,9 @@ expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] , testGroup "Cancellation"- [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse noTc- , cancellationTestGroup "edit import" editImport noDepends noSession yesParse noTc- , cancellationTestGroup "edit body" editBody yesDepends yesSession yesParse yesTc+ [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc+ , cancellationTestGroup "edit import" editImport noSession yesParse noTc+ , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc ] ] where@@ -666,17 +709,14 @@ noParse = False yesParse = True - noDepends = False- yesDepends = True- noSession = False yesSession = True noTc = False yesTc = True -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree-cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name+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)@@ -685,7 +725,6 @@ , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) -- getLocatedImports never fails , cancellationTemplate edits $ Just ("GetLocatedImports", True)- , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome) , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)@@ -708,7 +747,7 @@ -- Now we edit the document and wait for the given key (if any) changeDoc doc [edit] whenJust mbKey $ \(key, expectedResult) -> do- Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc+ WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc liftIO $ ideResultSuccess @?= expectedResult -- The 2nd edit cancels the active session and unbreaks the file@@ -722,7 +761,7 @@ runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s typeCheck doc = do- Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+ 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@@ -769,25 +808,51 @@ watchedFilesTests :: TestTree watchedFilesTests = testGroup "watched files"- [ 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+ [ 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+ -- 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+ , 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+ -- 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+ -- 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@@ -1758,10 +1823,20 @@ 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"@@ -3788,9 +3863,6 @@ pluginSimpleTests :: TestTree pluginSimpleTests = ignoreInWindowsForGHC88And810 $-#if __GLASGOW_HASKELL__ == 810 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 5- expectFailBecause "known broken for ghc 8.10.5 (see GHC #19763)" $-#endif testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir </> "KnownNat.hs") "haskell" liftIO $ writeFile (dir</>"hie.yaml")@@ -4042,8 +4114,10 @@ -- modify b too let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource']+ waitForProgressBegin+ waitForAllProgressDone - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])]+ expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] closeDoc adoc closeDoc bdoc@@ -4055,7 +4129,8 @@ completionTests :: TestTree completionTests = testGroup "completion"- [ testGroup "non local" nonLocalCompletionTests+ [+ testGroup "non local" nonLocalCompletionTests , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests , testGroup "package" packageCompletionTests@@ -4136,15 +4211,13 @@ "variable" ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] (Position 0 8)- [("xxx", CiFunction, "xxx", True, True, Nothing),- ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)+ [("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),- ("XxxCon", CiConstructor, "XxxCon", False, True, Nothing)+ [("xxx", CiFunction, "xxx", True, True, Nothing) ], completionTest "class method"@@ -4246,7 +4319,25 @@ (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]@@ -4258,17 +4349,15 @@ [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)], completionTest "constructor"- ["module A where", "f = Tru"]- (Position 1 7)- [ ("True", CiConstructor, "True ", True, True, Nothing),- ("truncate", CiFunction, "truncate ${1:a}", True, True, Nothing)+ ["{-# 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 :: Bo", "f = True"]- (Position 2 7)- [ ("Bounded", CiInterface, "Bounded ${1:(*)}", True, True, Nothing),- ("Bool", CiStruct, "Bool ", True, True, Nothing)+ ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]+ (Position 2 8)+ [ ("Bool", CiStruct, "Bool ", True, True, Nothing) ], completionTest "qualified"@@ -4278,8 +4367,8 @@ ], completionTest "duplicate import"- ["module A where", "import Data.List", "import Data.List", "f = perm"]- (Position 3 8)+ ["module A where", "import Data.List", "import Data.List", "f = permu"]+ (Position 3 9) [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing) ], completionTest@@ -4455,7 +4544,7 @@ _ <- waitForDiagnostics compls <- getCompletions docA $ Position 2 4 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]- liftIO $ take 2 compls' @?= ["member ${1:Foo}", "member ${1:Bar}"],+ liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines@@ -4550,7 +4639,7 @@ , _label == "fromList" ] liftIO $ take 3 compls' @?=- map Just ["fromList ${1:([Item l])}", "fromList", "fromList"]+ map Just ["fromList ${1:([Item l])}"] , testGroup "auto import snippets" [ completionCommandTest "import Data.Sequence"@@ -4590,7 +4679,58 @@ <- compls , _label == "anidentifier" ]- liftIO $ compls' @?= ["Defined in 'A"]+ 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" ] highlightTests :: TestTree@@ -4980,7 +5120,7 @@ liftIO $ writeFile hiePath hieContents let aPath = dir </> "A.hs" doc <- createDoc aPath "haskell" "main = return ()"- Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+ WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess -- Fix the cradle and typecheck again@@ -4988,17 +5128,8 @@ liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [FileEvent (filePathToUri $ dir </> "hie.yaml") FcChanged ]- -- Force a session restart by making an edit, just to dirty the typecheck node- changeDoc- doc- [ TextDocumentContentChangeEvent- { _range = Just Range {_start = Position 0 0, _end = Position 0 0},- _rangeLength = Nothing,- _text = "\n"- }- ] - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+ WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess @@ -5077,11 +5208,11 @@ bPath = dir </> "b/B.hs" aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource- Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc+ WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc liftIO $ assertBool "A should typecheck" ideResultSuccess bSource <- liftIO $ readFileUtf8 bPath bdoc <- createDoc bPath "haskell" bSource- Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc+ 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@@ -5203,14 +5334,9 @@ -- Check that we wrote the interfaces for B when we saved- let m = SCustomMethod "test"- lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath- res <- skipManyTill anyMessage $ responseForId m lid- liftIO $ case res of- ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do- hi_exists <- doesFileExist $ hidir </> "B.hi"- assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists- _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res+ 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" ]@@ -5748,8 +5874,6 @@ , testCase "from empty path URI" $ do let uri = Uri "file://" uriToFilePath' uri @?= Just ""- , testCase "Key with empty file path roundtrips via Binary" $- Binary.decode (Binary.encode (Q ((), emptyFilePath))) @?= Q ((), emptyFilePath) , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do let diag = ("", Diagnostics.ShowDiag, Diagnostic { _range = Range@@ -5779,7 +5903,7 @@ | i <- [(1::Int)..20] ] ++ Ghcide.descriptors - testIde def{IDE.argsHlsPlugins = plugins} $ do+ testIde IDE.testing{IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef@@ -5792,6 +5916,78 @@ assertBool msg (resolution_us <= 1000) , Progress.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"
test/src/Development/IDE/Test.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} module Development.IDE.Test@@ -20,7 +21,15 @@ , standardizeQuotes , flushMessages , waitForAction- ) where+ , getInterfaceFilesDir+ , garbageCollectDirtyKeys+ , getFilesOfInterest+ , waitForTypecheck+ , waitForBuildQueue+ , getStoredKeys+ , waitForCustomMessage+ , waitForGC+ ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount) where import Control.Applicative.Combinators import Control.Lens hiding (List)@@ -30,10 +39,13 @@ import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust)+import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..),- WaitForIdeRuleResult)+ WaitForIdeRuleResult,+ ideResultSuccess) import Development.IDE.Test.Diagnostic+import Ide.Plugin.Config (CheckParents) import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types hiding@@ -169,13 +181,68 @@ diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult)-waitForAction key TextDocumentIdentifier{_uri} = do+tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)+tryCallTestPlugin cmd = do let cm = SCustomMethod "test"- waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)+ waitId <- sendRequest cm (A.toJSON cmd) ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId- return $ do- e <- _result- case A.fromJSON e of- A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing- A.Success a -> pure a+ return $ case _result of+ Left e -> Left e+ Right json -> case A.fromJSON json of+ A.Success a -> Right a+ A.Error e -> error e++callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b+callTestPlugin cmd = do+ res <- tryCallTestPlugin cmd+ case res of+ Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err+ Right a -> pure a+++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++getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath+getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri)++garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]+garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age)++getStoredKeys :: Session [Text]+getStoredKeys = callTestPlugin GetStoredKeys++waitForTypecheck :: TextDocumentIdentifier -> Session Bool+waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid++waitForBuildQueue :: Session ()+waitForBuildQueue = callTestPlugin WaitForShakeQueue++getFilesOfInterest :: Session [FilePath]+getFilesOfInterest = callTestPlugin GetFilesOfInterest++waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res+waitForCustomMessage msg pred =+ skipManyTill anyMessage $ satisfyMaybe $ \case+ FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value})+ | lbl == msg -> pred value+ _ -> Nothing++waitForGC :: Session [T.Text]+waitForGC = waitForCustomMessage "ghcide/GC" $ \v ->+ case A.fromJSON v of+ A.Success x -> Just x+ _ -> Nothing