diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -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 {..} diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -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") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -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 } } diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -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 diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -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 = diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -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 diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -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 "") 1 1 +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 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 diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -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 diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -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 diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -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 diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -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 diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -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"))) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -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: + -- * -> + -- * 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 diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -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 diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -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 + diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -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 diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/CPP.hs b/src/Development/IDE/GHC/Compat/CPP.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/CPP.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -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 + diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -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 diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -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 diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -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." diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -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 diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -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 diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -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 = "" 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 diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -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} diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -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 diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -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'} diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -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 diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -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 -------------------------------------------------------------------- diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -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 diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -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 diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -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 "" _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 diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -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 diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -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. + + 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 = diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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' diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -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 diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -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) diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -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 diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -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 diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -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 diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -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'. diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -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) diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -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 diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -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 diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -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 diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -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 diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -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. diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -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 diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -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 ("aell",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 diff --git a/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/test/data/hiding/HideFunctionWithoutLocal.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunctionWithoutLocal.expected.hs @@ -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 diff --git a/test/data/hiding/HideFunctionWithoutLocal.hs b/test/data/hiding/HideFunctionWithoutLocal.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HideFunctionWithoutLocal.hs @@ -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 diff --git a/test/data/hiding/HidePreludeLocalInfix.expected.hs b/test/data/hiding/HidePreludeLocalInfix.expected.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeLocalInfix.expected.hs @@ -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 diff --git a/test/data/hiding/HidePreludeLocalInfix.hs b/test/data/hiding/HidePreludeLocalInfix.hs new file mode 100644 --- /dev/null +++ b/test/data/hiding/HidePreludeLocalInfix.hs @@ -0,0 +1,8 @@ +module HidePreludeLocalInfix where + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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" diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -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