diff --git a/bench/hist/Main.hs b/bench/hist/Main.hs --- a/bench/hist/Main.hs +++ b/bench/hist/Main.hs @@ -57,7 +57,6 @@ import System.Console.GetOpt import System.FilePath - configPath :: FilePath configPath = "bench/config.yaml" @@ -88,6 +87,8 @@ ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide where projectDepends = do + need . map ("../hls-graph/src" ) =<< getDirectoryFiles "../hls-graph/src" ["//*.hs"] + need . map ("../hls-plugin-api/src" ) =<< getDirectoryFiles "../hls-plugin-api/src" ["//*.hs"] need . map ("src" ) =<< getDirectoryFiles "src" ["//*.hs"] need . map ("session-loader" ) =<< getDirectoryFiles "session-loader" ["//*.hs"] need =<< getDirectoryFiles "." ["*.cabal"] diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -37,7 +37,9 @@ getBuildKeysBuilt, getBuildKeysChanged, getBuildKeysVisited, - getStoredKeys) + getStoredKeys, + getRebuildsCount, + ) import Development.IDE.Test.Diagnostic import Development.Shake (CmdOption (Cwd, FileStdout), cmd_) @@ -329,12 +331,15 @@ , "setup" , "userTime" , "delayedTime" + , "firstBuildTime" + , "averageTimePerResponse" , "totalTime" , "buildRulesBuilt" , "buildRulesChanged" , "buildRulesVisited" , "buildRulesTotal" , "buildEdges" + , "ghcRebuilds" ] rows = [ [ name, @@ -344,15 +349,21 @@ show runSetup', show userWaits, show delayedWork, + show $ firstResponse+firstResponseDelayed, + -- Exclude first response as it has a lot of setup time included + -- Assume that number of requests = number of modules * number of samples + show ((userWaits - firstResponse)/((fromIntegral samples - 1)*modules)), show runExperiment, show rulesBuilt, show rulesChanged, show rulesVisited, show rulesTotal, - show edgesTotal + show edgesTotal, + show rebuildsTotal ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup + modules = fromIntegral $ length $ exampleModules $ example ?config ] csv = unlines $ map (intercalate ", ") (headers : rows) writeFile (outputCSV ?config) csv @@ -369,12 +380,14 @@ showDuration runSetup', showDuration userWaits, showDuration delayedWork, + showDuration firstResponse, showDuration runExperiment, show rulesBuilt, show rulesChanged, show rulesVisited, show rulesTotal, - show edgesTotal + show edgesTotal, + show rebuildsTotal ] | (Bench {name, samples}, BenchRun {..}) <- results, let runSetup' = if runSetup < 0.01 then 0 else runSetup @@ -420,16 +433,19 @@ runExperiment :: !Seconds, userWaits :: !Seconds, delayedWork :: !Seconds, + firstResponse :: !Seconds, + firstResponseDelayed :: !Seconds, rulesBuilt :: !Int, rulesChanged :: !Int, rulesVisited :: !Int, rulesTotal :: !Int, edgesTotal :: !Int, + rebuildsTotal :: !Int, success :: !Bool } badRun :: BenchRun -badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 False +badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False waitForProgressStart :: Session () waitForProgressStart = void $ do @@ -482,8 +498,8 @@ liftIO $ output $ "Running " <> name <> " benchmark" (runSetup, ()) <- duration $ benchSetup docs - let loop !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork) - loop !userWaits !delayedWork n = do + let loop' (Just timeForFirstResponse) !userWaits !delayedWork 0 = return $ Just (userWaits, delayedWork, timeForFirstResponse) + loop' timeForFirstResponse !userWaits !delayedWork n = do (t, res) <- duration $ experiment docs if not res then return Nothing @@ -491,17 +507,19 @@ output (showDuration t) -- Wait for the delayed actions to finish td <- waitForBuildQueue - loop (userWaits+t) (delayedWork+td) (n -1) + loop' (timeForFirstResponse <|> (Just (t,td))) (userWaits+t) (delayedWork+td) (n -1) + loop = loop' Nothing (runExperiment, result) <- duration $ loop 0 0 samples let success = isJust result - (userWaits, delayedWork) = fromMaybe (0,0) result + (userWaits, delayedWork, (firstResponse, firstResponseDelayed)) = fromMaybe (0,0,(0,0)) result rulesTotal <- length <$> getStoredKeys rulesBuilt <- either (const 0) length <$> getBuildKeysBuilt rulesChanged <- either (const 0) length <$> getBuildKeysChanged rulesVisited <- either (const 0) length <$> getBuildKeysVisited edgesTotal <- fromRight 0 <$> getBuildEdgesCount + rebuildsTotal <- fromRight 0 <$> getRebuildsCount return BenchRun {..} diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -8,20 +8,34 @@ import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless) +import Control.Monad.IO.Class (liftIO) import Data.Default (def) +import Data.Function ((&)) import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (Priority (Debug, Info), - action) +import Development.IDE (action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Tracing (withTelemetryLogger) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) -import qualified Development.IDE.Main as Main +import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Types.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug, Info, Error), + Recorder (Recorder), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options +import GHC.Stack (emptyCallStack) +import Language.LSP.Server as LSP +import Language.LSP.Types as LSP import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) import Paths_ghcide (version) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) @@ -29,6 +43,17 @@ import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +data Log + = LogIDEMain IDEMain.Log + | LogRules Rules.Log + | LogGhcIde GhcIde.Log + +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + LogRules log -> pretty log + LogGhcIde log -> pretty log + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -42,7 +67,12 @@ main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do - let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors + -- stderr recorder just for plugin cli commands + pluginCliRecorder <- + cmapWithPrio pretty + <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info + + let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work Arguments{..} <- getArguments hlsPlugins @@ -55,30 +85,59 @@ Nothing -> IO.getCurrentDirectory Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory - let logPriority = if argsVerbose then Debug else Info - arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority + let minPriority = if argsVerbose then Debug else Info - Main.defaultMain arguments - { Main.argsProjectRoot = Just argsCwd - , Main.argCommand = argsCommand - ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority - ,Main.argsRules = do + (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder + (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder + -- This plugin just installs a handler for the `initialized` notification, which then + -- picks up the LSP environment and feeds it to our recorders + let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do + env <- LSP.getLspEnv + liftIO $ (cb1 <> cb2) env + } + + let docWithFilteredPriorityRecorder = + (docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <> + (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <> + (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + & cfilter (\WithPriority{ priority } -> priority >= Error)) + + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m)) + + let recorder = docWithFilteredPriorityRecorder + & cmapWithPrio pretty + + let arguments = + if argsTesting + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger + + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDEMain.argsProjectRoot = Just argsCwd + , IDEMain.argCommand = argsCommand + , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger + , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] + + , IDEMain.argsRules = do -- install the main and ghcide-plugin rules - mainRule def + mainRule (cmapWithPrio LogRules recorder) 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.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) + , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) - ,Main.argsIdeOptions = \config sessionLoader -> - let defOptions = Main.argsIdeOptions arguments config sessionLoader + , IDEMain.argsIdeOptions = \config sessionLoader -> + let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader in defOptions { optShakeProfiling = argsShakeProfiling , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling - , 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.6.0.1 +version: 1.7.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 +tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.6 || == 8.10.7 || == 9.0.1 || == 9.0.2 || == 9.2.1 || == 9.2.2 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -50,7 +50,7 @@ dlist, exceptions, extra >= 1.7.4, - fuzzy, + enummapset, filepath, fingertree, focus, @@ -60,7 +60,7 @@ haddock-library >= 1.8 && < 1.11, hashable, hie-compat ^>= 0.2.0.0, - hls-plugin-api ^>= 1.2.0.2 || ^>= 1.3, + hls-plugin-api ^>= 1.4, lens, list-t, hiedb == 0.4.1.*, @@ -79,7 +79,7 @@ rope-utf16-splay, safe, safe-exceptions, - hls-graph ^>= 1.6, + hls-graph ^>= 1.7, sorted-list, sqlite-simple, stm, @@ -105,7 +105,7 @@ ghc-check >=0.5.0.4, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios >= 0.8 && < 0.9.0, + hie-bios ^>= 0.9.1, implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, base16-bytestring >=0.1.1 && <1.1 if os(windows) @@ -148,6 +148,7 @@ Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer Development.IDE.Core.FileStore + Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping @@ -205,6 +206,7 @@ Development.IDE.Plugin.HLS.GhcIde Development.IDE.Plugin.Test Development.IDE.Plugin.TypeLenses + Text.Fuzzy.Parallel other-modules: Development.IDE.Core.FileExists @@ -216,7 +218,6 @@ Development.IDE.Plugin.Completions.Logic Development.IDE.Session.VersionCheck Development.IDE.Types.Action - Text.Fuzzy.Parallel ghc-options: -Wall @@ -371,6 +372,7 @@ directory, extra, filepath, + fuzzy, -------------------------------------------------------------- -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas -- which require depending on ghc. So the tests need to depend @@ -385,11 +387,13 @@ lsp, lsp-types, hls-plugin-api, - network-uri, lens, list-t, lsp-test ^>= 0.14, + monoid-subclasses, + network-uri, optparse-applicative, + parallel, process, QuickCheck, quickcheck-instances, @@ -410,6 +414,7 @@ tasty-rerun, text, unordered-containers, + vector, if (impl(ghc >= 8.6) && impl(ghc < 9.2)) build-depends: record-dot-preprocessor, @@ -423,6 +428,7 @@ Development.IDE.Test.Runfiles Experiments Experiments.Types + FuzzySearch Progress HieDbRetry default-extensions: 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 @@ -1,5 +1,6 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -14,6 +15,7 @@ ,runWithDb ,retryOnSqliteBusy ,retryOnException + ,Log(..) ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -27,7 +29,7 @@ import Control.Monad.Extra import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -44,11 +46,12 @@ import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (withHieDb) +import Development.IDE.Core.Shake hiding (Log, Priority, + withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, - Var) + Var, Warning) import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) @@ -60,7 +63,11 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + logWith, nest, vcat, + viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -72,7 +79,6 @@ import System.Directory import qualified System.Directory.Extra as IO import System.FilePath -import System.IO import System.Info import Control.Applicative (Alternative ((<|>))) @@ -82,6 +88,8 @@ readTVar, writeTVar) import Control.Concurrent.STM.TQueue import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) @@ -91,7 +99,96 @@ import HieDb.Utils import System.Random (RandomGen) import qualified System.Random as Random +import Control.Monad.IO.Unlift (MonadUnliftIO) +data Log + = LogSettingInitialDynFlags + | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) + | LogGetInitialGhcLibDirDefaultCradleNone + | LogHieDbRetry !Int !Int !Int !SomeException + | LogHieDbRetriesExhausted !Int !Int !Int !SomeException + | LogHieDbWriterThreadSQLiteError !SQLError + | LogHieDbWriterThreadException !SomeException + | LogInterfaceFilesCacheDir !FilePath + | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) + | LogMakingNewHscEnv ![UnitId] + | LogDLLLoadError !String + | LogCradlePath !FilePath + | LogCradleNotFound !FilePath + | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) + | LogCradle !(Cradle Void) + | LogNoneCradleFound FilePath + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogNoneCradleFound path -> + "None cradle found for" <+> pretty path <+> ", ignoring the file" + LogSettingInitialDynFlags -> + "Setting initial dynflags..." + LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> + nest 2 $ + vcat + [ "Couldn't load cradle for ghc libdir." + , "Cradle error:" <+> viaShow cradleError + , "Root dir path:" <+> pretty rootDirPath + , "hie.yaml path:" <+> pretty hieYamlPath + , "Cradle:" <+> viaShow cradle ] + LogGetInitialGhcLibDirDefaultCradleNone -> + "Couldn't load cradle. Cradle not found." + LogHieDbRetry delay maxDelay maxRetryCount e -> + nest 2 $ + vcat + [ "Retrying hiedb action..." + , "delay:" <+> pretty delay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty maxRetryCount + , "SQLite error:" <+> pretty (displayException e) ] + LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e -> + nest 2 $ + vcat + [ "Retries exhausted for hiedb action." + , "base delay:" <+> pretty baseDelay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty maxRetryCount + , "Exception:" <+> pretty (displayException e) ] + LogHieDbWriterThreadSQLiteError e -> + nest 2 $ + vcat + [ "HieDb writer thread SQLite error:" + , pretty (displayException e) ] + LogHieDbWriterThreadException e -> + nest 2 $ + vcat + [ "HieDb writer thread exception:" + , pretty (displayException e) ] + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogKnownFilesUpdated targetToPathsMap -> + nest 2 $ + vcat + [ "Known files updated:" + , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap + ] + LogMakingNewHscEnv inPlaceUnitIds -> + "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) + LogDLLLoadError errorString -> + "Error dynamically loading libm.so.6:" <+> pretty errorString + LogCradlePath path -> + "Cradle path:" <+> pretty path + LogCradleNotFound path -> + vcat + [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." + , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)." + , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ] + LogSessionLoadingResult e -> + "Session loading result:" <+> viaShow e + LogCradle cradle -> + "Cradle:" <+> viaShow cradle + LogNewComponentCache componentCache -> + "New component cache HscEnvEq:" <+> viaShow componentCache + -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1" @@ -110,7 +207,7 @@ -- or 'Nothing' to respect the cradle setting , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: Logger -> FilePath -> IO (Maybe LibDir) + , getInitialGhcLibDir :: Recorder (WithPriority Log) -> 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, @@ -119,7 +216,7 @@ } instance Default SessionLoadingOptions where - def = SessionLoadingOptions + def = SessionLoadingOptions {findCradle = HieBios.findCradle ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault @@ -148,26 +245,27 @@ Just yaml -> HieBios.loadCradle yaml Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir) -getInitialGhcLibDirDefault logger rootDir = do +getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) +getInitialGhcLibDirDefault recorder rootDir = do + let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir - logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle) + log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do - hPutStrLn stderr "Couldn't load cradle (CradleNone)" + log Warning LogGetInitialGhcLibDirDefaultCradleNone pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) -setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do - libdir <- getInitialGhcLibDir logger rootDir +setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir recorder rootDir dynFlags <- mapM dynFlagsForPrinting libdir + logWith recorder Debug LogSettingInitialDynFlags mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -180,14 +278,14 @@ retryOnException :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just - -> Logger + -> Recorder (WithPriority Log) -> Int -- ^ maximum backoff delay in microseconds -> Int -- ^ base backoff delay in microseconds -> Int -- ^ maximum number of times to retry -> g -- ^ random number generator -> m a -- ^ action that may throw exception -> m a -retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do +retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do result <- tryJust exceptionPred action case result of Left e @@ -197,30 +295,18 @@ let (delay, newRng) = Random.randomR (0, newBaseDelay) rng let newMaxRetryCount = maxRetryCount - 1 liftIO $ do - logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e + log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) threadDelay delay - retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action + retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action | otherwise -> do liftIO $ do - logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e + log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) throwIO e Right b -> pure b where - -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... } - makeLogMsgComponentsText delay newMaxRetryCount e = - let - logMsgComponents = - [ either - (("base delay: " <>) . T.pack . show) - (("delay: " <>) . T.pack . show) - delay - , "maximumDelay: " <> T.pack (show maxDelay) - , "maxRetryCount: " <> T.pack (show newMaxRetryCount) - , "exception: " <> T.pack (show e)] - in - T.intercalate ", " logMsgComponents + log = logWith recorder -- | in microseconds oneSecond :: Int @@ -235,30 +321,30 @@ maxRetryCount = 10 retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) - => Logger -> g -> m a -> m a -retryOnSqliteBusy logger rng action = + => Recorder (WithPriority Log) -> g -> m a -> m a +retryOnSqliteBusy recorder rng action = let isErrorBusy e | SQLError{ sqlError = ErrorBusy } <- e = Just e | otherwise = Nothing in - retryOnException isErrorBusy logger oneSecond oneMillisecond maxRetryCount rng action + retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action -makeWithHieDbRetryable :: RandomGen g => Logger -> g -> HieDb -> WithHieDb -makeWithHieDbRetryable logger rng hieDb f = - retryOnSqliteBusy logger rng (f hieDb) +makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb +makeWithHieDbRetryable recorder rng hieDb f = + retryOnSqliteBusy recorder rng (f hieDb) -- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for -- 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 :: Logger -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb logger fp k = do +runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () +runWithDb recorder fp k = do -- use non-deterministic seed because maybe multiple HLS start at same time -- and send bursts of requests rng <- Random.newStdGen -- Delete the database if it has an incompatible schema version retryOnSqliteBusy - logger + recorder rng (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) @@ -267,14 +353,16 @@ -- e.g. `withWriteDbRetrable initConn` without type signature will -- instantiate tyvar `a` to `()` let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb withWriteDbRetryable initConn chan <- newTQueueIO withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan) + withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) where + log = logWith recorder + writerThread :: WithHieDb -> IndexQueue -> IO () writerThread withHieDbRetryable chan = do -- Clear the index of any files that might have been deleted since the last run @@ -282,11 +370,12 @@ _ <- withHieDbRetryable garbageCollectTypeNames forever $ do k <- atomically $ readTQueue chan + -- TODO: probably should let exceptions be caught/logged/handled by top level handler k withHieDbRetryable `Safe.catch` \e@SQLError{} -> do - logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e + log Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \e -> do - logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e + log Error $ LogHieDbWriterThreadException e getHieDbLoc :: FilePath -> IO FilePath @@ -310,11 +399,11 @@ -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSession :: FilePath -> IO (Action IdeGhcSession) -loadSession = loadSessionWithOptions def +loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) +loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions SessionLoadingOptions{..} dir = do +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -340,7 +429,7 @@ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do - extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv + extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras let invalidateShakeCache :: IO () invalidateShakeCache = do @@ -371,8 +460,7 @@ logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] return (logDirtyKeys >> pure hasUpdate) for_ hasUpdate $ \x -> - logDebug logger $ "Known files updated: " <> - T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) + logWith recorder Debug $ LogKnownFilesUpdated x -- Create a new HscEnv from a hieYaml root and a set of options -- If the hieYaml file already has an HscEnv, the new component is @@ -412,7 +500,7 @@ let hscComponents = sort $ map show uids cacheDirOpts = hscComponents ++ componentOptions opts cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs logger cacheDirs df2 + processed_df <- setCacheDirs recorder cacheDirs df2 -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded -- into the same component. @@ -427,7 +515,7 @@ -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand - logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + log Info $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir newHscEnv <- -- Add the options for the current component to the HscEnv @@ -463,10 +551,10 @@ initObjLinker hscEnv res <- loadDLL hscEnv "libm.so.6" case res of - Nothing -> pure () - Just err -> logDebug logger $ T.pack $ - "Error dynamically loading libm.so.6:\n" <> err + Nothing -> pure () + Just err -> log Error $ LogDLLLoadError err + -- Make a map from unit-id to DynFlags, this is used when trying to -- resolve imports. (especially PackageImports) let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) @@ -476,7 +564,7 @@ -- New HscEnv for the component in question, returns the new HscEnvEq and -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids + let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids (cs, res) <- new_cache new -- Modified cache targets for everything else in the hie.yaml file -- which now uses the same EPS and so on @@ -493,8 +581,10 @@ -- Invalidate all the existing GhcSession build nodes by restarting the Shake session invalidateShakeCache - restartShakeSession "new component" [] + -- The VFS doesn't change on cradle edits, re-use the old one. + restartShakeSession VFSUnmodified "new component" [] + -- Typecheck all files in the project on startup checkProject <- getCheckProject unless (null cs || not checkProject) $ do @@ -513,10 +603,10 @@ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do lfp <- flip makeRelative cfp <$> getCurrentDirectory - logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) + log Info $ LogCradlePath lfp when (isNothing hieYaml) $ - logWarning logger $ implicitCradleWarning lfp + log Warning $ LogCradleNotFound lfp cradle <- loadCradle hieYaml dir lfp <- flip makeRelative cfp <$> getCurrentDirectory @@ -530,12 +620,11 @@ eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfp - res <- cradleToOptsAndLibDir logger cradle cfp + res <- cradleToOptsAndLibDir recorder cradle cfp addTag "result" (show res) return res - - logDebug logger $ T.pack ("Session loading result: " <> show eopts) + log Debug $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -598,16 +687,19 @@ as <- async $ getOptions file return (as, wait as) pure opts + where + log = logWith recorder -- | Run the specific cradle on a specific FilePath via hie-bios. -- 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 => Logger -> Cradle a -> FilePath +cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir logger cradle file = do +cradleToOptsAndLibDir recorder cradle file = do + -- let noneCradleFoundMessage :: FilePath -> T.Text + -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options - logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle + logWith recorder Debug $ LogCradle cradle cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do @@ -617,13 +709,14 @@ -- This is the successful path CradleSuccess libDir -> pure (Right (r, libDir)) CradleFail err -> return (Left [err]) - -- For the None cradle perhaps we still want to report an Info - -- message about the fact that the file is being ignored. - CradleNone -> return (Left []) + CradleNone -> do + logWith recorder Info $ LogNoneCradleFound file + return (Left []) CradleFail err -> return (Left [err]) - -- Same here - CradleNone -> return (Left []) + CradleNone -> do + logWith recorder Info $ LogNoneCradleFound file + return (Left []) emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do @@ -669,7 +762,7 @@ -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache - :: Logger + :: Recorder (WithPriority Log) -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component @@ -677,17 +770,26 @@ -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger exts cradlePath cfp hsc_env uids ci = do +newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci - let hscEnv' = hscSetFlags df hsc_env - { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + hscEnv' <- + -- Add the options for the current component to the HscEnv + -- We want to call `setSessionDynFlags` instead of `hscSetFlags` + -- because `setSessionDynFlags` also initializes the package database, + -- which we need for any changes to the package flags in the dynflags + -- to be visible. + -- See #2693 + evalGhcEnv hsc_env $ do + _ <- setSessionDynFlags $ df + getSession + let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids let targetEnv = ([], Just henv) targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) - logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + logWith recorder Debug $ LogNewComponentCache res let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -755,9 +857,9 @@ -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs logger CacheDirs{..} dflags = do - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir @@ -930,12 +1032,6 @@ cacheDir :: String cacheDir = "ghcide" -implicitCradleWarning :: FilePath -> T.Text -implicitCradleWarning fp = - "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> - "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -17,8 +17,7 @@ isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) import Development.IDE.Core.RuleTypes as X -import Development.IDE.Core.Rules as X (IsHiFileStable (..), - getClientConfigAction, +import Development.IDE.Core.Rules as X (getClientConfigAction, getParsedModule) import Development.IDE.Core.Service as X (runAction) import Development.IDE.Core.Shake as X (FastResult (..), @@ -41,7 +40,8 @@ useWithStaleFast, useWithStaleFast', useWithStale_, - use_, uses, uses_) + use_, uses, uses_, + VFSModified(..)) import Development.IDE.GHC.Compat as X (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Error as X 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 @@ -26,14 +26,56 @@ , getModSummaryFromImports , loadHieFile , loadInterface + , RecompilationInfo(..) , loadModulesHome , getDocsBatch , lookupName - ,mergeEnvs) where + , mergeEnvs + ) where +import Control.Concurrent.Extra +import Control.Concurrent.STM.Stats hiding (orElse) +import Control.DeepSeq (force, liftRnf, rnf, rwhnf) +import Control.Exception (evaluate) +import Control.Exception.Safe +import Control.Lens hiding (List) +import Control.Monad.Except +import Control.Monad.Extra +import Control.Monad.Trans.Except +import Data.Aeson (toJSON) +import Data.Bifunctor (first, second) +import Data.Binary +import qualified Data.Binary as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce +import qualified Data.DList as DL +import Data.Functor +import qualified Data.HashMap.Strict as HashMap +import Data.IORef +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List.Extra +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Data.Time (UTCTime (..), + getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Tuple.Extra (dupe) +import Data.Unique as Unique +import Debug.Trace import Development.IDE.Core.Preprocessor import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake +import Development.IDE.Core.Tracing (withTrace) +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 Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util @@ -42,26 +84,25 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options - -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 GHC (ForeignHValue, + GetDocsFailure (..), + mgModSummaries, + parsedSource) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Serialized import HieDb - +import qualified Language.LSP.Server as LSP import Language.LSP.Types (DiagnosticTag (..)) +import qualified Language.LSP.Types as LSP +import System.Directory +import System.FilePath +import System.IO.Extra (fixIO, newTempFileWithin) +import Unsafe.Coerce -#if MIN_VERSION_ghc(8,10,0) -import Control.DeepSeq (force, liftRnf, rnf, rwhnf) -#else -import Control.DeepSeq (liftRnf, rnf, rwhnf) +#if !MIN_VERSION_ghc(8,10,0) import ErrUtils #endif - #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice #else @@ -69,53 +110,18 @@ #endif #if MIN_VERSION_ghc(9,2,0) +import Development.IDE.GHC.Compat.Util (emptyUDFM, fsLit, + plusUDFM_C) +import GHC (Anchor (anchor), + EpaComment (EpaComment), + EpaCommentTok (EpaBlockComment, EpaLineComment), + epAnnComments, + priorComments) +import qualified GHC as G +import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error #endif -import Control.Exception (evaluate) -import Control.Exception.Safe -import Control.Lens hiding (List) -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Trans.Except -import Data.Bifunctor (first, second) -import qualified Data.ByteString as BS -import qualified Data.DList as DL -import Data.IORef -import qualified Data.IntMap.Strict as IntMap -import Data.List.Extra -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text as T -import Data.Time (UTCTime, getCurrentTime) -import qualified GHC.LanguageExtensions as LangExt -import System.Directory -import System.FilePath -import System.IO.Extra (fixIO, newTempFileWithin) - --- GHC API imports --- GHC API imports -import GHC (GetDocsFailure (..), - mgModSummaries, - parsedSource) - -import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats hiding (orElse) -import Data.Aeson (toJSON) -import Data.Binary -import Data.Coerce -import Data.Functor -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) -import Data.Map (Map) -import Data.Tuple.Extra (dupe) -import Data.Unique as Unique -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM_C) -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 :: IdeOptions @@ -143,7 +149,7 @@ typecheckModule :: IdeDefer -> HscEnv - -> [Linkable] -- ^ linkables not to unload + -> ModuleEnv UTCTime -- ^ linkables not to unload -> ParsedModule -> IO (IdeResult TcModuleResult) typecheckModule (IdeDefer defer) hsc keep_lbls pm = do @@ -171,16 +177,110 @@ where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id --- | Add a Hook to the DynFlags which captures and returns the --- typechecked splices before they are run. This information --- is used for hover. -captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices) -captureSplices env k = do +-- | Install hooks to capture the splices as well as the runtime module dependencies +captureSplicesAndDeps :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, UniqSet ModuleName) +captureSplicesAndDeps env k = do splice_ref <- newIORef mempty - res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) + dep_ref <- newIORef emptyUniqSet + res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) splices <- readIORef splice_ref - return (res, splices) + needed_mods <- readIORef dep_ref + return (res, splices, needed_mods) where + addLinkableDepHook :: IORef (UniqSet ModuleName) -> Hooks -> Hooks + addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } + + -- We want to record exactly which linkables/modules the typechecker needed at runtime + -- This is useful for recompilation checking. + -- See Note [Recompilation avoidance in the presence of TH] + -- + -- From hscCompileCoreExpr' in GHC + -- To update, copy hscCompileCoreExpr' (the implementation of + -- hscCompileCoreExprHook) verbatim, and add code to extract all the free + -- names in the compiled bytecode, recording the modules that those names + -- come from in the IORef,, as these are the modules on whose implementation + -- we depend. + -- + -- Only compute direct dependencies instead of transitive dependencies. + -- It is much cheaper to store the direct dependencies, we can compute + -- the transitive ones when required. + -- Also only record dependencies from the home package + compile_bco_hook :: IORef (UniqSet ModuleName) -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue + compile_bco_hook var hsc_env srcspan ds_expr + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + +#if MIN_VERSION_ghc(9,2,0) + ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", + ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" } + ; let ictxt = hsc_IC hsc_env + + ; (binding_id, stg_expr, _, _) <- + myCoreToStgExpr (hsc_logger hsc_env) + (hsc_dflags hsc_env) + ictxt + (icInteractiveModule ictxt) + iNTERACTIVELoc + prepd_expr + + {- Convert to BCOs -} + ; bcos <- byteCodeGen hsc_env + (icInteractiveModule ictxt) + stg_expr + [] Nothing + ; let needed_mods = mkUniqSet [ moduleName mod | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos + , Just mod <- [nameModule_maybe n] -- Names from other modules + , not (isWiredInName n) -- Exclude wired-in names + , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package + ] + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + {- load it -} + ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos + ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) +#else + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + ; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos) + , Just mod <- [nameModule_maybe n] -- Names from other modules + , not (isWiredInName n) -- Exclude wired-in names + , moduleUnitId mod == homeUnitId_ dflags -- Only care about stuff from the home package + ] + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos +#endif + + ; modifyIORef' var (unionUniqSets needed_mods) + ; return hval } + + + -- | Add a Hook to the DynFlags which captures and returns the + -- typechecked splices before they are run. This information + -- is used for hover. addSpliceHook :: IORef Splices -> Hooks -> Hooks addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } @@ -208,15 +308,20 @@ pure $ f aw' -tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult +tcRnModule + :: HscEnv + -> ModuleEnv UTCTime -- ^ Program linkables not to unload + -> ParsedModule + -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env + hpt = hsc_HPT hsc_env - unload hsc_env_tmp keep_lbls + unload hsc_env_tmp $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls - ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices hsc_env_tmp $ \hsc_env_tmp -> + ((tc_gbl_env', mrn_info), splices, mods) + <- captureSplicesAndDeps hsc_env_tmp $ \hsc_env_tmp -> do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, @@ -224,8 +329,30 @@ let rn_info = case mrn_info of Just x -> x Nothing -> error "no renamed info tcRnModule" - pure (TcModuleResult pmod rn_info tc_gbl_env splices False) + -- Compute the transitive set of linkables required + mods_transitive = go emptyUniqSet mods + where + go seen new + | isEmptyUniqSet new = seen + | otherwise = go seen' new' + where + seen' = seen `unionUniqSets` new + new' = new_deps `minusUniqSet` seen' + new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info + | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] + + -- The linkables we depend on at runtime are the transitive closure of 'mods' + -- restricted to the home package + -- See Note [Recompilation avoidance in the presence of TH] + mod_env = filterModuleEnv (\m _ -> elementOfUniqSet (moduleName m) mods_transitive) keep_lbls -- Could use restrictKeys if the constructors were exported + + -- Serialize mod_env so we can read it from the interface + mod_env_anns = map (\(mod, time) -> Annotation (ModuleTarget mod) $ toSerialized serializeModDepTime (ModDepTime time)) + (moduleEnvToList mod_env) + tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } + pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) + mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session @@ -239,7 +366,7 @@ (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv #endif let mod_info = HomeModInfo iface details Nothing - pure $! mkHiFileResult ms mod_info + pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm) mkHiFileResultCompile :: HscEnv @@ -277,7 +404,7 @@ (final_iface,_) <- mkIface session Nothing details simplified_guts #endif let mod_info = HomeModInfo final_iface details linkable - pure (diags, Just $! mkHiFileResult ms mod_info) + pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)) where dflags = hsc_dflags session' @@ -932,56 +1059,211 @@ loadHieFile ncu f = do GHC.hie_file_result <$> GHC.readHieFile ncu f + +{- Note [Recompilation avoidance in the presence of TH] + +Most versions of GHC we currently support don't have a working implementation of +code unloading for object code, and no version of GHC supports this on certain +platforms like Windows. This makes it completely infeasible for interactive use, +as symbols from previous compiles will shadow over all future compiles. + +This means that we need to use bytecode when generating code for Template +Haskell. Unfortunately, we can't serialize bytecode, so we will always need +to recompile when the IDE starts. However, we can put in place a much tighter +recompilation avoidance scheme for subsequent compiles: + +1. If the source file changes, then we always need to recompile + a. For files of interest, we will get explicit `textDocument/change` events + that will let us invalidate our build products + b. For files we read from disk, we can detect source file changes by + comparing the `mtime` of the source file with the build product (.hi/.o) file + on disk. +2. If GHC's recompilation avoidance scheme based on interface file hashes says + that we need to recompile, the we need to recompile. +3. If the file in question requires code generation then, we need to recompile + if we don't have the appropriate kind of build products. + a. If we already have the build products in memory, and the conditions 1 and + 2 above hold, then we don't need to recompile + b. If we are generating object code, then we can also search for it on + disk and ensure it is up to date. Notably, we did _not_ previously re-use + old bytecode from memory when `hls-graph`/`shake` decided to rebuild the + `HiFileResult` for some reason + +4. If the file in question used Template Haskell on the previous compile, then + we need to recompile if any `Linkable` in its transitive closure changed. This + sounds bad, but it is possible to make some improvements. + In particular, we only need to recompile if any of the `Linkable`s actually used during the previous compile change. + +How can we tell if a `Linkable` was actually used while running some TH? + +GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as +it is being compiled and linked. We can inspect the bytecode to see which +`Linkable` dependencies it requires, and record this for use in +recompilation checking. +We record all the home package modules of the free names that occur in the +bytecode. The `Linkable`s required are then the transitive closure of these +modules in the home-package environment. This is the same scheme as used by +GHC to find the correct things to link in before running bytecode. + +This works fine if we already have previous build products in memory, but +what if we are reading an interface from disk? Well, we can smuggle in the +necessary information (linkable `Module`s required as well as the time they +were generated) using `Annotation`s, which provide a somewhat general purpose +way to serialise arbitrary information along with interface files. + +Then when deciding whether to recompile, we need to check that the versions +of the linkables used during a previous compile match whatever is currently +in the HPT. +-} + +data RecompilationInfo m + = RecompilationInfo + { source_version :: FileVersion + , old_value :: Maybe (HiFileResult, FileVersion) + , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) + , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface + } + -- | Retuns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies +-- See Note [Recompilation avoidance in the presence of TH] loadInterface :: (MonadIO m, MonadMask m) => HscEnv -> ModSummary - -> SourceModified -> Maybe LinkableType - -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface + -> RecompilationInfo m -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms sourceMod linkableNeeded regen = do +loadInterface session ms linkableNeeded RecompilationInfo{..} = do let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session - res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing - case res of - (UpToDate, Just iface) - -- If the module used TH splices when it was last - -- compiled, then the recompilation check is not - -- accurate enough (https://gitlab.haskell.org/ghc/ghc/-/issues/481) - -- and we must ignore - -- it. However, if the module is stable (none of - -- the modules it depends on, directly or - -- indirectly, changed), then we *can* skip - -- recompilation. This is why the SourceModified - -- type contains SourceUnmodifiedAndStable, and - -- it's pretty important: otherwise ghc --make - -- would always recompile TH modules, even if - -- nothing at all has changed. Stability is just - -- the same check that make is doing for us in - -- one-shot mode. - | not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod - -> do - linkable <- case linkableNeeded of - Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms) - _ -> pure Nothing + mb_old_iface = hm_iface . hirHomeMod . fst <$> old_value + mb_old_version = snd <$> old_value - -- We don't need to regenerate if the object is up do date, or we don't need one - let objUpToDate = isNothing linkableNeeded || case linkable of - Nothing -> False - Just (LM obj_time _ _) -> obj_time > ms_hs_date ms - if objUpToDate - then do - hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface linkable - return ([], Just $ mkHiFileResult ms hmi) - else regen linkableNeeded - (_reason, _) -> withTrace "regenerate interface" $ \setTag -> do - setTag "Module" $ moduleNameString $ moduleName $ ms_mod ms - setTag "Reason" $ showReason _reason - regen linkableNeeded + obj_file = ml_obj_file (ms_location ms) + !mod = ms_mod ms + + mb_dest_version <- case mb_old_version of + Just ver -> pure $ Just ver + Nothing -> get_file_version $ toNormalizedFilePath' $ case linkableNeeded of + Just ObjectLinkable -> ml_obj_file (ms_location ms) + _ -> ml_hi_file (ms_location ms) + + -- The source is modified if it is newer than the destination + let sourceMod = case mb_dest_version of + Nothing -> SourceModified -- desitination file doesn't exist, assume modified source + Just dest_version + | source_version <= dest_version -> SourceUnmodified + | otherwise -> SourceModified + + -- If mb_old_iface is nothing then checkOldIface will load it for us + (recomp_iface_reqd, mb_checked_iface) + <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface + + + let + (recomp_obj_reqd, mb_linkable) = case linkableNeeded of + Nothing -> (UpToDate, Nothing) + Just linkableType -> case old_value of + -- We don't have an old result + Nothing -> recompMaybeBecause "missing" + -- We have an old result + Just (old_hir, old_file_version) -> + case hm_linkable $ hirHomeMod old_hir of + Nothing -> recompMaybeBecause "missing [not needed before]" + Just old_lb + | Just True <- mi_used_th <$> mb_checked_iface -- No need to recompile if TH wasn't used + , old_file_version /= source_version -> recompMaybeBecause "out of date" + + -- Check if it is the correct type + -- Ideally we could use object-code in case we already have + -- it when we are generating bytecode, but this is difficult because something + -- below us may be bytecode, and object code can't depend on bytecode + | ObjectLinkable <- linkableType, isObjectLinkable old_lb + -> (UpToDate, Just old_lb) + + | BCOLinkable <- linkableType , not (isObjectLinkable old_lb) + -> (UpToDate, Just old_lb) + + | otherwise -> recompMaybeBecause "missing [wrong type]" + where + recompMaybeBecause msg = case linkableType of + BCOLinkable -> (RecompBecause ("bytecode "++ msg), Nothing) + ObjectLinkable -> case mb_dest_version of -- The destination file should be the object code + Nothing -> (RecompBecause ("object code "++ msg), Nothing) + Just disk_obj_version@(ModificationTime t) -> + -- If we make it this far, assume that the object code on disk is up to date + -- This assertion works because of the sourceMod check + assert (disk_obj_version >= source_version) + (UpToDate, Just $ LM (posixSecondsToUTCTime t) mod [DotO obj_file]) + Just (VFSVersion _) -> error "object code in vfs" + + let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do + setTag "Module" $ moduleNameString $ moduleName mod + setTag "Reason" $ showReason _reason + liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason) + regenerate linkableNeeded + + case (mb_checked_iface, recomp_iface_reqd <> recomp_obj_reqd) of + (Just iface, UpToDate) -> do + -- Force it because we don't want to retain old modsummaries or linkables + lb <- liftIO $ evaluate $ force mb_linkable + + -- If we have an old value, just return it + case old_value of + Just (old_hir, _) + | Just msg <- checkLinkableDependencies (hsc_HPT sessionWithMsDynFlags) (hirRuntimeModules old_hir) + -> do_regenerate msg + | otherwise -> return ([], Just old_hir) + Nothing -> do + hmi <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface lb + -- parse the runtime dependencies from the annotations + let runtime_deps + | not (mi_used_th iface) = emptyModuleEnv + | otherwise = parseRuntimeDeps (md_anns (hm_details hmi)) + return ([], Just $ mkHiFileResult ms hmi runtime_deps) + (_, _reason) -> do_regenerate _reason + +-- | ModDepTime is stored as an annotation in the iface to +-- keep track of runtime dependencies +newtype ModDepTime = ModDepTime UTCTime + +deserializeModDepTime :: [Word8] -> ModDepTime +deserializeModDepTime xs = ModDepTime $ case decode (LBS.pack xs) of + (a,b) -> UTCTime (toEnum a) (toEnum b) + +serializeModDepTime :: ModDepTime -> [Word8] +serializeModDepTime (ModDepTime l) = LBS.unpack $ + B.encode (fromEnum $ utctDay l, fromEnum $ utctDayTime l) + +-- | Find the runtime dependencies by looking at the annotations +-- serialized in the iface +parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv UTCTime +parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns + where + go (Annotation (ModuleTarget mod) payload) + | Just (ModDepTime t) <- fromSerialized deserializeModDepTime payload + = Just (mod, t) + go _ = Nothing + +-- | checkLinkableDependencies compares the linkables in the home package to +-- the runtime dependencies of the module, to check if any of them are out of date +-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH +-- See Note [Recompilation avoidance in the presence of TH] +checkLinkableDependencies :: HomePackageTable -> ModuleEnv UTCTime -> Maybe RecompileRequired +checkLinkableDependencies hpt runtime_deps + | isEmptyModuleEnv out_of_date = Nothing -- Nothing out of date, so don't recompile + | otherwise = Just $ + RecompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show (moduleEnvKeys out_of_date)) + where + out_of_date = filterModuleEnv (\mod time -> case lookupHpt hpt (moduleName mod) of + Nothing -> False + Just hm -> case hm_linkable hm of + Nothing -> False + Just lm -> linkableTime lm /= time) + runtime_deps + showReason :: RecompileRequired -> String showReason UpToDate = "UpToDate" showReason MustCompile = "MustCompile" @@ -1019,7 +1301,7 @@ #endif Map.findWithDefault mempty name amap)) case res of - Just x -> return $ map (first $ T.unpack . showGhc) x + Just x -> return $ map (first $ T.unpack . printOutputable) x Nothing -> throwErrors #if MIN_VERSION_ghc(9,2,0) $ Error.getErrorMessages msgs 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 @@ -7,6 +7,7 @@ , getFileExists , watchedGlobs , GetFileExists(..) + , Log(..) ) where @@ -18,12 +19,17 @@ import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe -import Development.IDE.Core.FileStore +import Development.IDE.Core.FileStore hiding (Log, LogShake) +import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) @@ -82,6 +88,16 @@ instance IsIdeGlobal FileExistsMapVar +data Log + = LogFileStore FileStore.Log + | LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogFileStore log -> pretty log + LogShake log -> pretty log + -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do @@ -93,8 +109,7 @@ modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - -- update the map - mask_ $ join $ atomicallyNamed "modifyFileExists" $ do + join $ mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -116,14 +131,6 @@ ------------------------------------------------------------------------------------- -- | Returns True if the file exists --- Note that a file is not considered to exist unless it is saved to disk. --- In particular, VFS existence is not enough. --- Consider the following example: --- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest --- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing --- 2. The editor creates a new buffer @B.hs@ --- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up --- Most editors, e.g. VSCode, only send the event when the file is saved to disk. getFileExists :: NormalizedFilePath -> Action Bool getFileExists fp = use_ GetFileExists fp @@ -157,8 +164,8 @@ -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () -fileExistsRules lspEnv vfs = do +fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules () +fileExistsRules recorder lspEnv = do supportsWatchedFiles <- case lspEnv of Nothing -> pure False Just lspEnv' -> liftIO $ runLspT lspEnv' isWatchSupported @@ -179,19 +186,19 @@ else const $ pure False if supportsWatchedFiles - then fileExistsRulesFast isWatched vfs - else fileExistsRulesSlow vfs + then fileExistsRulesFast recorder isWatched + else fileExistsRulesSlow recorder - fileStoreRules vfs isWatched + fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () -fileExistsRulesFast isWatched vfs = - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do +fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileExistsRulesFast recorder isWatched = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF - then fileExistsFast vfs file - else fileExistsSlow vfs file + then fileExistsFast file + else fileExistsSlow file {- Note [Invalidating file existence results] We have two mechanisms for getting file existence information: @@ -209,8 +216,8 @@ we use 'alwaysRerun'. -} -fileExistsFast :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) -fileExistsFast vfs file = do +fileExistsFast :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsFast file = do -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] mp <- getFileExistsMapUntracked @@ -219,28 +226,27 @@ Just exist -> pure exist -- We don't know about it: use the slow route. -- Note that we do *not* call 'fileExistsSlow', as that would trigger 'alwaysRerun'. - Nothing -> liftIO $ getFileExistsVFS vfs file + Nothing -> getFileExistsVFS file pure (summarizeExists exist, Just exist) summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: VFSHandle -> Rules () -fileExistsRulesSlow vfs = - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file +fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules () +fileExistsRulesSlow recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file -fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) -fileExistsSlow vfs file = do +fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsSlow file = do -- See Note [Invalidating file existence results] alwaysRerun - exist <- liftIO $ getFileExistsVFS vfs file + exist <- getFileExistsVFS file pure (summarizeExists exist, Just exist) -getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool -getFileExistsVFS vfs file = do - -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute - -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly - -- cached 'No' rather than an exception in the wrong place - handle (\(_ :: IOException) -> return False) $ - (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ - Dir.doesFileExist (fromNormalizedFilePath file) +getFileExistsVFS :: NormalizedFilePath -> Action Bool +getFileExistsVFS file = do + vf <- getVirtualFile file + if isJust vf + then pure True + else liftIO $ handle (\(_ :: IOException) -> return False) $ + Dir.doesFileExist (fromNormalizedFilePath file) 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 @@ -5,15 +5,11 @@ module Development.IDE.Core.FileStore( getFileContents, - getVirtualFile, setFileModified, setSomethingModified, fileStoreRules, modificationTime, typecheckParents, - VFSHandle, - makeVFSHandle, - makeLSPVFSHandle, resetFileStore, resetInterfaceStore, getModificationTimeImpl, @@ -21,26 +17,25 @@ getFileContentsImpl, getModTime, isWatchSupported, - registerFileWatches + registerFileWatches, + Log(..) ) where import Control.Concurrent.STM.Stats (STM, atomically, modifyTVar') import Control.Concurrent.STM.TQueue (writeTQueue) -import Control.Concurrent.Strict import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.Either.Extra -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.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.FileUtils import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -55,8 +50,6 @@ #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else -import System.Posix.Files (getFileStatus, - modificationTimeHiRes) #endif import qualified Development.IDE.Types.Logger as L @@ -67,8 +60,14 @@ import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) -import Language.LSP.Server hiding - (getVirtualFile) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Types.Logger (Pretty (pretty), + Priority (Info), + Recorder, + WithPriority, + cmapWithPrio, + logWith, viaShow, + (<+>)) import qualified Language.LSP.Server as LSP import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileChangeType (FcChanged), @@ -80,29 +79,25 @@ import Language.LSP.VFS import System.FilePath -makeVFSHandle :: IO VFSHandle -makeVFSHandle = do - vfsVar <- newVar (1, Map.empty) - pure VFSHandle - { getVirtualFile = \uri -> do - (_nextVersion, vfs) <- readVar vfsVar - pure $ Map.lookup uri vfs - , setVirtualFileContents = Just $ \uri content -> - void $ modifyVar' vfsVar $ \(nextVersion, vfs) -> (nextVersion + 1, ) $ - case content of - Nothing -> Map.delete uri vfs - -- The second version number is only used in persistFileVFS which we do not use so we set it to 0. - Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs - } +data Log + = LogCouldNotIdentifyReverseDeps !NormalizedFilePath + | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) + | LogShake Shake.Log + deriving Show -makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle -makeLSPVFSHandle lspEnv = VFSHandle - { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile - , setVirtualFileContents = Nothing - } +instance Pretty Log where + pretty = \case + LogCouldNotIdentifyReverseDeps path -> + "Could not identify reverse dependencies for" <+> viaShow path + (LogTypeCheckingReverseDeps path reverseDepPaths) -> + "Typechecking reverse dependecies for" + <+> viaShow path + <> ":" + <+> pretty (fmap (fmap show) reverseDepPaths) + LogShake log -> pretty log -addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules () -addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do +addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f isWp <- isWorkspaceFile f if isAlreadyWatched then pure (Just True) else @@ -114,20 +109,19 @@ Nothing -> pure $ Just False -getModificationTimeRule :: VFSHandle -> Rules () -getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file -> - getModificationTimeImpl vfs missingFileDiags file +getModificationTimeRule :: Recorder (WithPriority Log) -> Rules () +getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> + getModificationTimeImpl missingFileDiags file -getModificationTimeImpl :: VFSHandle - -> Bool - -> NormalizedFilePath - -> Action - (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) -getModificationTimeImpl vfs missingFileDiags file = do +getModificationTimeImpl + :: Bool + -> NormalizedFilePath + -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getModificationTimeImpl missingFileDiags file = do let file' = fromNormalizedFilePath file let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) - mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file - case mbVirtual of + mbVf <- getVirtualFile file + case mbVf of Just (virtualFileVersion -> ver) -> do alwaysRerun pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver)) @@ -180,43 +174,23 @@ _ -> pure () --- Dir.getModificationTime is surprisingly slow since it performs --- a ton of conversions. Since we do not actually care about --- the format of the time, we can get away with something cheaper. --- For now, we only try to do this on Unix systems where it seems to get the --- time spent checking file modifications (which happens on every change) --- from > 0.5s to ~0.15s. --- We might also want to try speeding this up on Windows at some point. --- TODO leverage DidChangeWatchedFile lsp notifications on clients that --- support them, as done for GetFileExists -getModTime :: FilePath -> IO POSIXTime -getModTime f = -#ifdef mingw32_HOST_OS - utcTimeToPOSIXSeconds <$> Dir.getModificationTime f -#else - modificationTimeHiRes <$> getFileStatus f -#endif - modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: VFSHandle -> Rules () -getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file +getFileContentsRule :: Recorder (WithPriority Log) -> Rules () +getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file getFileContentsImpl - :: VFSHandle - -> NormalizedFilePath + :: NormalizedFilePath -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) -getFileContentsImpl vfs file = do +getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff time <- use_ GetModificationTime file - res <- liftIO $ ideTryIOException file $ do - mbVirtual <- getVirtualFile vfs $ filePathToUri' file + res <- do + mbVirtual <- getVirtualFile file pure $ Rope.toText . _text <$> mbVirtual - case res of - Left err -> return ([err], Nothing) - Right contents -> return ([], Just (time, contents)) + pure ([], Just (time, res)) ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a) ideTryIOException fp act = @@ -240,64 +214,57 @@ pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () -fileStoreRules vfs isWatched = do - addIdeGlobal vfs - getModificationTimeRule vfs - getFileContentsRule vfs - addWatchedFileRule isWatched +fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules recorder isWatched = do + getModificationTimeRule recorder + getFileContentsRule recorder + addWatchedFileRule recorder isWatched -- | Note that some buffer for a specific file has been modified but not -- with what changes. -setFileModified :: IdeState +setFileModified :: Recorder (WithPriority Log) + -> VFSModified + -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath -> IO () -setFileModified state saved nfp = do +setFileModified recorder vfs state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSave -> saved _ -> False - VFSHandle{..} <- getIdeGlobalState state - when (isJust setVirtualFileContents) $ - fail "setFileModified can't be called on this type of VFSHandle" join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ - typecheckParents state nfp + typecheckParents recorder state nfp -typecheckParents :: IdeState -> NormalizedFilePath -> IO () -typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents - where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp) +typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () +typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents + where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) -typecheckParentsAction :: NormalizedFilePath -> Action () -typecheckParentsAction nfp = do +typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () +typecheckParentsAction recorder nfp = do revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph - logger <- logger <$> getShakeExtras - let log = L.logInfo logger . T.pack + let log = logWith recorder case revs of - Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp + Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) - `catch` \(e :: SomeException) -> log (show e) + log Info $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | 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 -> [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" +setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () +setSomethingModified vfs state keys reason = do -- Update database to remove any files that might have been renamed/deleted atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> foldl' (flip HSet.insert) x keys - void $ restartShakeSession (shakeExtras state) reason [] + void $ restartShakeSession (shakeExtras state) vfs reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/src/Development/IDE/Core/FileUtils.hs b/src/Development/IDE/Core/FileUtils.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/FileUtils.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} + +module Development.IDE.Core.FileUtils( + getModTime, + ) where + + +import Data.Time.Clock.POSIX +#ifdef mingw32_HOST_OS +import qualified System.Directory as Dir +#else +import System.Posix.Files (getFileStatus, + modificationTimeHiRes) +#endif + +-- Dir.getModificationTime is surprisingly slow since it performs +-- a ton of conversions. Since we do not actually care about +-- the format of the time, we can get away with something cheaper. +-- For now, we only try to do this on Unix systems where it seems to get the +-- time spent checking file modifications (which happens on every change) +-- from > 0.5s to ~0.15s. +-- We might also want to try speeding this up on Windows at some point. +-- TODO leverage DidChangeWatchedFile lsp notifications on clients that +-- support them, as done for GetFileExists +getModTime :: FilePath -> IO POSIXTime +getModTime f = +#ifdef mingw32_HOST_OS + utcTimeToPOSIXSeconds <$> Dir.getModificationTime f +#else + modificationTimeHiRes <$> getFileStatus f +#endif 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 @@ -14,8 +14,10 @@ deleteFileOfInterest, setFilesOfInterest, kick, FileOfInterestStatus(..), - OfInterestVar(..) - ,scheduleGarbageCollection) where + OfInterestVar(..), + scheduleGarbageCollection, + Log(..) + ) where import Control.Concurrent.Strict import Control.Monad @@ -32,24 +34,37 @@ import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio, + logDebug) import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP +data Log = LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + instance IsIdeGlobal OfInterestVar -- | The rule that initialises the files of interest state. -ofInterestRules :: Rules () -ofInterestRules = do +ofInterestRules :: Recorder (WithPriority Log) -> Rules () +ofInterestRules recorder = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) - defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest 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 @@ -138,6 +138,9 @@ -- ^ Typechecked splice information , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? + , tmrRuntimeModules :: !(ModuleEnv UTCTime) + -- ^ Which modules did we need at runtime while compiling this file? + -- Used for recompilation checking in the presence of TH } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -158,13 +161,15 @@ -- ^ Fingerprint for the ModIface , hirLinkableFp :: ByteString -- ^ Fingerprint for the Linkable + , hirRuntimeModules :: !(ModuleEnv UTCTime) + -- ^ same as tmrRuntimeModules } hiFileFingerPrint :: HiFileResult -> ByteString hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> hirLinkableFp -mkHiFileResult :: ModSummary -> HomeModInfo -> HiFileResult -mkHiFileResult hirModSummary hirHomeMod = HiFileResult{..} +mkHiFileResult :: ModSummary -> HomeModInfo -> ModuleEnv UTCTime -> HiFileResult +mkHiFileResult hirModSummary hirHomeMod hirRuntimeModules = HiFileResult{..} where hirIfaceFp = fingerprintToBS . getModuleHash . hm_iface $ hirHomeMod -- will always be two bytes hirLinkableFp = case hm_linkable hirHomeMod of @@ -290,10 +295,12 @@ -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +-- | Either the mtime from disk or an LSP version +-- LSP versions always compare as greater than on disk versions data FileVersion - = VFSVersion !Int32 - | ModificationTime !POSIXTime - deriving (Show, Generic) + = ModificationTime !POSIXTime -- order of constructors is relevant + | VFSVersion !Int32 + deriving (Show, Generic, Eq, Ord) instance NFData FileVersion @@ -414,7 +421,11 @@ -- Required for interactive evaluation, but leads to more cache invalidations fullModSummary :: Bool } - deriving newtype (Eq, Show, Typeable, Hashable, NFData) + deriving newtype (Eq, Typeable, Hashable, NFData) + +instance Show GhcSessionDeps where + show (GhcSessionDeps_ False) = "GhcSessionDeps" + show (GhcSessionDeps_ True) = "GhcSessionDepsFull" pattern GhcSessionDeps :: GhcSessionDeps pattern GhcSessionDeps = GhcSessionDeps_ False 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 @@ -30,7 +30,6 @@ usePropertyAction, -- * Rules CompiledLinkables(..), - IsHiFileStable(..), getParsedModuleRule, getParsedModuleWithCommentsRule, getLocatedImportsRule, @@ -42,7 +41,6 @@ getModIfaceFromDiskRule, getModIfaceRule, getModSummaryRule, - isHiFileStableRule, getModuleGraphRule, knownFilesRule, getClientSettingsRule, @@ -56,7 +54,9 @@ ghcSessionDepsDefinition, getParsedModuleDefinition, typeCheckRuleDefinition, + getRebuildCount, GhcSessionDepsConfig(..), + Log(..), DisplayTHWarning(..), ) where @@ -84,6 +84,7 @@ import qualified Data.HashSet as HashSet import Data.Hashable import Data.IORef +import Control.Concurrent.STM.TVar import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.List @@ -96,29 +97,29 @@ import Data.Time (UTCTime (..)) import Data.Tuple.Extra import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists +import Development.IDE.Core.FileExists hiding (LogShake, Log) import Development.IDE.Core.FileStore (getFileContents, - modificationTime, resetInterfaceStore) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (LogShake, Log) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (LogShake, Log) +import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat hiding - (parseModule, + (vcat, nest, parseModule, TargetId(..), loadInterface, - Var) -import qualified Development.IDE.GHC.Compat as Compat + Var, + (<+>)) +import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph -import Development.IDE.Graph.Classes import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint as AtPoint @@ -127,9 +128,7 @@ import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location -import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options -import GHC.Generics (Generic) import qualified GHC.LanguageExtensions as LangExt import qualified HieDb import Ide.Plugin.Config @@ -150,7 +149,37 @@ import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) +import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) +import qualified Development.IDE.Types.Logger as Logger +import qualified Development.IDE.Types.Shake as Shake +data Log + = LogShake Shake.Log + | LogReindexingHieFile !NormalizedFilePath + | LogLoadingHieFile !NormalizedFilePath + | LogLoadingHieFileFail !FilePath !SomeException + | LogLoadingHieFileSuccess !FilePath + | LogExactPrint ExactPrint.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogReindexingHieFile path -> + "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFile path -> + "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFileFail path e -> + nest 2 $ + vcat + [ "FAILED LOADING HIE FILE FOR" <+> pretty path + , pretty (displayException e) ] + LogLoadingHieFileSuccess path -> + "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path + LogExactPrint log -> pretty log + templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -207,10 +236,10 @@ -- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations -getParsedModuleRule :: Rules () -getParsedModuleRule = +getParsedModuleRule :: Recorder (WithPriority Log) -> Rules () +getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it - define $ \GetParsedModule file -> do + define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess @@ -280,11 +309,11 @@ -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. -getParsedModuleWithCommentsRule :: Rules () -getParsedModuleWithCommentsRule = +getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules () +getParsedModuleWithCommentsRule recorder = -- The parse diagnostics are owned by the GetParsedModule rule -- For this reason, this rule does not produce any diagnostics - defineNoDiagnostics $ \GetParsedModuleWithComments file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -315,9 +344,9 @@ Nothing -> pure (diag, Nothing) Just modu -> pure (diag, Just modu) -getLocatedImportsRule :: Rules () -getLocatedImportsRule = - define $ \GetLocatedImports file -> do +getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules () +getLocatedImportsRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let targetsMap = HM.mapWithKey const targets @@ -376,7 +405,7 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act = execStateT act - ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty , IntMap.empty ) @@ -403,6 +432,11 @@ let al = modSummaryToArtifactsLocation f msum -- Get a fresh FilePathId for the new file fId <- getFreshFid al + -- Record this module and its location + whenJust msum $ \ms -> + modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId) + (ShowableModuleName (moduleName $ ms_mod ms)) + (rawModuleNameMap rd)}) -- Adding an edge to the bootmap so we can make sure to -- insert boot nodes before the real files. addBootMap al fId @@ -474,15 +508,15 @@ dropBootSuffix :: FilePath -> FilePath dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Rules () -getDependencyInformationRule = - define $ \GetDependencyInformation file -> do +getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules () +getDependencyInformationRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do rawDepInfo <- rawDependencyInformation [file] pure ([], Just $ processDependencyInformation rawDepInfo) -reportImportCyclesRule :: Rules () -reportImportCyclesRule = - define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do +reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () +reportImportCyclesRule recorder = + define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do DependencyInformation{..} <- use_ GetDependencyInformation file let fileId = pathToId depPathIdMap file case IntMap.lookup (getFilePathId fileId) depErrorNodes of @@ -514,22 +548,21 @@ pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) -getHieAstsRule :: Rules () -getHieAstsRule = - define $ \GetHieAst f -> do +getHieAstsRule :: Recorder (WithPriority Log) -> Rules () +getHieAstsRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do tmr <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSessionDeps f getHieAstRuleDefinition f hsc tmr -persistentHieFileRule :: Rules () -persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do - res <- readHieFileForSrcFromDisk file - vfs <- asks vfs - (currentSource,ver) <- liftIO $ do - mvf <- getVirtualFile vfs $ filePathToUri' file - case mvf of - Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) +persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () +persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk recorder file + vfsRef <- asks vfsVar + vfsData <- liftIO $ vfsMap <$> readTVarIO vfsRef + (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of + Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) + Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) @@ -557,8 +590,8 @@ typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) -getImportMapRule :: Rules () -getImportMapRule = define $ \GetImportMap f -> do +getImportMapRule :: Recorder (WithPriority Log) -> Rules () +getImportMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetImportMap f -> do im <- use GetLocatedImports f let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports pure ([], ImportMap . mkImports <$> im) @@ -567,17 +600,17 @@ persistentImportMapRule :: Rules () persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) -getBindingsRule :: Rules () -getBindingsRule = - define $ \GetBindings f -> do +getBindingsRule :: Recorder (WithPriority Log) -> Rules () +getBindingsRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetBindings f -> do HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f case kind of HieFresh -> pure ([], Just $ bindings rm) HieFromDisk _ -> pure ([], Nothing) -getDocMapRule :: Rules () -getDocMapRule = - define $ \GetDocMap file -> do +getDocMapRule :: Recorder (WithPriority Log) -> Rules () +getDocMapRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do -- Stale data for the scenario where a broken module has previously typechecked -- but we never generated a DocMap for it (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file @@ -591,40 +624,39 @@ persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile -readHieFileForSrcFromDisk file = do +readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile +readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask - log <- asks $ L.logDebug . logger row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row - liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) - exceptToMaybeT $ readHieFileFromDisk hie_loc + liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file + exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile -readHieFileFromDisk hie_loc = do +readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc - log <- asks $ L.logDebug . logger res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - res + let log = (liftIO .) . logWith recorder + case res of + Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e + Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. -typeCheckRule :: Rules () -typeCheckRule = define $ \TypeCheck file -> do +typeCheckRule :: Recorder (WithPriority Log) -> Rules () +typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do pm <- use_ GetParsedModule file hsc <- hscEnv <$> use_ GhcSessionDeps file typeCheckRuleDefinition hsc pm -knownFilesRule :: Rules () -knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do +knownFilesRule :: Recorder (WithPriority Log) -> Rules () +knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do alwaysRerun fs <- knownTargets pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) -getModuleGraphRule :: Rules () -getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do +getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () +getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets rawDepInfo <- rawDependencyInformation (HashSet.toList fs) pure $ processDependencyInformation rawDepInfo @@ -655,19 +687,16 @@ -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. -- Doesn't actually contain the code, since we don't need it to unload -currentLinkables :: Action [Linkable] +currentLinkables :: Action (ModuleEnv UTCTime) currentLinkables = do compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - hm <- liftIO $ readVar compiledLinkables - pure $ map go $ moduleEnvToList hm - where - go (mod, time) = LM time mod [] + liftIO $ readVar compiledLinkables -loadGhcSession :: GhcSessionDepsConfig -> Rules () -loadGhcSession ghcSessionDepsConfig = do +loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules () +loadGhcSession recorder ghcSessionDepsConfig = do -- This function should always be rerun because it tracks changes -- to the version of the collection of HscEnv's. - defineEarlyCutOffNoFile $ \GhcSessionIO -> do + defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do alwaysRerun opts <- getIdeOptions res <- optGhcSession opts @@ -675,7 +704,7 @@ let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) return (fingerprint, res) - defineEarlyCutoff $ Rule $ \GhcSession file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -689,18 +718,10 @@ use_ GetModificationTime nfp mapM_ addDependency deps - opts <- getIdeOptions - let cutoffHash = - case optShakeFiles opts of - -- optShakeFiles is only set in the DAML case. - -- https://github.com/haskell/ghcide/pull/522#discussion_r428622915 - Just {} -> "" - -- Hash the HscEnvEq returned so cutoff if it didn't change - -- from last time - Nothing -> LBS.toStrict $ B.encode (hash (snd val)) + let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics $ \(GhcSessionDeps_ fullModSummary) file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do env <- use_ GhcSession file ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file @@ -738,16 +759,26 @@ -- | 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 +getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules () +getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithOldValue $ \GetModIfaceFromDisk f old -> do ms <- msrModSummary <$> use_ GetModSummary f mb_session <- use GhcSessionDeps f case mb_session of 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) + ver <- use_ GetModificationTime f + let m_old = case old of + Shake.Succeeded (Just old_version) v -> Just (v, old_version) + Shake.Stale _ (Just old_version) v -> Just (v, old_version) + _ -> Nothing + recompInfo = RecompilationInfo + { source_version = ver + , old_value = m_old + , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} + , regenerate = regenerateHiFile session f ms + } + r <- loadInterface (hscEnv session) ms linkableType recompInfo case r of (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do @@ -762,10 +793,10 @@ -- `.hie` file. There should be an up2date `.hie` file on -- disk since we are careful to write out the `.hie` file before writing the -- `.hi` file -getModIfaceFromDiskAndIndexRule :: Rules () -getModIfaceFromDiskAndIndexRule = +getModIfaceFromDiskAndIndexRule :: Recorder (WithPriority Log) -> Rules () +getModIfaceFromDiskAndIndexRule recorder = -- doesn't need early cutoff since all its dependencies already have it - defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f se@ShakeExtras{withHieDb} <- getShakeExtras @@ -787,63 +818,28 @@ -- Not in db, must re-index _ -> do ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ - readHieFileFromDisk hie_loc + readHieFileFromDisk recorder hie_loc case ehf of -- Uh oh, we failed to read the file for some reason, need to regenerate it Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err -- can just re-index the file we read from disk Right hf -> liftIO $ do - L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f) + logWith recorder Logger.Debug $ LogReindexingHieFile f indexHieFile se ms f hash hf return (Just x) -isHiFileStableRule :: Rules () -isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do - ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f - let hiFile = toNormalizedFilePath' - $ Compat.ml_hi_file $ ms_location ms - mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile - modVersion <- use_ GetModificationTime f - sourceModified <- case mbHiVersion of - Nothing -> pure SourceModified - Just x -> - if modificationTime x < modificationTime modVersion - then pure SourceModified - else do - fileImports <- use_ GetLocatedImports f - let imports = fmap artifactFilePath . snd <$> fileImports - deps <- uses_ IsHiFileStable (catMaybes imports) - pure $ if all (== SourceUnmodifiedAndStable) deps - then SourceUnmodifiedAndStable - else SourceUnmodified - return (Just (summarize sourceModified), Just sourceModified) - where - summarize SourceModified = BS.singleton 1 - summarize SourceUnmodified = BS.singleton 2 - summarize SourceUnmodifiedAndStable = BS.singleton 3 - -displayTHWarning :: LspT c IO () -displayTHWarning - | not isWindows && not hostIsDynamic = do - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ T.unwords - [ "This HLS binary does not support Template Haskell." - , "Follow the [instructions](" <> templateHaskellInstructions <> ")" - , "to build an HLS binary with support for Template Haskell." - ] - | otherwise = return () - -newtype DisplayTHWarning = DisplayTHWarning (IO ()) +newtype DisplayTHWarning = DisplayTHWarning (IO()) instance IsIdeGlobal DisplayTHWarning -getModSummaryRule :: Rules () -getModSummaryRule = do - env <- lspEnv <$> getShakeExtrasRules - displayItOnce <- liftIO $ once $ LSP.runLspT (fromJust env) displayTHWarning - addIdeGlobal (DisplayTHWarning displayItOnce) +getModSummaryRule :: LspT Config IO () -> Recorder (WithPriority Log) -> Rules () +getModSummaryRule displayTHWarning recorder = do + menv <- lspEnv <$> getShakeExtrasRules + forM_ menv $ \env -> do + displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning + addIdeGlobal (DisplayTHWarning displayItOnce) - defineEarlyCutoff $ Rule $ \GetModSummary f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' @@ -864,7 +860,7 @@ return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) - defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of Just res@ModSummaryResult{..} -> do @@ -883,12 +879,12 @@ setPriority priorityGenerateCore liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) -generateCoreRule :: Rules () -generateCoreRule = - define $ \GenerateCore -> generateCore (RunSimplifier True) +generateCoreRule :: Recorder (WithPriority Log) -> Rules () +generateCoreRule recorder = + define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) -getModIfaceRule :: Rules () -getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do +getModIfaceRule :: Recorder (WithPriority Log) -> Rules () +getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do @@ -916,6 +912,20 @@ liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time pure res +-- | Count of total times we asked GHC to recompile +newtype RebuildCounter = RebuildCounter { getRebuildCountVar :: TVar Int } +instance IsIdeGlobal RebuildCounter + +getRebuildCount :: Action Int +getRebuildCount = do + count <- getRebuildCountVar <$> getIdeGlobalAction + liftIO $ readTVarIO count + +incrementRebuildCount :: Action () +incrementRebuildCount = do + count <- getRebuildCountVar <$> getIdeGlobalAction + liftIO $ atomically $ modifyTVar' count (+1) + -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written @@ -945,10 +955,10 @@ Just tmr -> do -- compile writes .o file - let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr + let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr -- Bang pattern is important to avoid leaking 'tmr' - (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr + (diags'', !res) <- compileToObjCodeIfNeeded hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -972,18 +982,17 @@ pure (hiDiags <> gDiags <> concat wDiags) Nothing -> pure [] - return (diags <> diags' <> diags'' <> hiDiags, res) -type CompileMod m = m (IdeResult ModGuts) - -- | HscEnv should have deps included already -compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult) -compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do - res <- mkHiFileResultNoCompile hsc tmr +compileToObjCodeIfNeeded :: HscEnv -> Maybe LinkableType -> Action (IdeResult ModGuts) -> TcModuleResult -> Action (IdeResult HiFileResult) +compileToObjCodeIfNeeded hsc Nothing _ tmr = do + incrementRebuildCount + res <- liftIO $ mkHiFileResultNoCompile hsc tmr pure ([], Just $! res) compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do + incrementRebuildCount (diags, mguts) <- getGuts case mguts of Nothing -> pure (diags, Nothing) @@ -991,8 +1000,8 @@ (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType pure (diags++diags', res) -getClientSettingsRule :: Rules () -getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do +getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () +getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun settings <- clientSettings <$> getIdeConfiguration return (LBS.toStrict $ B.encode $ hash settings, settings) @@ -1084,6 +1093,7 @@ newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables + writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do extras <- getShakeExtras @@ -1097,33 +1107,48 @@ checkForImportCycles :: Bool -- | Disable TH for improved performance in large codebases , enableTemplateHaskell :: Bool + -- | Warning to show when TH is not supported by the current HLS binary + , templateHaskellWarning :: LspT Config IO () } -instance Default RulesConfig where def = RulesConfig True True +instance Default RulesConfig where + def = RulesConfig True True displayTHWarning + where + displayTHWarning :: LspT c IO () + displayTHWarning + | not isWindows && not hostIsDynamic = do + LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtInfo $ T.unwords + [ "This HLS binary does not support Template Haskell." + , "Follow the [instructions](" <> templateHaskellInstructions <> ")" + , "to build an HLS binary with support for Template Haskell." + ] + | otherwise = return () -- | A rule that wires per-file rules together -mainRule :: RulesConfig -> Rules () -mainRule RulesConfig{..} = do +mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules () +mainRule recorder RulesConfig{..} = do linkables <- liftIO $ newVar emptyModuleEnv addIdeGlobal $ CompiledLinkables linkables - getParsedModuleRule - getParsedModuleWithCommentsRule - getLocatedImportsRule - getDependencyInformationRule - reportImportCyclesRule - typeCheckRule - getDocMapRule - loadGhcSession def{checkForImportCycles} - getModIfaceFromDiskRule - getModIfaceFromDiskAndIndexRule - getModIfaceRule - getModSummaryRule - isHiFileStableRule - getModuleGraphRule - knownFilesRule - getClientSettingsRule - getHieAstsRule - getBindingsRule + rebuildCountVar <- liftIO $ newTVarIO 0 + addIdeGlobal $ RebuildCounter rebuildCountVar + getParsedModuleRule recorder + getParsedModuleWithCommentsRule recorder + getLocatedImportsRule recorder + getDependencyInformationRule recorder + reportImportCyclesRule recorder + typeCheckRule recorder + getDocMapRule recorder + loadGhcSession recorder def{checkForImportCycles} + getModIfaceFromDiskRule recorder + getModIfaceFromDiskAndIndexRule recorder + getModIfaceRule recorder + getModSummaryRule templateHaskellWarning recorder + getModuleGraphRule recorder + knownFilesRule recorder + getClientSettingsRule recorder + getHieAstsRule recorder + getBindingsRule recorder -- This rule uses a custom newness check that relies on the encoding -- produced by 'encodeLinkable'. This works as follows: -- * -> @@ -1131,22 +1156,12 @@ -- * 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 -> + then defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> needsCompilationRule file - else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing - generateCoreRule - getImportMapRule - getAnnotatedParsedSourceRule - persistentHieFileRule + else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing + generateCoreRule recorder + getImportMapRule recorder + getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder) + persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule - --- | Given the path to a module src file, this rule returns True if the --- corresponding `.hi` file is stable, that is, if it is newer --- than the src file, and all its dependencies are stable too. -data IsHiFileStable = IsHiFileStable - deriving (Eq, Show, Typeable, Generic) -instance Hashable IsHiFileStable -instance NFData IsHiFileStable - -type instance RuleResult IsHiFileStable = SourceModified diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -15,45 +15,67 @@ getDiagnostics, ideLogger, updatePositionMapping, + Log(..), ) where import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Debug), + Recorder, + WithPriority, + cmapWithPrio) import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad -import Development.IDE.Core.Shake +import qualified Development.IDE.Core.FileExists as FileExists +import qualified Development.IDE.Core.OfInterest as OfInterest +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) import System.Environment (lookupEnv) +data Log + = LogShake Shake.Log + | LogOfInterest OfInterest.Log + | LogFileExists FileExists.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogOfInterest log -> pretty log + LogFileExists log -> pretty log + ------------------------------------------------------------ -- Exposed API -- | Initialise the Compiler Service. -initialise :: Config +initialise :: Recorder (WithPriority Log) + -> Config -> Rules () -> Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions - -> VFSHandle -> WithHieDb -> IndexQueue -> IO IdeState -initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do +initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" return $ fromConf <|> fromEnv shakeOpen + (cmapWithPrio LogShake recorder) lspEnv defaultConfig logger @@ -63,12 +85,11 @@ (optTesting options) withHieDb hiedbChan - vfs (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options - ofInterestRules - fileExistsRules lspEnv vfs + ofInterestRules (cmapWithPrio LogOfInterest recorder) + fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv mainRule -- | Shutdown the Compiler Service. @@ -80,4 +101,4 @@ -- e.g., the ofInterestRule. runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act = - join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Info act) + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act) 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 @@ -42,7 +42,6 @@ RuleBody(..), define, defineNoDiagnostics, defineEarlyCutoff, - defineOnDisk, needOnDisk, needOnDisks, defineNoFile, defineEarlyCutOffNoFile, getDiagnostics, mRunLspT, mRunLspTCallback, @@ -58,11 +57,11 @@ setPriority, ideLogger, actionLogger, + getVirtualFile, FileVersion(..), Priority(..), updatePositionMapping, deleteValue, recordDirtyKeys, - OnDiskRule(..), WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -73,30 +72,44 @@ IndexQueue, HieDb, HieDbWriter(..), - VFSHandle(..), addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, + Log(..), + VFSModified(..) ) where import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq +import Control.Exception.Extra hiding (bracket_) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe +import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce (coerce) +import Data.Default import Data.Dynamic +import Data.EnumMap.Strict (EnumMap) +import qualified Data.EnumMap.Strict as EM +import Data.Foldable (for_, toList) +import Data.Functor ((<&>)) import qualified Data.HashMap.Strict as HMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet import Data.Hashable +import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.SortedList as SL +import Data.String (fromString) import qualified Data.Text as T import Data.Time import Data.Traversable @@ -105,7 +118,9 @@ import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector +import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.Debouncer +import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes @@ -121,53 +136,82 @@ import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, - shakeOpenDatabase, + shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports +import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location import Development.IDE.Types.Logger hiding (Priority) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Development.IDE.Types.Shake -import GHC.Generics +import qualified Focus +import GHC.Fingerprint +import HieDb.Types +import Ide.Plugin.Config +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId) import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as LSP +import Language.LSP.Types.Capabilities import Language.LSP.VFS +import qualified "list-t" ListT +import OpenTelemetry.Eventlog +import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) +import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import Data.IORef -import GHC.Fingerprint -import Language.LSP.Types.Capabilities -import OpenTelemetry.Eventlog +data Log + = LogCreateHieDbExportsMapStart + | LogCreateHieDbExportsMapFinish !Int + | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogBuildSessionRestartTakingTooLong !Seconds + | LogDelayedAction !(DelayedAction ()) !Seconds + | LogBuildSessionFinish !(Maybe SomeException) + | LogDiagsDiffButNoLspEnv ![FileDiagnostic] + | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic + | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic + deriving Show -import Control.Concurrent.STM.Stats (atomicallyNamed) -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 (for_, toList) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HSet -import Data.String (fromString) -import Data.Text (pack) -import Debug.Trace.Flags (userTracingEnabled) -import qualified Development.IDE.Types.Exports as ExportsMap -import qualified Focus -import HieDb.Types -import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) -import qualified "list-t" ListT -import qualified StmContainers.Map as STM +instance Pretty Log where + pretty = \case + LogCreateHieDbExportsMapStart -> + "Initializing exports map from hiedb" + LogCreateHieDbExportsMapFinish exportsMapSize -> + "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize + LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath -> + vcat + [ "Restarting build session due to" <+> pretty reason + , "Action Queue:" <+> pretty (map actionName actionQueue) + , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) + , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] + LogBuildSessionRestartTakingTooLong seconds -> + "Build restart is taking too long (" <> pretty seconds <> " seconds)" + LogDelayedAction delayedAction duration -> + hsep + [ "Finished:" <+> pretty (actionName delayedAction) + , "Took:" <+> pretty (showDuration duration) ] + LogBuildSessionFinish e -> + vcat + [ "Finished build session" + , pretty (fmap displayException e) ] + LogDiagsDiffButNoLspEnv fileDiagnostics -> + "updateFileDiagnostics published different from new diagnostics - file diagnostics:" + <+> pretty (showDiagnosticsColored fileDiagnostics) + LogDefineEarlyCutoffRuleNoDiagHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleNoDiagnostics - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) + LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -201,7 +245,7 @@ ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,positionMapping :: STM.Map NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)) + ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an @@ -210,7 +254,8 @@ ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession - :: String + :: VFSModified + -> String -> [DelayedAction ()] -> IO () ,ideNc :: IORef NameCache @@ -226,8 +271,12 @@ , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) - -- Small and immutable after startup, so not worth using an STM.Map. - , vfs :: VFSHandle + , vfsVar :: TVar VFS + -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart + -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session, + -- leaving us vulnerable to suble race conditions. To avoid this, we take a snapshot of the state of the VFS on every + -- restart, so that the whole session sees a single consistent view of the VFS. + -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar (HashSet Key) @@ -268,19 +317,18 @@ class Typeable a => IsIdeGlobal a where +-- | Read a virtual file from the current snapshot +getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) +getVirtualFile nf = do + vfs <- fmap vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras + pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map --- | haskell-lsp manages the VFS internally and automatically so we cannot use --- the builtin VFS without spawning up an LSP server. To be able to test things --- like `setBufferModified` we abstract over the VFS implementation. -data VFSHandle = VFSHandle - { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) - -- ^ get the contents of a virtual file - , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) - -- ^ set a specific file to a value. If Nothing then we are ignoring these - -- signals anyway so can just say something was modified - } -instance IsIdeGlobal VFSHandle +-- Take a snapshot of the current LSP VFS +vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS +vfsSnapshot Nothing = pure $ VFS mempty "" +vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv LSP.getVirtualFiles + addIdeGlobal :: IsIdeGlobal a => a -> Rules () addIdeGlobal x = do extras <- getShakeExtrasRules @@ -292,7 +340,6 @@ Just _ -> error $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty Nothing -> HMap.insert ty (toDyn x) mp - getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do let typ = typeRep (Proxy :: Proxy a) @@ -345,13 +392,18 @@ f <- MaybeT $ pure $ HMap.lookup (Key k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv - atomicallyNamed "lastValueIO" $ case mv of - Nothing -> do + case mv of + Nothing -> atomicallyNamed "lastValueIO 1" $ do STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing Just (v,del,ver) -> do - STM.focus (Focus.alter (alterValue $ Stale (Just del) ver (toDyn v))) (toKey k file) state - Just . (v,) . addDelta del <$> mappingForVersion positionMapping file ver + actual_version <- case ver of + Just ver -> pure (Just $ VFSVersion ver) + Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) + `catch` (\(_ :: IOException) -> pure Nothing) + atomicallyNamed "lastValueIO 2" $ do + STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state + Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics @@ -379,13 +431,14 @@ liftIO $ lastValueIO s key file mappingForVersion - :: STM.Map NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) + :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping)) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe FileVersion -> STM PositionMapping -mappingForVersion allMappings file ver = do +mappingForVersion allMappings file (Just (VFSVersion ver)) = do mapping <- STM.lookup (filePathToUri' file) allMappings - return $ maybe zeroMapping snd $ Map.lookup ver =<< mapping + return $ maybe zeroMapping snd $ EM.lookup ver =<< mapping +mappingForVersion _ _ _ = pure zeroMapping type IdeRule k v = ( Shake.RuleResult k ~ v @@ -407,7 +460,6 @@ data IdeState = IdeState {shakeDb :: ShakeDatabase ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) } @@ -494,7 +546,8 @@ Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: Maybe (LSP.LanguageContextEnv Config) +shakeOpen :: Recorder (WithPriority Log) + -> Maybe (LSP.LanguageContextEnv Config) -> Config -> Logger -> Debouncer NormalizedUri @@ -503,12 +556,13 @@ -> IdeTesting -> WithHieDb -> IndexQueue - -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo +shakeOpen recorder lspEnv defaultConfig logger debouncer + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts rules = mdo + let log :: Logger.Priority -> Log -> IO () + log = logWith recorder us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -520,7 +574,7 @@ publishedDiagnostics <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty - let restartShakeSession = shakeRestart ideState + let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO HMap.empty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -528,11 +582,12 @@ let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb + -- TODO: exceptions can be swallowed here? _ <- async $ do - logDebug logger "Initializing exports map from hiedb" + log Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" + log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1) @@ -544,12 +599,13 @@ let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv dirtyKeys <- newTVarIO mempty + -- Take one VFS snapshot at the start + vfsVar <- newTVarIO =<< vfsSnapshot lspEnv pure ShakeExtras{..} - (shakeDbM, shakeClose) <- - shakeOpenDatabase + shakeDb <- + shakeNewDatabase opts { shakeExtra = newShakeExtra shakeExtras } rules - shakeDb <- shakeDbM shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} @@ -584,9 +640,12 @@ -- | Must be called in the 'Initialized' handler and only once -shakeSessionInit :: IdeState -> IO () -shakeSessionInit ide@IdeState{..} = do - initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" +shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () +shakeSessionInit recorder ide@IdeState{..} = do + -- Take a snapshot of the VFS - it should be empty as we've recieved no notifications + -- till now, but it can't hurt to be in sync with the `lsp` library. + vfs <- vfsSnapshot (lspEnv shakeExtras) + initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" putMVar shakeSession initSession logDebug (ideLogger ide) "Shake session initialized" @@ -597,7 +656,6 @@ -- request so we first abort that. for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb - shakeClose progressStop $ progress shakeExtras @@ -626,31 +684,40 @@ -- | 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 -> String -> [DelayedAction ()] -> IO () -shakeRestart IdeState{..} reason acts = +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts = withMVar' shakeSession (\runner -> do - (stopTime,()) <- duration (cancelShakeSession runner) + let log = logWith recorder + (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + + log Debug $ LogBuildSessionRestart reason queue backlog stopTime res + let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" + -- TODO: should replace with logging using a logger that sends lsp message let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg reason' = "due to " ++ reason queueMsg = " with queue " ++ show (map actionName queue) keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" - logDebug (logger shakeExtras) msg notifyTestingLogMessage shakeExtras msg ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 (\() -> do - (,()) <$> newSession shakeExtras shakeDb acts reason) + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + where + logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () + logErrorAfter seconds recorder action = flip withAsync (const action) $ do + sleep seconds + logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do @@ -681,15 +748,25 @@ ] return (wait' b >>= either throwIO return) +data VFSModified = VFSUnmodified | VFSModified !VFS + -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. newSession - :: ShakeExtras + :: Recorder (WithPriority Log) + -> ShakeExtras + -> VFSModified -> ShakeDatabase -> [DelayedActionInternal] -> String -> IO ShakeSession -newSession extras@ShakeExtras{..} shakeDb acts reason = do +newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do + + -- Take a new VFS snapshot + case vfsMod of + VFSUnmodified -> pure () + VFSModified vfs -> atomically $ writeTVar vfsVar vfs + IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue allPendingKeys <- @@ -709,10 +786,7 @@ getAction d liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue runTime <- liftIO start - let msg = T.pack $ "finish: " ++ actionName d - ++ " (took " ++ showDuration runTime ++ ")" - liftIO $ do - logPriority logger (actionPriority d) msg + logWith recorder (actionPriority d) $ LogDelayedAction d runTime -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) @@ -728,7 +802,11 @@ Right _ -> "completed" let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" return $ do - logDebug logger msg + let exception = + case res of + Left e -> Just e + _ -> Nothing + logWith recorder Debug $ LogBuildSessionFinish exception notifyTestingLogMessage extras msg -- Do the work in a background thread @@ -736,6 +814,7 @@ -- run the wrap up in a separate thread since it contains interruptible -- commands (and we are not using uninterruptible mask) + -- TODO: can possibly swallow exceptions? _ <- async $ join $ wait workThread -- Cancelling is required to flush the Shake database when either @@ -843,13 +922,13 @@ -- | Define a new Rule without early cutoff define :: IdeRule k v - => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () -define op = defineEarlyCutoff $ Rule $ \k v -> (Nothing,) <$> op k v + => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () +define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v defineNoDiagnostics :: IdeRule k v - => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () -defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v + => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () +defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available use :: IdeRule k v @@ -960,6 +1039,11 @@ -- whether the rule succeeded or not. mapM (lastValue key) files +useWithoutDependency :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe v) +useWithoutDependency key file = + (\[A value] -> currentValue value) <$> applyWithoutDependency [Q (key, file)] + data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) @@ -967,54 +1051,60 @@ { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) } + | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v - => RuleBody k v + => Recorder (WithPriority Log) + -> RuleBody k v -> Rules () -defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do +defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do extras <- getShakeExtras - let diagnostics diags = do + let diagnostics ver 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 + updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file +defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + let diagnostics _ver 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{..} = + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags + defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file +defineEarlyCutoff recorder 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 + let diagnostics _ver diags = do traceDiagnostics diags + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ - second (mempty,) <$> build key file + const $ second (mempty,) <$> build key file +defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + extras <- getShakeExtras + let diagnostics ver diags = do + traceDiagnostics diags + updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key file old mode $ op key file -defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () -defineNoFile f = defineNoDiagnostics $ \k file -> do +defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () +defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do if file == emptyFilePath then do res <- f k; return (Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do +defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" defineEarlyCutoff' - :: IdeRule k v - => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics + :: forall k v. IdeRule k v + => (TextDocumentVersion -> [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) + -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics cmp key file old mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras @@ -1026,8 +1116,9 @@ case v of -- No changes in the dependencies and we have -- an existing successful result. - Just (v@Succeeded{}, diags) -> do - doDiagnostics $ Vector.toList diags + Just (v@(Succeeded _ x), diags) -> do + ver <- estimateFileVersionUnsafely key (Just x) file + doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> @@ -1037,26 +1128,23 @@ res <- case val of Just res -> return res Nothing -> do + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + Nothing -> Failed False + Just (Succeeded ver v, _) -> Stale Nothing ver v + Just (Stale d ver v, _) -> Stale d ver v + Just (Failed b, _) -> Failed b (bs, (diags, res)) <- actionCatch - (do v <- action; liftIO $ evaluate $ force v) $ + (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) + + ver <- estimateFileVersionUnsafely key res file (bs, res) <- case res of Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file - pure $ case staleV of - Nothing -> (toShakeValue ShakeResult bs, Failed False) - Just v -> case v of - (Succeeded ver v, _) -> - (toShakeValue ShakeStale bs, Stale Nothing ver v) - (Stale d ver v, _) -> - (toShakeValue ShakeStale bs, Stale d ver v) - (Failed b, _) -> - (toShakeValue ShakeResult bs, Failed b) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) + pure (toShakeValue ShakeStale bs, staleV) + Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) - doDiagnostics diags + doDiagnostics (vfsVersion =<< ver) diags let eq = case (bs, fmap decodeShakeValue old) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b (ShakeStale a, Just (ShakeStale b)) -> cmp a b @@ -1069,115 +1157,73 @@ A res liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file) return res + where + -- Highly unsafe helper to compute the version of a file + -- without creating a dependency on the GetModificationTime rule + -- (and without creating cycles in the build graph). + estimateFileVersionUnsafely + :: forall k v + . IdeRule k v + => k + -> Maybe v + -> NormalizedFilePath + -> Action (Maybe FileVersion) + estimateFileVersionUnsafely _k v fp + | fp == emptyFilePath = pure Nothing + | Just Refl <- eqT @k @GetModificationTime = pure v + -- GetModificationTime depends on these rules, so avoid creating a cycle + | Just Refl <- eqT @k @AddWatchedFile = pure Nothing + | Just Refl <- eqT @k @IsFileOfInterest = pure Nothing + -- GetFileExists gets called for missing files + | Just Refl <- eqT @k @GetFileExists = pure Nothing + -- For all other rules - compute the version properly without: + -- * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff + -- * creating bogus "file does not exists" diagnostics + | otherwise = useWithoutDependency (GetModificationTime_ False) fp 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 - deriving (Eq, Generic) - -instance Hashable k => Hashable (QDisk k) - -instance NFData k => NFData (QDisk k) - -instance Show k => Show (QDisk k) where - show (QDisk k file) = - show k ++ "; " ++ fromNormalizedFilePath file - -type instance RuleResult (QDisk k) = Bool - -data OnDiskRule = OnDiskRule - { getHash :: Action BS.ByteString - -- This is used to figure out if the state on disk corresponds to the state in the Shake - -- database and we can therefore avoid rerunning. Often this can just be the file hash but - -- in some cases we can be more aggressive, e.g., for GHC interface files this can be the ABI hash which - -- is more stable than the hash of the interface file. - -- An empty bytestring indicates that the state on disk is invalid, e.g., files are missing. - -- We do not use a Maybe since we have to deal with encoding things into a ByteString anyway in the Shake DB. - , runRule :: Action (IdeResult BS.ByteString) - -- The actual rule code which produces the new hash (or Nothing if the rule failed) and the diagnostics. - } - --- This is used by the DAML compiler for incremental builds. Right now this is not used by --- ghcide itself but that might change in the future. --- The reason why this code lives in ghcide and in particular in this module is that it depends quite heavily on --- the internals of this module that we do not want to expose. -defineOnDisk - :: (Shake.ShakeValue k, RuleResult k ~ ()) - => (k -> NormalizedFilePath -> OnDiskRule) - -> Rules () -defineOnDisk act = addRule $ - \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do - extras <- getShakeExtras - let OnDiskRule{..} = act key file - let validateHash h - | BS.null h = Nothing - | otherwise = Just h - let runAct = actionCatch runRule $ - \(e :: SomeException) -> pure ([ideErrorText file $ T.pack $ displayException e | not $ isBadDependency e], Nothing) - case mbOld of - Nothing -> do - (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash) - Just old -> do - current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "") - if mode == RunDependenciesSame && Just old == current && not (BS.null old) - then - -- None of our dependencies changed, we’ve had a successful run before and - -- the state on disk matches the state in the Shake database. - pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current) - else do - (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags - let change - | mbHash == Just old = ChangedRecomputeSame - | otherwise = ChangedRecomputeDiff - pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash) - -needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () -needOnDisk k file = do - successfull <- apply1 (QDisk k file) - liftIO $ unless successfull $ throwIO $ BadDependency (show k) - -needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action () -needOnDisks k files = do - successfulls <- apply $ map (QDisk k) files - liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) - updateFileDiagnostics :: MonadIO m - => NormalizedFilePath + => Recorder (WithPriority Log) + -> NormalizedFilePath + -> TextDocumentVersion -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do - modTime <- (currentValue . fst =<<) <$> atomicallyNamed "diagnostics - read" (getValues state GetModificationTime fp) +updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv} current = + liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do + addTag "key" (show k) let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp - ver = vfsVersion =<< modTime - update new store = setStageDiagnostics uri ver (T.pack $ show k) new store + addTagUnsafe :: String -> String -> String -> a -> a + addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v + update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] + update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store + addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (map snd currentShown) diagnostics - _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (map snd currentHidden) hiddenDiagnostics + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics let uri = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 - registerEvent debouncer delay uri $ do + registerEvent debouncer delay uri $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do join $ mask_ $ do lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags - Just env -> LSP.runLspT env $ + logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) + Just env -> LSP.runLspT env $ do + liftIO $ tag "count" (show $ Prelude.length newDiags) + liftIO $ tag "key" (show k) LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) return action newtype Priority = Priority Double @@ -1199,28 +1245,35 @@ getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags -updateSTMDiagnostics :: STMDiagnosticStore - -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource - -> STM [LSP.Diagnostic] -updateSTMDiagnostics store uri mv newDiagsBySource = +updateSTMDiagnostics :: + (forall a. String -> String -> a -> a) -> + STMDiagnosticStore -> + NormalizedUri -> + TextDocumentVersion -> + DiagnosticsBySource -> + STM [LSP.Diagnostic] +updateSTMDiagnostics addTag store uri mv newDiagsBySource = getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store where update (Just(StoreItem mvs dbs)) + | addTag "previous version" (show mvs) $ + addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) update _ = Just (StoreItem mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list setStageDiagnostics - :: NormalizedUri + :: (forall a. String -> String -> a -> a) + -> NormalizedUri -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited -> T.Text -> [LSP.Diagnostic] -> STMDiagnosticStore -> STM [LSP.Diagnostic] -setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags +setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags where - updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) + !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags getAllDiagnostics :: STMDiagnosticStore -> @@ -1238,7 +1291,10 @@ -- Very important to use mapAccum here so that the tails of -- each mapping can be shared, otherwise quadratic space is -- used which is evident in long running sessions. - Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) + EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) zeroMapping - (Map.insert _version (shared_change, zeroMapping) mappingForUri) + (EM.insert actual_version (shared_change, zeroMapping) mappingForUri) shared_change = mkDelta changes + actual_version = case _version of + Nothing -> error "Nothing version from server" -- This is a violation of the spec + Just v -> v 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 @@ -1,162 +1,162 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Development.IDE.Core.UseStale - ( Age(..) - , Tracked - , unTrack - , PositionMap - , TrackedStale (..) - , untrackedStaleValue - , unsafeMkStale - , unsafeMkCurrent - , unsafeCopyAge - , MapAge (..) - , dualPositionMap - , useWithStale - , useWithStale_ - ) where - -import Control.Arrow -import Control.Category (Category) -import qualified Control.Category as C -import Control.DeepSeq (NFData) -import Data.Aeson -import Data.Coerce (coerce) -import Data.Functor ((<&>)) -import Data.Functor.Identity (Identity (Identity)) -import Data.Kind (Type) -import Data.String (fromString) -import Development.IDE (Action, IdeRule, - NormalizedFilePath, - Range, - rangeToRealSrcSpan, - realSrcSpanToRange) -import qualified Development.IDE.Core.PositionMapping as P -import qualified Development.IDE.Core.Shake as IDE -import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) -import Development.IDE.GHC.Compat.Util (unpackFS) - - ------------------------------------------------------------------------------- --- | A data kind for 'Tracked'. -data Age = Current | Stale Type - - ------------------------------------------------------------------------------- --- | Some value, tagged with its age. All 'Current' ages are considered to be --- the same thing, but 'Stale' values are protected by an untouchable variable --- to ensure they can't be unified. -newtype Tracked (age :: Age) a = UnsafeTracked - { unTrack :: a - } - deriving stock (Functor, Foldable, Traversable) - deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) - deriving (Applicative, Monad) via Identity - - ------------------------------------------------------------------------------- --- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values --- change. Use the 'Category' instance to compose 'PositionMapping's in order --- to transform between values of different stale ages. -newtype PositionMap (from :: Age) (to :: Age) = PositionMap - { _getPositionMapping :: P.PositionMapping - } - -instance Category PositionMap where - id = coerce P.zeroMapping - (.) = coerce P.composeDelta - - ------------------------------------------------------------------------------- --- | Get a 'PositionMap' that runs in the opposite direction. -dualPositionMap :: PositionMap from to -> PositionMap to from -dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = - PositionMap $ P.PositionMapping $ P.PositionDelta to from - - ------------------------------------------------------------------------------- --- | A pair containing a @'Tracked' 'Stale'@ value, as well as --- a 'PositionMapping' that will fast-forward values to the current age. -data TrackedStale a where - TrackedStale - :: Tracked (Stale s) a - -> PositionMap (Stale s) Current - -> TrackedStale a - -instance Functor TrackedStale where - fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm - - -untrackedStaleValue :: TrackedStale a -> a -untrackedStaleValue (TrackedStale ta _) = coerce ta - - ------------------------------------------------------------------------------- --- | A class for which 'Tracked' values can be run across a 'PositionMapping' --- to change their ages. -class MapAge a where - {-# MINIMAL mapAgeFrom | mapAgeTo #-} - mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) - mapAgeFrom = mapAgeTo . dualPositionMap - - mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) - mapAgeTo = mapAgeFrom . dualPositionMap - - -instance MapAge Range where - mapAgeFrom = coerce P.fromCurrentRange - mapAgeTo = coerce P.toCurrentRange - - -instance MapAge RealSrcSpan where - mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) - (srcSpanFile &&& realSrcSpanToRange) - . mapAgeFrom - - ------------------------------------------------------------------------------- --- | Helper function for deriving 'MapAge' for values in terms of other --- instances. -invMapAge - :: (c -> a -> b) - -> (b -> (c, a)) - -> (Tracked from a -> Maybe (Tracked to a)) - -> Tracked from b - -> Maybe (Tracked to b) -invMapAge to from f t = - let (c, t') = unTrack $ fmap from t - in fmap (fmap $ to c) $ f $ UnsafeTracked t' - - -unsafeMkCurrent :: age -> Tracked 'Current age -unsafeMkCurrent = coerce - - -unsafeMkStale :: age -> Tracked (Stale s) age -unsafeMkStale = coerce - - -unsafeCopyAge :: Tracked age a -> b -> Tracked age b -unsafeCopyAge _ = coerce - - --- | Request a Rule result, it not available return the last computed result, if any, which may be stale -useWithStale :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) -useWithStale key file = do - x <- IDE.useWithStale key file - pure $ x <&> \(v, pm) -> - TrackedStale (coerce v) (coerce pm) - --- | Request a Rule result, it not available return the last computed result which may be stale. --- Errors out if none available. -useWithStale_ :: IdeRule k v - => k -> NormalizedFilePath -> Action (TrackedStale v) -useWithStale_ key file = do - (v, pm) <- IDE.useWithStale_ key file - pure $ TrackedStale (coerce v) (coerce pm) - +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module Development.IDE.Core.UseStale + ( Age(..) + , Tracked + , unTrack + , PositionMap + , TrackedStale (..) + , untrackedStaleValue + , unsafeMkStale + , unsafeMkCurrent + , unsafeCopyAge + , MapAge (..) + , dualPositionMap + , useWithStale + , useWithStale_ + ) where + +import Control.Arrow +import Control.Category (Category) +import qualified Control.Category as C +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Type) +import Data.String (fromString) +import Development.IDE (Action, IdeRule, + NormalizedFilePath, + Range, + rangeToRealSrcSpan, + realSrcSpanToRange) +import qualified Development.IDE.Core.PositionMapping as P +import qualified Development.IDE.Core.Shake as IDE +import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) +import Development.IDE.GHC.Compat.Util (unpackFS) + + +------------------------------------------------------------------------------ +-- | A data kind for 'Tracked'. +data Age = Current | Stale Type + + +------------------------------------------------------------------------------ +-- | Some value, tagged with its age. All 'Current' ages are considered to be +-- the same thing, but 'Stale' values are protected by an untouchable variable +-- to ensure they can't be unified. +newtype Tracked (age :: Age) a = UnsafeTracked + { unTrack :: a + } + deriving stock (Functor, Foldable, Traversable) + deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON, NFData) + deriving (Applicative, Monad) via Identity + + +------------------------------------------------------------------------------ +-- | Like 'P.PositionMapping', but with annotated ages for how 'Tracked' values +-- change. Use the 'Category' instance to compose 'PositionMapping's in order +-- to transform between values of different stale ages. +newtype PositionMap (from :: Age) (to :: Age) = PositionMap + { _getPositionMapping :: P.PositionMapping + } + +instance Category PositionMap where + id = coerce P.zeroMapping + (.) = coerce P.composeDelta + + +------------------------------------------------------------------------------ +-- | Get a 'PositionMap' that runs in the opposite direction. +dualPositionMap :: PositionMap from to -> PositionMap to from +dualPositionMap (PositionMap (P.PositionMapping (P.PositionDelta from to))) = + PositionMap $ P.PositionMapping $ P.PositionDelta to from + + +------------------------------------------------------------------------------ +-- | A pair containing a @'Tracked' 'Stale'@ value, as well as +-- a 'PositionMapping' that will fast-forward values to the current age. +data TrackedStale a where + TrackedStale + :: Tracked (Stale s) a + -> PositionMap (Stale s) Current + -> TrackedStale a + +instance Functor TrackedStale where + fmap f (TrackedStale t pm) = TrackedStale (fmap f t) pm + + +untrackedStaleValue :: TrackedStale a -> a +untrackedStaleValue (TrackedStale ta _) = coerce ta + + +------------------------------------------------------------------------------ +-- | A class for which 'Tracked' values can be run across a 'PositionMapping' +-- to change their ages. +class MapAge a where + {-# MINIMAL mapAgeFrom | mapAgeTo #-} + mapAgeFrom :: PositionMap from to -> Tracked to a -> Maybe (Tracked from a) + mapAgeFrom = mapAgeTo . dualPositionMap + + mapAgeTo :: PositionMap from to -> Tracked from a -> Maybe (Tracked to a) + mapAgeTo = mapAgeFrom . dualPositionMap + + +instance MapAge Range where + mapAgeFrom = coerce P.fromCurrentRange + mapAgeTo = coerce P.toCurrentRange + + +instance MapAge RealSrcSpan where + mapAgeFrom = + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) + (srcSpanFile &&& realSrcSpanToRange) + . mapAgeFrom + + +------------------------------------------------------------------------------ +-- | Helper function for deriving 'MapAge' for values in terms of other +-- instances. +invMapAge + :: (c -> a -> b) + -> (b -> (c, a)) + -> (Tracked from a -> Maybe (Tracked to a)) + -> Tracked from b + -> Maybe (Tracked to b) +invMapAge to from f t = + let (c, t') = unTrack $ fmap from t + in fmap (fmap $ to c) $ f $ UnsafeTracked t' + + +unsafeMkCurrent :: age -> Tracked 'Current age +unsafeMkCurrent = coerce + + +unsafeMkStale :: age -> Tracked (Stale s) age +unsafeMkStale = coerce + + +unsafeCopyAge :: Tracked age a -> b -> Tracked age b +unsafeCopyAge _ = coerce + + +-- | Request a Rule result, it not available return the last computed result, if any, which may be stale +useWithStale :: IdeRule k v + => k -> NormalizedFilePath -> Action (Maybe (TrackedStale v)) +useWithStale key file = do + x <- IDE.useWithStale key file + pure $ x <&> \(v, pm) -> + TrackedStale (coerce v) (coerce pm) + +-- | Request a Rule result, it not available return the last computed result which may be stale. +-- Errors out if none available. +useWithStale_ :: IdeRule k v + => k -> NormalizedFilePath -> Action (TrackedStale v) +useWithStale_ key file = do + (v, pm) <- IDE.useWithStale_ key file + pure $ TrackedStale (coerce v) (coerce pm) + 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,63 +1,63 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE NondecreasingIndentation #-} - ------------------------------------------------------------------------------ --- --- GHC Driver --- --- (c) The University of Glasgow 2005 --- ------------------------------------------------------------------------------ - -module Development.IDE.GHC.CPP(doCpp, addOptP) -where - -import Development.IDE.GHC.Compat as Compat -import GHC -#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 qualified DriverPipeline as Pipeline -import ToolSettings -#else -import DynFlags -#endif -#endif - -addOptP :: String -> DynFlags -> DynFlags -#if MIN_VERSION_ghc (8,10,0) -addOptP f = alterToolSettings $ \s -> s - { toolSettings_opt_P = f : toolSettings_opt_P s - , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) - } - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -#else -addOptP opt = onSettings (onOptP (opt:)) - where - onSettings f x = x{settings = f $ settings x} - onOptP f x = x{sOpt_P = f $ sOpt_P x} -#endif - -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 - +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module Development.IDE.GHC.CPP(doCpp, addOptP) +where + +import Development.IDE.GHC.Compat as Compat +import GHC +#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 qualified DriverPipeline as Pipeline +import ToolSettings +#else +import DynFlags +#endif +#endif + +addOptP :: String -> DynFlags -> DynFlags +#if MIN_VERSION_ghc (8,10,0) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } +#else +addOptP opt = onSettings (onOptP (opt:)) + where + onSettings f x = x{settings = f $ settings x} + onOptP f x = x{sOpt_P = f $ sOpt_P x} +#endif + +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 + 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 @@ -20,6 +20,7 @@ reLocA, getMessages', pattern PFailedWithErrorMessages, + isObjectLinkable, #if !MIN_VERSION_ghc(9,0,1) RefMap, @@ -28,6 +29,7 @@ #if MIN_VERSION_ghc(9,2,0) extendModSummaryNoDeps, emsModSummary, + myCoreToStgExpr, #endif nodeInfo', @@ -69,6 +71,39 @@ Option (..), runUnlit, runPp, + + -- * Recompilation avoidance + hscCompileCoreExprHook, + CoreExpr, + simplifyExpr, + tidyExpr, + emptyTidyEnv, + corePrepExpr, + lintInteractiveExpr, + icInteractiveModule, + HomePackageTable, + lookupHpt, + Dependencies(dep_mods), + bcoFreeNames, + ModIfaceAnnotation, + pattern Annotation, + AnnTarget(ModuleTarget), + extendAnnEnvList, + module UniqDSet, + module UniqSet, + module UniqDFM, + getDependentMods, +#if MIN_VERSION_ghc(9,2,0) + loadExpr, + byteCodeGen, + bc_bcos, + loadDecls, + hscInterp, + expectJust, +#else + coreExprToBCOs, + linkExpr, +#endif ) where import Development.IDE.GHC.Compat.Core @@ -84,7 +119,48 @@ import GHC hiding (HasSrcSpan, ModLocation, RealSrcSpan, getLoc, - lookupName) + lookupName, exprType) +#if MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Hooks (hscCompileCoreExprHook) +import GHC.Core (CoreExpr, CoreProgram) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.Types.Var.Env (emptyTidyEnv) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Core.Lint (lintInteractiveExpr) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable) +import GHC.Runtime.Context (icInteractiveModule) +import GHC.Unit.Module.Deps (Dependencies(dep_mods)) +import GHC.Linker.Types (isObjectLinkable) +import GHC.Linker.Loader (loadExpr) +#else +import GHC.CoreToByteCode (coreExprToBCOs) +import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable) +import GHC.Runtime.Linker (linkExpr) +#endif +import GHC.ByteCode.Asm (bcoFreeNames) +import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet +import GHC.Types.Unique.DFM as UniqDFM +#else +import Hooks (hscCompileCoreExprHook) +import CoreSyn (CoreExpr) +import qualified SimplCore as GHC +import CoreTidy (tidyExpr) +import VarEnv (emptyTidyEnv) +import CorePrep (corePrepExpr) +import CoreLint (lintInteractiveExpr) +import ByteCodeGen (coreExprToBCOs) +import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods)) +import Linker (linkExpr) +import ByteCodeAsm (bcoFreeNames) +import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) +import UniqDSet +import UniqSet +import UniqDFM +#endif #if MIN_VERSION_ghc(9,0,0) import GHC.Data.StringBuffer @@ -142,12 +218,90 @@ import Bag (unitBag) #endif +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.CostCentre +import GHC.Stg.Syntax +import GHC.Types.IPE +import GHC.Stg.Syntax +import GHC.Types.IPE +import GHC.Types.CostCentre +import GHC.Core +import GHC.Builtin.Uniques +import GHC.Runtime.Interpreter +import GHC.StgToByteCode +import GHC.Stg.Pipeline +import GHC.ByteCode.Types +import GHC.Linker.Loader (loadDecls) +import GHC.Data.Maybe +import GHC.CoreToStg +#endif + +type ModIfaceAnnotation = Annotation + +#if MIN_VERSION_ghc(9,2,0) +myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext + -> Module -> ModLocation -> CoreExpr + -> IO ( Id + , [StgTopBinding] + , InfoTableProvMap + , CollectedCCs ) +myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do + {- Create a temporary binding (just because myCoreToStg needs a + binding for the stg2stg step) -} + let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") + (mkPseudoUniqueE 0) + Many + (exprType prepd_expr) + (stg_binds, prov_map, collected_ccs) <- + myCoreToStg logger + dflags + ictxt + this_mod + ml + [NonRec bco_tmp_id prepd_expr] + return (bco_tmp_id, stg_binds, prov_map, collected_ccs) + +myCoreToStg :: Logger -> DynFlags -> InteractiveContext + -> Module -> ModLocation -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , InfoTableProvMap + , CollectedCCs ) -- CAF cost centre info (declared and used) +myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do + let (stg_binds, denv, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod ml prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} + stg2stg logger dflags ictxt this_mod stg_binds + + return (stg_binds2, denv, cost_centre_info) +#endif + + #if !MIN_VERSION_ghc(9,2,0) reLoc :: Located a -> Located a reLoc = id reLocA :: Located a -> Located a reLocA = id +#endif + +getDependentMods :: ModIface -> [ModuleName] +#if MIN_VERSION_ghc(9,0,0) +getDependentMods = map gwib_mod . dep_mods . mi_deps +#else +getDependentMods = map fst . dep_mods . mi_deps +#endif + +simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +#if MIN_VERSION_ghc(9,0,0) +simplifyExpr _ = GHC.simplifyExpr + +corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr _ = GHC.corePrepExpr +#else +simplifyExpr df _ = GHC.simplifyExpr df #endif #if !MIN_VERSION_ghc(8,8,0) diff --git a/src/Development/IDE/GHC/Compat/CPP.hs b/src/Development/IDE/GHC/Compat/CPP.hs --- a/src/Development/IDE/GHC/Compat/CPP.hs +++ b/src/Development/IDE/GHC/Compat/CPP.hs @@ -1,204 +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 Control.Monad -import Data.List (intercalate) -import Data.Maybe -import Data.Version -import DynFlags -import Module (rtsUnitId, toInstalledUnitId) -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 +-- 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 Control.Monad +import Data.List (intercalate) +import Data.Maybe +import Data.Version +import DynFlags +import Module (rtsUnitId, toInstalledUnitId) +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 --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -141,6 +141,9 @@ ImportSpec(..), -- * SourceText SourceText(..), +#if !MIN_VERSION_ghc(9,2,0) + rationalFromFractionalLit, +#endif -- * Name tyThingParent_maybe, -- * Ways @@ -1075,4 +1078,9 @@ #if !MIN_VERSION_ghc(9,2,0) pattern HsLet xlet localBinds expr <- GHC.HsLet xlet (SrcLoc.unLoc -> localBinds) expr pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds) +#endif + +#if !MIN_VERSION_ghc(9,2,0) +rationalFromFractionalLit :: FractionalLit -> Rational +rationalFromFractionalLit = fl_value #endif diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -8,11 +8,12 @@ showSDocForUser, ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, printSDocQualifiedUnsafe, - printNameWithoutUniques, - printSDocAllTheWay, + printWithoutUniques, mkPrintUnqualified, mkPrintUnqualifiedDefault, PrintUnqualified(..), + defaultUserStyle, + withPprStyle, -- * Parser errors PsWarning, PsError, @@ -43,7 +44,8 @@ import GHC.Types.SrcLoc import GHC.Unit.State import GHC.Utils.Error hiding (mkWarnMsg) -import GHC.Utils.Outputable +import GHC.Utils.Outputable as Out hiding (defaultUserStyle) +import qualified GHC.Utils.Outputable as Out import GHC.Utils.Panic #elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Session @@ -52,25 +54,37 @@ 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 +import GHC.Utils.Outputable as Out hiding (defaultUserStyle) +import qualified 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 Outputable as Out hiding (defaultUserStyle) +import qualified Outputable as Out import SrcLoc #endif -printNameWithoutUniques :: Outputable a => a -> String -printNameWithoutUniques = +-- | A compatible function to print `Outputable` instances +-- without unique symbols. +-- +-- It print with a user-friendly style like: `a_a4ME` as `a`. +printWithoutUniques :: Outputable a => a -> String +printWithoutUniques = #if MIN_VERSION_ghc(9,2,0) - renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) . ppr + renderWithContext (defaultSDocContext + { + sdocStyle = defaultUserStyle + , sdocSuppressUniques = True + , sdocCanUseUnicode = True + }) . ppr #else - printSDocAllTheWay dyn . ppr - where - dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques + go . ppr + where + go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) + dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques #endif printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String @@ -86,15 +100,7 @@ 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) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc oldMkUserStyle _ = Out.mkUserStyle oldMkErrStyle _ = Out.mkErrStyle @@ -102,8 +108,7 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext where dummySDocContext = initSDocContext dflags Out.defaultUserStyle - -#else +#elif !MIN_VERSION_ghc(9,0,0) oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String oldRenderWithStyle = Out.renderWithStyle @@ -116,7 +121,6 @@ oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc = Err.formatErrDoc #endif -#endif pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = @@ -164,7 +168,7 @@ mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualifiedDefault env = #if MIN_VERSION_ghc(9,2,0) - -- GHC 9.2.1 version + -- GHC 9.2 version -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified (hsc_unit_env env) #else @@ -177,4 +181,11 @@ const Error.mkWarnMsg #else Err.mkWarnMsg +#endif + +defaultUserStyle :: PprStyle +#if MIN_VERSION_ghc(9,0,0) +defaultUserStyle = Out.defaultUserStyle +#else +defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags #endif diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -41,6 +41,8 @@ #if !MIN_VERSION_ghc(9,2,0) Anno.AnnotationComment(..), #endif + pattern EpaLineComment, + pattern EpaBlockComment ) where #if MIN_VERSION_ghc(9,0,0) @@ -51,12 +53,18 @@ import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..)) #if MIN_VERSION_ghc(9,2,0) -import GHC (pm_extra_src_files, +import GHC (Anchor (anchor), + EpAnnComments (priorComments), + EpaComment (EpaComment), + EpaCommentTok (..), + epAnnComments, + pm_extra_src_files, pm_mod_summary, pm_parsed_source) import qualified GHC import qualified GHC.Driver.Config as Config -import GHC.Hs (hpm_module, hpm_src_files) +import GHC.Hs (LEpaComment, hpm_module, + hpm_src_files) import GHC.Parser.Lexer hiding (initParserState) #endif #else @@ -100,6 +108,8 @@ #endif #if MIN_VERSION_ghc(9,2,0) +-- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the +-- annotations are found in the ast. type ApiAnns = () #else type ApiAnns = Anno.ApiAnns @@ -154,4 +164,9 @@ Map.fromList ((SrcLoc.noSrcSpan,comment_q pst) :annotations_comments pst)) #endif +#endif + +#if !MIN_VERSION_ghc(9,2,0) +pattern EpaLineComment a = Anno.AnnLineComment a +pattern EpaBlockComment a = Anno.AnnBlockComment a #endif 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 @@ -23,7 +23,6 @@ transformM, ExactPrint(..), #if !MIN_VERSION_ghc(9,2,0) - useAnnotatedSource, Anns, Annotate, setPrecedingLinesT, @@ -44,6 +43,7 @@ ASTElement (..), ExceptStringT (..), TransformT, + Log(..), ) where @@ -67,13 +67,18 @@ import Data.Traversable (for) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, parseType) import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import qualified GHC.Generics as GHC import Generics.SYB import Generics.SYB.GHC @@ -101,6 +106,12 @@ ------------------------------------------------------------------------------ +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) @@ -109,8 +120,8 @@ type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource -- | Get the latest version of the annotated parse source with comments. -getAnnotatedParsedSourceRule :: Rules () -getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do +getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () +getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do pm <- use GetParsedModuleWithComments nfp return ([], fmap annotateParsedSource pm) @@ -120,16 +131,6 @@ #else annotateParsedSource :: ParsedModule -> Annotated ParsedSource annotateParsedSource = fixAnns -#endif - -#if !MIN_VERSION_ghc(9,2,0) -useAnnotatedSource :: - String -> - IdeState -> - NormalizedFilePath -> - IO (Maybe (Annotated ParsedSource)) -useAnnotatedSource herald state nfp = - runAction herald state (use GetAnnotatedParsedSource nfp) #endif ------------------------------------------------------------------------------ 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 @@ -39,24 +39,35 @@ import Data.Bifunctor (Bifunctor (..)) import Data.Hashable import Data.String (IsString (fromString)) +import Data.Text (unpack) +#if MIN_VERSION_ghc(9,0,0) +import GHC.ByteCode.Types +#else +import ByteCodeTypes +#endif -- Orphan instances for types from the GHC API. -instance Show CoreModule where show = prettyPrint +instance Show CoreModule where show = unpack . printOutputable instance NFData CoreModule where rnf = rwhnf -instance Show CgGuts where show = prettyPrint . cg_module +instance Show CgGuts where show = unpack . printOutputable . cg_module instance NFData CgGuts where rnf = rwhnf instance Show ModDetails where show = const "" instance NFData ModDetails where rnf = rwhnf instance NFData SafeHaskellMode where rnf = rwhnf -instance Show Linkable where show = prettyPrint -instance NFData Linkable where rnf = rwhnf -instance Show PackageFlag where show = prettyPrint -instance Show InteractiveImport where show = prettyPrint -instance Show PackageName where show = prettyPrint +instance Show Linkable where show = unpack . printOutputable +instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c +instance NFData Unlinked where + rnf (DotO f) = rnf f + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b +instance Show PackageFlag where show = unpack . printOutputable +instance Show InteractiveImport where show = unpack . printOutputable +instance Show PackageName where show = unpack . printOutputable #if !MIN_VERSION_ghc(9,0,1) -instance Show ComponentId where show = prettyPrint -instance Show SourcePackageId where show = prettyPrint +instance Show ComponentId where show = unpack . printOutputable +instance Show SourcePackageId where show = unpack . printOutputable instance Show GhcPlugins.InstalledUnitId where show = installedUnitIdString @@ -66,7 +77,7 @@ instance Hashable GhcPlugins.InstalledUnitId where hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else -instance Show UnitId where show = prettyPrint +instance Show UnitId where show = unpack . printOutputable deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif @@ -76,7 +87,7 @@ instance Show Module where show = moduleNameString . moduleName -instance Outputable a => Show (GenLocated SrcSpan a) where show = prettyPrint +instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable instance (NFData l, NFData e) => NFData (GenLocated l e) where rnf (L l e) = rnf l `seq` rnf e @@ -197,5 +208,5 @@ #endif rnf = rwhnf -instance Show OccName where show = prettyPrint +instance Show OccName where show = unpack . printOutputable instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) 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 @@ -7,8 +7,6 @@ modifyDynFlags, evalGhcEnv, -- * GHC wrappers - prettyPrint, - unsafePrintSDoc, printRdrName, Development.IDE.GHC.Util.printName, ParseResult(..), runParser, @@ -28,7 +26,9 @@ setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - traceAst) where + traceAst, + printOutputable + ) where #if MIN_VERSION_ghc(9,2,0) import GHC.Data.FastString @@ -130,16 +130,9 @@ bytestringToStringBuffer :: ByteString -> StringBuffer bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} --- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. -prettyPrint :: Outputable a => a -> String -prettyPrint = unsafePrintSDoc . ppr - -unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = showSDocUnsafe sdoc - -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String -printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn) +printRdrName name = T.unpack $ printOutputable $ parenSymOcc rn (ppr rn) where rn = rdrNameOcc name @@ -304,7 +297,7 @@ #if MIN_VERSION_ghc(9,2,0) renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True} #else - renderDump = unsafePrintSDoc + renderDump = showSDocUnsafe . ppr #endif htmlDump = showAstDataHtml x doTrace = unsafePerformIO $ do @@ -318,4 +311,18 @@ #endif , "file://" ++ htmlDumpFileName] +-- Should in `Development.IDE.GHC.Orphans`, +-- leave it here to prevent cyclic module dependency +#if !MIN_VERSION_ghc(8,10,0) +instance Outputable SDoc where + ppr = id +#endif +-- | Print a GHC value in `defaultUserStyle` without unique symbols. +-- +-- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`. +-- +-- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`. +printOutputable :: Outputable a => a -> T.Text +printOutputable = T.pack . printWithoutUniques +{-# INLINE printOutputable #-} 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 @@ -129,6 +129,7 @@ -- need to add edges between .hs-boot and .hs so that the .hs files -- appear later in the sort. , rawBootMap :: !BootIdMap + , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName) } deriving Show data DependencyInformation = @@ -220,15 +221,12 @@ { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps , depReverseModuleDeps = reverseModuleDeps - , depModuleNames = IntMap.fromList $ coerce moduleNames + , depModuleNames = rawModuleNameMap , depPathIdMap = rawPathIdMap , depBootMap = rawBootMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph - moduleNames :: [(FilePathId, ModuleName)] - moduleNames = - [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports] successEdges :: [(FilePathId, [FilePathId])] successEdges = map 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 @@ -10,6 +10,7 @@ -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer + , Log(..) ) where import Control.Concurrent.STM @@ -31,35 +32,61 @@ import UnliftIO.Directory import UnliftIO.Exception -import Development.IDE.Core.FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Development.IDE.Session as Session +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) import System.IO.Unsafe (unsafeInterleaveIO) -issueTrackerUrl :: T.Text -issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" +data Log + = LogRegisteringIdeConfig !IdeConfiguration + | LogReactorThreadException !SomeException + | LogReactorMessageActionException !SomeException + | LogReactorThreadStopped + | LogCancelledRequest !SomeLspId + | LogSession Session.Log + deriving Show +instance Pretty Log where + pretty = \case + LogRegisteringIdeConfig ideConfig -> + "Registering IDE configuration:" <+> viaShow ideConfig + LogReactorThreadException e -> + vcat + [ "ReactorThreadException" + , pretty $ displayException e ] + LogReactorMessageActionException e -> + vcat + [ "ReactorMessageActionException" + , pretty $ displayException e ] + LogReactorThreadStopped -> + "Reactor thread stopped" + LogCancelledRequest requestId -> + "Cancelled request" <+> viaShow requestId + LogSession log -> pretty log + -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config. (Show config) - => LSP.Options + => Recorder (WithPriority Log) + -> LSP.Options -> Handle -- input -> Handle -- output -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> config -> (config -> Value -> Either T.Text config) -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do +runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. @@ -128,6 +155,9 @@ serverDefinition where + log :: Logger.Priority -> Log -> IO () + log = logWith recorder + handleInit :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) @@ -142,33 +172,20 @@ dbMVar <- newEmptyMVar ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - ide <- getIdeState env (makeLSPVFSHandle env) root withHieDb hieChan + ide <- getIdeState env root withHieDb hieChan let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + + log Info $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError logger $ - T.pack $ "Fatal error in server thread: " <> show e - sendErrorMessage e + log Error $ LogReactorThreadException e exitClientMsg handleServerException (Right _) = pure () - sendErrorMessage (e :: SomeException) = do - LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtError $ T.unlines - [ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): " - , T.pack(show e) - ] - exceptionInHandler e = do - logError logger $ T.pack $ - "Unexpected exception, please report!\n" ++ - "Exception: " ++ show e - sendErrorMessage e - - logger = ideLogger ide + log Error $ LogReactorMessageActionException e checkCancelled _id act k = flip finally (clearReqId _id) $ @@ -180,14 +197,14 @@ cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + log Debug $ LogCancelledRequest _id k $ ResponseError RequestCancelled "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError InternalError (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb logger dbLoc $ \withHieDb hieChan -> do + untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) forever $ do msg <- readChan clientMsgChan @@ -196,7 +213,7 @@ case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logInfo logger "Reactor thread stopped" + log Info LogReactorThreadStopped pure $ Right (env,ide) 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 @@ -9,6 +9,7 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor + , Log(..) ) where import Language.LSP.Types @@ -26,57 +27,69 @@ resetFileStore, setFileModified, setSomethingModified) +import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log, LogShake) +import Development.IDE.Core.Shake hiding (Log, Priority) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) import Ide.Types +data Log + = LogShake Shake.Log + | LogFileStore FileStore.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogFileStore log -> pretty log + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ - \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do + \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open addFileOfInterest ide file Modified{firstOpen=True} - setFileModified ide False file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidChange $ - \ide _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do + \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} - setFileModified ide False file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidSave $ - \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do + \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk - setFileModified ide True file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidClose $ - \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do + \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file let msg = "Closed text document: " <> getUri _uri scheduleGarbageCollection ide - setSomethingModified ide [] $ Text.unpack msg + setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg logDebug (ideLogger ide) msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do + \ide vfs _ (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 -- filter out files of interest, since we already know all about those @@ -93,10 +106,10 @@ logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg modifyFileExists ide fileEvents' resetFileStore ide fileEvents' - setSomethingModified ide [] msg + setSomethingModified (VFSModified vfs) ide [] msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ - \ide _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do + \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do let add = S.union substract = flip S.difference modifyWorkspaceFolders ide @@ -104,15 +117,15 @@ . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $ - \ide _ (DidChangeConfigurationParams cfg) -> liftIO $ do + \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do let msg = Text.pack $ show cfg logDebug (ideLogger ide) $ "Configuration changed: " <> msg modifyClientSettings ide (const $ Just cfg) - setSomethingModified ide [toKey GetClientSettings emptyFilePath] "config change" + setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" - , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do + , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- - liftIO $ shakeSessionInit ide + liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide --------- Set up file watchers ------------------------------------------------------------------------ opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide 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 @@ -13,7 +13,6 @@ import Data.Functor import Data.Generics import Data.Maybe -import Data.Text (Text, pack) import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake @@ -21,6 +20,7 @@ import Development.IDE.GHC.Error (rangeToRealSrcSpan, realSrcSpanToRange) import Development.IDE.Types.Location +import Development.IDE.GHC.Util (printOutputable) import Language.LSP.Server (LspM) import Language.LSP.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), @@ -47,7 +47,7 @@ moduleSymbol = hsmodName >>= \case (L (locA -> (RealSrcSpan l _)) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) - { _name = pprText m + { _name = printOutputable m , _kind = SkFile , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } @@ -70,18 +70,18 @@ documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n - <> (case pprText fdTyVars of + { _name = printOutputable n + <> (case printOutputable fdTyVars of "" -> "" t -> " " <> t ) - , _detail = Just $ pprText fdInfo + , _detail = Just $ printOutputable fdInfo , _kind = SkFunction } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name - <> (case pprText tcdTyVars of + { _name = printOutputable name + <> (case printOutputable tcdTyVars of "" -> "" t -> " " <> t ) @@ -90,7 +90,7 @@ , _children = Just $ List [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n + { _name = printOutputable n , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } @@ -100,12 +100,12 @@ } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name + { _name = printOutputable name , _kind = SkStruct , _children = Just $ List [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n + { _name = printOutputable n , _kind = SkConstructor , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0) @@ -123,7 +123,7 @@ where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName (unLoc (rdrNameFieldOcc n)) + { _name = printOutputable (unLoc (rdrNameFieldOcc n)) , _kind = SkField } cvtFld _ = Nothing @@ -138,7 +138,7 @@ -- | Extract the record fields of a constructor conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List [ (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName n + { _name = printOutputable n , _kind = SkField } | L _ cdf <- lcdfs @@ -147,12 +147,12 @@ conArgRecordFields _ = Nothing #endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just - (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) - = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty + = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty , _kind = SkInterface } #if MIN_VERSION_ghc(9,2,0) @@ -161,8 +161,8 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords - (map pprText feqn_pats) + { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) , _kind = SkInterface } #if MIN_VERSION_ghc(9,2,0) @@ -171,24 +171,24 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) #endif = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords - (map pprText feqn_pats) + { _name = printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) , _kind = SkInterface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> - (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) name , _kind = SkInterface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = showRdrName name + { _name = printOutputable name , _kind = SkFunction } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = pprText pat_lhs + { _name = printOutputable pat_lhs , _kind = SkFunction } @@ -204,7 +204,7 @@ ForeignExport{} -> Just "export" XForeignDecl{} -> Nothing } - where name = showRdrName $ unLoc $ fd_name x + where name = printOutputable $ unLoc $ fd_name x documentSymbolForDecl _ = Nothing @@ -228,7 +228,7 @@ documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) - { _name = "import " <> pprText ideclName + { _name = "import " <> printOutputable ideclName , _kind = SkModule #if MIN_VERSION_ghc(8,10,0) , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } @@ -248,12 +248,6 @@ _selectionRange = realSrcSpanToRange l _children = Nothing _tags = Nothing - -showRdrName :: RdrName -> Text -showRdrName = pprText - -pprText :: Outputable a => a -> Text -pprText = pack . showSDocUnsafe . ppr -- the version of getConNames for ghc9 is restricted to only the renaming phase #if !MIN_VERSION_ghc(9,2,0) diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -22,6 +22,7 @@ import Language.LSP.Server (Handlers, LspM) import qualified Language.LSP.Server as LSP import Language.LSP.Types +import Language.LSP.VFS import UnliftIO.Chan data ReactorMessage @@ -48,14 +49,16 @@ notificationHandler :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => SMethod m - -> (IdeState -> MessageParams m -> LspM c ()) + -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c) notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do (chan,ide) <- ask env <- LSP.getLspEnv + -- Take a snapshot of the VFS state on every notification + -- We only need to do this here because the VFS state is only updated + -- on notifications + vfs <- LSP.getVirtualFiles let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do traceWithSpan sp _params x - writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) - - + writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide vfs _params) 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 @@ -8,13 +8,14 @@ ,isLSP ,commandP ,defaultMain -,testing) where -import Control.Concurrent.Extra (newLock, withLock, - withNumCapabilities) +,testing +,Log(..) +) where +import Control.Concurrent.Extra (withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) -import Control.Exception.Safe (Exception (displayException), - catchAny) +import Control.Exception.Safe (SomeException, catchAny, + displayException) import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A @@ -26,18 +27,16 @@ nub, nubOrd, partition) import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T -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 (..), - Priority (Debug), Rules, + Priority (Debug, Error), Rules, ghcVersion, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported, - makeVFSHandle) +import Development.IDE.Core.FileStore (isWatchSupported) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), @@ -50,17 +49,23 @@ TypeCheck (TypeCheck)) import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), mainRule) +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Service (initialise, runAction) +import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), shakeSessionInit, uses) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) +import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) +import qualified Development.IDE.Main.HeapStats as HeapStats import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Plugin.HLS as PluginHLS +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, @@ -68,11 +73,14 @@ retryOnSqliteBusy, runWithDb, setInitialDynFlags) +import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger (Logger), - Priority (Info), - logDebug, logInfo) +import Development.IDE.Types.Logger (Logger, Pretty (pretty), + Priority (Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + vsep, (<+>)) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -118,10 +126,49 @@ hSetEncoding, stderr, stdin, stdout, utf8) import System.Random (newStdGen) -import System.Time.Extra (offsetTime, +import System.Time.Extra (Seconds, offsetTime, showDuration) import Text.Printf (printf) +data Log + = LogHeapStats !HeapStats.Log + | LogLspStart + | LogLspStartDuration !Seconds + | LogShouldRunSubset !Bool + | LogOnlyPartialGhc9Support + | LogSetInitialDynFlagsException !SomeException + | LogService Service.Log + | LogShake Shake.Log + | LogGhcIde GhcIde.Log + | LogLanguageServer LanguageServer.Log + | LogSession Session.Log + | LogPluginHLS PluginHLS.Log + | LogRules Rules.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogHeapStats log -> pretty log + LogLspStart -> + vsep + [ "Staring LSP server..." + , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] + LogLspStartDuration duration -> + "Started LSP server in" <+> pretty (showDuration duration) + LogShouldRunSubset shouldRunSubset -> + "shouldRunSubset:" <+> pretty shouldRunSubset + LogOnlyPartialGhc9Support -> + "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + LogSetInitialDynFlagsException e -> + "setInitialDynFlags:" <+> pretty (displayException e) + LogService log -> pretty log + LogShake log -> pretty log + LogGhcIde log -> pretty log + LogLanguageServer log -> pretty log + LogSession log -> pretty log + LogPluginHLS log -> pretty log + LogRules log -> pretty log + data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} @@ -132,7 +179,6 @@ | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show - -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options @@ -144,8 +190,8 @@ commandP :: IdePlugins IdeState -> Parser Command commandP plugins = hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo) - <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser <**> helper) hieInfo) - <> command "lsp" (info (pure LSP <**> helper) lspInfo) + <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser) hieInfo) + <> command "lsp" (info (pure LSP) lspInfo) <> command "vscode-extension-schema" extensionSchemaCommand <> command "generate-default-config" generateDefaultConfigCommand <> pluginCommands @@ -187,18 +233,16 @@ , argsThreads :: Maybe Natural } -instance Default Arguments where - def = defaultArguments Info -defaultArguments :: Priority -> Arguments -defaultArguments priority = Arguments +defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments +defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing , argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger priority - , argsRules = mainRule def >> action kick + , argsLogger = pure logger + , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors + , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -226,35 +270,39 @@ 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 :: Priority -> IO Logger -stderrLogger logLevel = do - lock <- newLock - return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ - T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m +testing :: Recorder (WithPriority Log) -> Logger -> Arguments +testing recorder logger = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc argsHlsPlugins + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions = \config sessionLoader -> + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + } -defaultMain :: Arguments -> IO () -defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger + +defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () +defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where + log :: Priority -> Log -> IO () + log = logWith recorder + fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID logger <- argsLogger hSetBuffering stderr LineBuffering - let hlsPlugin = asGhcIdePlugin argsHlsPlugins + let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } @@ -274,29 +322,29 @@ LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do t <- offsetTime - 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 withHieDb hieChan -> do + log Info LogLspStart + + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t - logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t + log Info $ LogLspStartDuration 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 logger dir argsSessionLoadingOptions - `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) - + setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + -- TODO: should probably catch/log/rethrow at top level instead + `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - logDebug logger $ T.pack $ "runSubset: " <> show runSubset + log Debug $ LogShouldRunSubset runSubset let options = def_options { optReportProgress = clientSupportsProgress caps @@ -306,24 +354,22 @@ caps = LSP.resClientCapabilities env -- FIXME: Remove this after GHC 9 gets fully supported when (ghcVersion == GHC90) $ - hPutStrLn stderr $ - "Currently, HLS supports GHC 9 only partially. " - <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + log Warning LogOnlyPartialGhc9Support initialise + (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules (Just env) logger debouncer options - vfs withHieDb hieChan dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb logger dbLoc $ \hiedb hieChan -> do + runWithDb (cmapWithPrio LogSession recorder) 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 @@ -344,16 +390,15 @@ putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit ide + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" @@ -388,26 +433,25 @@ root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags logger root def + mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 - Just libdir -> retryOnSqliteBusy logger rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) + Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb logger dbLoc $ \hiedb hieChan -> do - vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." + runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit ide + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan + shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs --- a/src/Development/IDE/Main/HeapStats.hs +++ b/src/Development/IDE/Main/HeapStats.hs @@ -1,53 +1,75 @@ -{-# LANGUAGE NumericUnderscores #-} --- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats ) where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Monad -import qualified Data.Text as T -import Data.Word -import Development.IDE.Types.Logger (Logger, logInfo) -import GHC.Stats -import Text.Printf (printf) - --- | Interval at which to report the latest heap statistics. -heapStatsInterval :: Int -heapStatsInterval = 60_000_000 -- 60s - --- | Report the live bytes and heap size at the last major collection. -logHeapStats :: Logger -> IO () -logHeapStats l = do - stats <- getRTSStats - -- live_bytes is the total amount of live memory in a program - -- (corresponding to the amount on a heap profile) - let live_bytes = gcdetails_live_bytes (gc stats) - -- heap_size is the total amount of memory the RTS is using - -- this corresponds closer to OS memory usage - heap_size = gcdetails_mem_in_use_bytes (gc stats) - format :: Word64 -> T.Text - format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) - message = "Live bytes: " <> format live_bytes <> " " <> - "Heap size: " <> format heap_size - logInfo l message - --- | An action which logs heap statistics at the 'heapStatsInterval' -heapStatsThread :: Logger -> IO r -heapStatsThread l = forever $ do - threadDelay heapStatsInterval - logHeapStats l - --- | A helper function which lauches the 'heapStatsThread' and kills it --- appropiately when the inner action finishes. It also checks to see --- if `-T` is enabled. -withHeapStats :: Logger -> IO r -> IO r -withHeapStats l k = do - enabled <- getRTSStatsEnabled - if enabled - then do - logInfo l ("Logging heap statistics every " - <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) - withAsync (heapStatsThread l) (const k) - else do - logInfo l "Heap statistics are not enabled (RTS option -T is needed)" - k +{-# LANGUAGE NumericUnderscores #-} +-- | Logging utilities for reporting heap statistics +module Development.IDE.Main.HeapStats ( withHeapStats, Log(..)) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Data.Word +import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) +import GHC.Stats +import Text.Printf (printf) + +data Log + = LogHeapStatsPeriod !Int + | LogHeapStatsDisabled + | LogHeapStats !Word64 !Word64 + deriving Show + +instance Pretty Log where + pretty log = case log of + LogHeapStatsPeriod period -> + "Logging heap statistics every" <+> pretty (toFormattedSeconds period) + LogHeapStatsDisabled -> + "Heap statistics are not enabled (RTS option -T is needed)" + LogHeapStats liveBytes heapSize -> + hsep + [ "Live bytes:" + , pretty (toFormattedMegabytes liveBytes) + , "Heap size:" + , pretty (toFormattedMegabytes heapSize) ] + where + toFormattedSeconds :: Int -> String + toFormattedSeconds s = printf "%.2fs" (fromIntegral @Int @Double s / 1e6) + + toFormattedMegabytes :: Word64 -> String + toFormattedMegabytes b = printf "%.2fMB" (fromIntegral @Word64 @Double b / 1e6) + +-- | Interval at which to report the latest heap statistics. +heapStatsInterval :: Int +heapStatsInterval = 60_000_000 -- 60s + +-- | Report the live bytes and heap size at the last major collection. +logHeapStats :: Recorder (WithPriority Log) -> IO () +logHeapStats l = do + stats <- getRTSStats + -- live_bytes is the total amount of live memory in a program + -- (corresponding to the amount on a heap profile) + let live_bytes = gcdetails_live_bytes (gc stats) + -- heap_size is the total amount of memory the RTS is using + -- this corresponds closer to OS memory usage + heap_size = gcdetails_mem_in_use_bytes (gc stats) + logWith l Info $ LogHeapStats live_bytes heap_size + +-- | An action which logs heap statistics at the 'heapStatsInterval' +heapStatsThread :: Recorder (WithPriority Log) -> IO r +heapStatsThread l = forever $ do + threadDelay heapStatsInterval + logHeapStats l + +-- | A helper function which lauches the 'heapStatsThread' and kills it +-- appropiately when the inner action finishes. It also checks to see +-- if `-T` is enabled. +withHeapStats :: Recorder (WithPriority Log) -> IO r -> IO r +withHeapStats l k = do + enabled <- getRTSStatsEnabled + if enabled + then do + logWith l Info $ LogHeapStatsPeriod heapStatsInterval + withAsync (heapStatsThread l) (const k) + else do + logWith l Info LogHeapStatsDisabled + k + 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 @@ -48,15 +48,13 @@ import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint -import Development.IDE.GHC.Util (prettyPrint, +import Development.IDE.GHC.Util (printOutputable, printRdrName, - traceAst, - unsafePrintSDoc) + traceAst) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.TypeLenses (suggestSignature) -import Development.IDE.Spans.Common import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -546,7 +544,7 @@ isTheBinding span = srcSpanToRange span == Just _range isSameName :: IdP GhcPs -> String -> Bool - isSameName x name = showSDocUnsafe (ppr x) == name + isSameName x name = T.unpack (printOutputable x) == name data ExportsAs = ExportName | ExportPattern | ExportFamily | ExportAll deriving (Eq) @@ -711,7 +709,7 @@ , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig - , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])] + , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = _"])] )] | otherwise = [] where @@ -719,7 +717,6 @@ sig = name <> colon <> T.dropWhileEnd isSpace typ ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule - suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] suggestFillTypeWildcard Diagnostic{_range=_range,..} -- Foo.hs:3:8: error: @@ -1014,7 +1011,7 @@ occursUnqualified _ _ = False symbolOccursIn :: T.Text -> IE GhcPs -> Bool -symbolOccursIn symb = any ((== symb). showNameWithoutUniques) . ieNames +symbolOccursIn symb = any ((== symb). printOutputable) . ieNames targetModuleName :: ModuleTarget -> ModuleName targetModuleName ImplicitPrelude{} = mkModuleName "Prelude" @@ -1048,12 +1045,12 @@ in Right <$> [ if parensed then Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @(HsExpr GhcPs) df $ - prettyPrint $ + T.unpack $ printOutputable $ HsVar @GhcPs noExtField $ reLocA $ L (mkGeneralSrcSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (mkGeneralSrcSpan "") rdr + T.unpack $ printOutputable $ L (mkGeneralSrcSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L (locA -> l) _)-> srcSpanToRange l == Just range) xs @@ -1424,7 +1421,7 @@ symImp | Just symbol <- mSymbol , symOcc <- mkVarOcc $ T.unpack symbol = - " (" <> T.pack (unsafePrintSDoc (parenSymOcc symOcc $ ppr symOcc)) <> ")" + " (" <> printOutputable (parenSymOcc symOcc $ ppr symOcc) <> ")" | otherwise = "" impStmt = "import " @@ -1530,14 +1527,22 @@ curr <- textInRange range <$> contents pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr + +-- | Extract the type and surround it in parentheses except in obviously safe cases. +-- +-- Inferring when parentheses are actually needed around the type signature would +-- require understanding both the precedence of the context of the hole and of +-- the signature itself. Inserting them (almost) unconditionally is ugly but safe. extractWildCardTypeSignature :: T.Text -> T.Text -extractWildCardTypeSignature = - -- inferring when parens are actually needed around the type signature would - -- require understanding both the precedence of the context of the _ and of - -- the signature itself. Inserting them unconditionally is ugly but safe. - ("(" `T.append`) . (`T.append` ")") . - T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') . - snd . T.breakOnEnd "standing for " +extractWildCardTypeSignature msg = (if enclosed || not application then id else bracket) signature + where + msgSigPart = snd $ T.breakOnEnd "standing for " msg + signature = T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') $ msgSigPart + -- parenthesize type applications, e.g. (Maybe Char) + application = any isSpace . T.unpack $ signature + -- do not add extra parentheses to lists, tuples and already parenthesized types + enclosed = not (T.null signature) && (T.head signature, T.last signature) `elem` [('(',')'), ('[',']')] + bracket = ("(" `T.append`) . (`T.append` ")") extractRenamableTerms :: T.Text -> [T.Text] extractRenamableTerms msg @@ -1610,32 +1615,32 @@ b' = wrapOperatorInParens . unqualify $ b #if !MIN_VERSION_ghc(9,2,0) ranges' (L _ (IEThingWith _ thing _ inners labels)) - | showSDocUnsafe (ppr thing) == b' = [] + | T.unpack (printOutputable thing) == b' = [] | otherwise = - [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] - ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b'] + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] + ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b'] #else ranges' (L _ (IEThingWith _ thing _ inners)) - | showSDocUnsafe (ppr thing) == b' = [] + | T.unpack (printOutputable thing) == b' = [] | otherwise = - [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b'] + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] #endif ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] -rangesForBinding' b (L (locA -> l) x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] +rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] #if !MIN_VERSION_ghc(9,2,0) rangesForBinding' b (L l (IEThingWith _ thing _ inners labels)) #else rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) #endif - | showSDocUnsafe (ppr thing) == b = [l] + | T.unpack (printOutputable thing) == b = [l] | otherwise = - [ locA l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] + [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] #if !MIN_VERSION_ghc(9,2,0) - ++ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b] + ++ [ l' | L l' x <- labels, T.unpack (printOutputable x) == b] #endif rangesForBinding' _ _ = [] @@ -1726,6 +1731,13 @@ -- -- @P@ and @?@ can be a data type and a constructor, a class and a method, -- a class and an associated type/data family, etc. + + | ImportAllConstructors T.Text + -- ^ Import all constructors for a specific data type. + -- + -- import M (P(..)) + -- + -- @P@ can be a data type or a class. deriving Show importStyles :: IdentInfo -> NonEmpty ImportStyle @@ -1734,7 +1746,9 @@ -- Constructors always have to be imported via their parent data type, but -- methods and associated type/data families can also be imported as -- top-level exports. - = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon] + = ImportViaParent rendered p + :| [ImportTopLevel rendered | not isDatacon] + <> [ImportAllConstructors p] | otherwise = ImportTopLevel rendered :| [] @@ -1743,15 +1757,19 @@ renderImportStyle (ImportTopLevel x) = x renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")" renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" +renderImportStyle (ImportAllConstructors p) = p <> "(..)" -- | Used for extending import lists unImportStyle :: ImportStyle -> (Maybe String, String) unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x) unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x) +unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) + quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent" +quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors" quickFixImportKind :: T.Text -> CodeActionKind quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x diff --git a/src/Development/IDE/Plugin/CodeAction/Args.hs b/src/Development/IDE/Plugin/CodeAction/Args.hs --- a/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -65,7 +65,7 @@ pure $ localExports <> pkgExports _ -> pure mempty caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions - caaParsedModule <- onceIO $ runRule GetParsedModule + caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments caaContents <- onceIO $ runRule GetFileContents >>= \case 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 @@ -19,6 +19,8 @@ extendImport, hideSymbol, liftParseAST, + + wildCardSymbol ) where import Control.Applicative @@ -33,7 +35,7 @@ import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (Annotation) import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.Common @@ -49,7 +51,7 @@ DeltaPos (SameLine), EpAnn (..), EpaLocation (EpaDelta), IsUnicodeSyntax (NormalSyntax), NameAdornment (NameParens), NameAnn (..), addAnns, ann, emptyComments, - reAnnL, AnnList (..)) + reAnnL, AnnList (..), TrailingAnn (AddCommaAnn), addTrailingAnnToA) #endif import Language.LSP.Types import Development.IDE.GHC.Util @@ -330,6 +332,7 @@ extendImport mparent identifier lDecl@(L l _) = Rewrite (locA l) $ \df -> do case mparent of + -- This will also work for `ImportAllConstructors` Just parent -> extendImportViaParent df parent identifier lDecl _ -> extendImportTopLevel identifier lDecl @@ -352,8 +355,8 @@ top <- uniqueSrcSpanT let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing let alreadyImported = - showNameWithoutUniques (occName (unLoc rdr)) - `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies) + printOutputable (occName (unLoc rdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies) when alreadyImported $ lift (Left $ thing <> " already imported") @@ -374,15 +377,14 @@ transferAnn (L l' lies) (L l' [x]) id return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])} #else - - x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0) - - let fixLast = if hasSibling then first addComma else id - lies' = over _last fixLast lies ++ [x] + lies' <- addCommaInImportList lies x return $ L l it{ideclHiding = Just (hide, L l' lies')} #endif extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list" +wildCardSymbol :: String +wildCardSymbol = ".." + -- | Add an identifier with its parent to import list -- -- extendImportViaParent "Bar" "Cons" AST: @@ -393,6 +395,11 @@ -- import A () --> import A (Bar(Cons)) -- import A (Foo, Bar) --> import A (Foo, Bar(Cons)) -- import A (Foo, Bar()) --> import A (Foo, Bar(Cons)) +-- +-- extendImportViaParent "Bar" ".." AST: +-- import A () --> import A (Bar(..)) +-- import A (Foo, Bar) -> import A (Foo, Bar(..)) +-- import A (Foo, Bar()) -> import A (Foo, Bar(..)) extendImportViaParent :: DynFlags -> -- | parent (already parenthesized if needs) @@ -428,6 +435,19 @@ #endif -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) | parent == unIEWrappedName ie + , child == wildCardSymbol = do +#if MIN_VERSION_ghc(9,2,0) + let it' = it{ideclHiding = Just (hide, lies)} + thing = IEThingWith newl twIE (IEWildcard 2) [] + newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l''' + lies = L l' $ reverse pre ++ [L l'' thing] ++ xs + return $ L l it' +#else + let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2) [] []) + modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann})) + return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)} +#endif + | parent == unIEWrappedName ie , hasSibling <- not $ null lies' = do srcChild <- uniqueSrcSpanT @@ -436,8 +456,8 @@ childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0 #endif let alreadyImported = - showNameWithoutUniques (occName (unLoc childRdr)) - `elem` map (showNameWithoutUniques @OccName) (listify (const True) lies') + printOutputable (occName (unLoc childRdr)) + `elem` map (printOutputable @OccName) (listify (const True) lies') when alreadyImported $ lift (Left $ child <> " already included in " <> parent <> " imports") @@ -452,9 +472,7 @@ lies = L l' $ reverse pre ++ [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs fixLast = if hasSibling then first addComma else id - return $ if hasSibling - then L l it' - else L l it' + return $ L l it' #endif go hide l' pre (x : xs) = go hide l' (x : pre) xs go hide l' pre [] @@ -490,15 +508,41 @@ -- we need change the ann key from `[]` to `:` to keep parens and other anns. unless hasSibling $ transferAnn (L l' $ reverse pre) (L l' [x]) id + + let lies' = reverse pre ++ [x] #else - x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] + x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] + + let hasSibling = not (null pre) + lies' <- addCommaInImportList (reverse pre) x #endif - return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x])} + return $ L l it{ideclHiding = Just (hide, L l' lies')} extendImportViaParent _ _ _ _ = lift $ Left "Unable to extend the import list via parent" +#if MIN_VERSION_ghc(9,2,0) +-- Add an item in an import list, taking care of adding comma if needed. +addCommaInImportList :: Monad m => + -- | Initial list + [LocatedAn AnnListItem a] + -- | Additionnal item + -> LocatedAn AnnListItem a + -> m [LocatedAn AnnListItem a] +addCommaInImportList lies x = do + let hasSibling = not (null lies) + -- Add the space before the comma + x <- pure $ setEntryDP x (SameLine $ if hasSibling then 1 else 0) + + -- Add the comma (if needed) + let + fixLast = if hasSibling then first addComma else id + lies' = over _last fixLast lies ++ [x] + + pure lies' +#endif + unIEWrappedName :: IEWrappedName (IdP GhcPs) -> String -unIEWrappedName (occName -> occ) = showSDocUnsafe $ parenSymOcc occ (ppr occ) +unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ) hasParen :: String -> Bool hasParen ('(' : _) = True 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 @@ -4,6 +4,7 @@ module Development.IDE.Plugin.Completions ( descriptor + , Log(..) ) where import Control.Concurrent.Async (concurrently) @@ -19,12 +20,14 @@ import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log, + LogShake) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) -import Development.IDE.GHC.Util (prettyPrint) +import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Graph import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) @@ -36,6 +39,10 @@ hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import GHC.Exts (fromList, toList) import Ide.Plugin.Config (Config) import Ide.Types @@ -44,17 +51,23 @@ import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (..)) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = produceCompletions +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP , pluginCommands = [extendImportCommand] , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -produceCompletions :: Rules () -produceCompletions = do - define $ \LocalCompletions file -> do +produceCompletions :: Recorder (WithPriority Log) -> Rules () +produceCompletions recorder = do + define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file pm <- useWithStale GetParsedModule file case pm of @@ -62,7 +75,7 @@ let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) - define $ \NonLocalCompletions file -> do + define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthetizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports @@ -200,7 +213,7 @@ <> "’ from " <> importName <> " (at " - <> T.pack (prettyPrint srcSpan) + <> printOutputable srcSpan <> ")" void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null 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 @@ -31,7 +31,7 @@ import Data.Functor import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.Monoid (First(..)) +import Data.Monoid (First (..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set import Development.IDE.Core.Compile @@ -63,7 +63,7 @@ import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS -import Text.Fuzzy.Parallel (Scored (score_), +import Text.Fuzzy.Parallel (Scored (score), original) -- Chunk size used for parallelizing fuzzy matching @@ -204,7 +204,7 @@ where kind = Just compKind docs' = imported : spanDocToMarkdown docs imported = case provenance of - Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n'" + 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 ":: " @@ -214,7 +214,7 @@ pprLineCol :: SrcLoc -> T.Text pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs pprLineCol (RealSrcLoc loc _) = - "line " <> ppr(srcLocLine loc) <> ", column " <> ppr(srcLocCol loc) + "line " <> printOutputable (srcLocLine loc) <> ", column " <> printOutputable (srcLocCol loc) mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command @@ -226,16 +226,16 @@ where compKind = occNameToComKind typeText origName isTypeCompl = isTcOcc origName - label = stripPrefix $ showGhc origName + label = stripPrefix $ printOutputable origName insertText = case isInfix of Nothing -> case getArgText <$> thingType of Nothing -> label - Just argText -> label <> " " <> argText + Just argText -> if T.null argText then label else label <> " " <> argText Just LeftSide -> label <> "`" Just Surrounded -> label typeText - | Just t <- thingType = Just . stripForall $ showGhc t + | Just t <- thingType = Just . stripForall $ printOutputable t | otherwise = Nothing additionalTextEdits = imp <&> \x -> @@ -244,7 +244,7 @@ thingParent, importName = showModName $ unLoc $ ideclName $ unLoc x, importQual = getImportQual x, - newThing = showNameWithoutUniques origName + newThing = printOutputable origName } stripForall :: T.Text -> T.Text @@ -295,7 +295,7 @@ where ctxt = defaultSDocContext{sdocStyle = mkUserStyle neverQualify AllTheWay} #else -showForSnippet x = showGhc x +showForSnippet x = printOutputable x #endif mkModCompl :: T.Text -> CompletionItem @@ -350,7 +350,7 @@ let packageState = hscEnv env curModName = moduleName curMod - curModNameText = ppr curModName + curModNameText = printOutputable curModName importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ] @@ -384,9 +384,9 @@ -- we don't want to extend import if it's already in scope guard . null $ lookupGRE_Name inScopeEnv n -- or if it doesn't have a real location - loc <- realSpan $ is_dloc spec + loc <- realSpan $ is_dloc spec Map.lookup loc importMap - compItem <- toCompItem par curMod (ppr $ is_mod spec) n originalImportDecl + compItem <- toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl let unqual | is_qual spec = [] | otherwise = compItem @@ -498,12 +498,12 @@ findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result where - result = [mkRecordSnippetCompItem uri (Just $ showNameWithoutUniques $ unLoc tcdLName) - (showGhc . unLoc $ con_name) field_labels mn doc Nothing + result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName) + (printOutputable . unLoc $ con_name) field_labels mn doc Nothing | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn , Just con_details <- [getFlds con_args] , let field_names = concatMap extract con_details - , let field_labels = showGhc <$> field_names + , let field_labels = printOutputable <$> field_names , (not . List.null) field_labels ] doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing) @@ -528,9 +528,6 @@ extract _ = [] findRecordCompl _ _ _ _ = [] -ppr :: Outputable a => a -> T.Text -ppr = T.pack . prettyPrint - toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = removeSnippetsWhen (not $ enableSnippets && supported) @@ -590,7 +587,7 @@ $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual)) allModNamesAsNS - filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls "" "" (label . snd) + filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) where mcc = case maybe_parsed of @@ -668,7 +665,7 @@ return $ (fmap.fmap) snd $ sortBy (compare `on` lexicographicOrdering) $ - mergeListsBy (flip compare `on` score_) + mergeListsBy (flip compare `on` score) [ (fmap.fmap) (notQual,) filtModNameCompls , (fmap.fmap) (notQual,) filtKeywordCompls , (fmap.fmap.fmap) (toggleSnippets caps config) compls @@ -681,11 +678,11 @@ -- 3. In-scope completions rank next -- 4. label alphabetical ordering next -- 4. detail alphabetical ordering (proxy for module) - lexicographicOrdering Fuzzy.Scored{score_, original} = + 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) + (Down isQual, Down score, Down isLocal, _label, _detail) @@ -807,7 +804,7 @@ safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) safeTyThingForRecord (AnId _) = Nothing safeTyThingForRecord (AConLike dc) = - let ctxStr = showGhc . occName . conLikeName $ dc + let ctxStr = printOutputable . occName . conLikeName $ dc field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc in Just (ctxStr, field_names) diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -6,11 +6,11 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , Log(..) ) where import Control.Exception (SomeException) import Control.Monad -import Control.Monad.IO.Class import qualified Data.Aeson as J import Data.Bifunctor import Data.Dependent.Map (DMap) @@ -22,7 +22,7 @@ import qualified Data.Map as Map import Data.String import qualified Data.Text as T -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server @@ -33,6 +33,7 @@ import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS import qualified Language.LSP.Server as LSP +import Language.LSP.VFS import Language.LSP.Types import qualified Language.LSP.Types as J import Text.Regex.TDFA.Text () @@ -43,13 +44,22 @@ -- --------------------------------------------------------------------- -- +data Log + = LogNoEnabledPlugins + deriving Show + +instance Pretty Log where + pretty = \case + LogNoEnabledPlugins -> + "extensibleNotificationPlugins no enabled plugins" + -- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config -asGhcIdePlugin (IdePlugins ls) = +asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config +asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> mkPlugin extensiblePlugins HLS.pluginHandlers <> - mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <> + mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -171,8 +181,8 @@ pure $ Right $ combineResponses m config caps params xs -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config -extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers } +extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers @@ -181,17 +191,17 @@ hs handlers = mconcat $ do (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers' - pure $ notificationHandler m $ \ide params -> do + pure $ notificationHandler m $ \ide vfs params -> do config <- Ide.PluginUtils.getClientConfig let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' case nonEmpty fs of Nothing -> do - liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins" + logWith recorder Info LogNoEnabledPlugins pure () Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide params) fs + mapM_ (\(pid,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs -- --------------------------------------------------------------------- @@ -217,7 +227,7 @@ -- | Combine the 'PluginHandler' for all plugins newtype IdeNotificationHandler (m :: J.Method FromClient Notification) - = IdeNotificationHandler [(PluginId, IdeState -> MessageParams m -> LSP.LspM Config ())] + = IdeNotificationHandler [(PluginId, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] -- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -5,6 +5,7 @@ module Development.IDE.Plugin.HLS.GhcIde ( descriptors + , Log(..) ) where import Control.Monad.IO.Class import Development.IDE @@ -19,16 +20,28 @@ import Language.LSP.Types import Text.Regex.TDFA.Text () -descriptors :: [PluginDescriptor IdeState] -descriptors = +data Log + = LogNotifications Notifications.Log + | LogCompletions Completions.Log + | LogTypeLenses TypeLenses.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogNotifications log -> pretty log + LogCompletions log -> pretty log + LogTypeLenses log -> pretty log + +descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] +descriptors recorder = [ descriptor "ghcide-hover-and-symbols", CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", - Completions.descriptor "ghcide-completions", - TypeLenses.descriptor "ghcide-type-lenses", - Notifications.descriptor "ghcide-core" + Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", + TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", + Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" ] -- --------------------------------------------------------------------- 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 @@ -28,6 +28,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake +import Development.IDE.Core.Rules import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import qualified Development.IDE.Graph as Graph @@ -64,6 +65,7 @@ | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) | GetStoredKeys -- ^ :: [String] (list of keys in store) | GetFilesOfInterest -- ^ :: [FilePath] + | GetRebuildsCount -- ^ :: Int (number of times we recompiled with GHC) deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -131,6 +133,9 @@ testRequestHandler s GetFilesOfInterest = do ff <- liftIO $ getFilesOfInterest s return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff +testRequestHandler s GetRebuildsCount = do + count <- liftIO $ runAction "get build count" s getRebuildCount + return $ Right $ toJSON count getDatabaseKeys :: (Graph.Result -> Step) -> ShakeDatabase 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 @@ -10,7 +10,8 @@ GlobalBindingTypeSig (..), GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), -) where + Log(..) + ) where import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) @@ -33,6 +34,7 @@ import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes @@ -41,6 +43,9 @@ Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, + cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties @@ -68,15 +73,21 @@ WorkspaceEdit (WorkspaceEdit)) import Text.Regex.TDFA ((=~), (=~~)) +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] - , pluginRules = rules + , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } @@ -239,9 +250,9 @@ type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult -rules :: Rules () -rules = do - define $ \GetGlobalBindingTypeSigs nfp -> do +rules :: Recorder (WithPriority Log) -> Rules () +rules recorder = do + define (cmapWithPrio LogShake recorder) $ \GetGlobalBindingTypeSigs nfp -> do tmr <- use TypeCheck nfp -- we need session here for tidying types hsc <- use GhcSession nfp 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 @@ -17,7 +17,7 @@ , computeTypeReferences , FOIReferences(..) , defRowToSymbolInfo - , getAstNamesAtPoint + , getNamesAtPoint , toCurrentLocation , rowToLoc ) where @@ -34,6 +34,7 @@ import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.Spans.Common import Development.IDE.Types.Options +import Development.IDE.GHC.Util (printOutputable) import Control.Applicative import Control.Monad.Extra @@ -86,7 +87,7 @@ case HM.lookup file asts of Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> - let names = getAstNamesAtPoint hf pos mapping + let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -96,8 +97,8 @@ $ concat $ mapMaybe (`M.lookup` tr) names in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) -getAstNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] -getAstNamesAtPoint hf pos mapping = +getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] +getNamesAtPoint hf pos mapping = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) where posFile = fromMaybe pos $ fromCurrentPosition mapping pos @@ -229,13 +230,13 @@ prettyNames :: [T.Text] prettyNames = map prettyName names prettyName (Right n, dets) = T.unlines $ - wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : definedAt n ++ maybeToList (prettyPackageName n) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n ] - where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n - prettyName (Left m,_) = showGhc m + where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + prettyName (Left m,_) = printOutputable m prettyPackageName n = do m <- nameModule_maybe n @@ -247,15 +248,15 @@ prettyTypes = map (("_ :: "<>) . prettyType) types prettyType t = case kind of - HieFresh -> showGhc t - HieFromDisk full_file -> showGhc $ hieTypeToIface $ recoverFullType t (hie_types full_file) + HieFresh -> printOutputable t + HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) definedAt name = -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information case nameSrcLoc name of UnhelpfulLoc {} | isInternalName name || isSystemName name -> [] - _ -> ["*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"] + _ -> ["*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"] typeLocationsAtPoint :: forall m @@ -380,7 +381,7 @@ defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing Nothing loc Nothing + = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing where kind | isVarOcc defNameOcc = SkVariable 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 @@ -3,9 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} module Development.IDE.Spans.Common ( - showGhc -, showNameWithoutUniques -, unqualIEWrapName + unqualIEWrapName , safeTyThingId , safeTyThingType , SpanDoc(..) @@ -34,18 +32,9 @@ type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing -showGhc :: Outputable a => a -> T.Text -showGhc = showSD . ppr - -showSD :: SDoc -> T.Text -showSD = T.pack . unsafePrintSDoc - -showNameWithoutUniques :: Outputable a => a -> T.Text -showNameWithoutUniques = T.pack . printNameWithoutUniques - -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text -unqualIEWrapName = showNameWithoutUniques . rdrNameOcc . ieWrappedName +unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs safeTyThingType :: TyThing -> Maybe Type @@ -62,7 +51,9 @@ -- Possible documentation for an element in the code data SpanDoc = SpanDocString HsDocString SpanDocUris - | SpanDocText [T.Text] SpanDocUris + -- ^ Extern module doc + | SpanDocText [T.Text] SpanDocUris + -- ^ Local module doc deriving stock (Eq, Show, Generic) deriving anyclass NFData @@ -76,13 +67,33 @@ emptySpanDoc :: SpanDoc emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing) +-- | Convert `SpanDoc` to Markdown format. +-- +-- Return a list `Text` includes haddock, document uri and source code uri, +-- each item can be empty and must end with '\\n' if exist. This is to prevent +-- subsequent render problem caused by the missing newline. +-- +-- Example: +-- +-- For return value ["xxxx","yyyy"], if we concat the list with inserting +-- a separate line(note by "---\n"), +-- it will result "xxxx---\nyyyy" and can't be rendered as a normal doc. +-- Therefore we check every item in the value to make sure they all end with '\\n', +-- this makes "xxxx\n---\nyyy\n" and can be rendered correctly. spanDocToMarkdown :: SpanDoc -> [T.Text] -spanDocToMarkdown (SpanDocString docs uris) - = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs] - <> ["\n"] <> spanDocUrisToMarkdown uris - -- Append the extra newlines since this is markdown --- to get a visible newline, - -- you need to have two newlines -spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris +spanDocToMarkdown = \case + (SpanDocString docs uris) -> + let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs + in go [doc] uris + (SpanDocText txt uris) -> go txt uris + where + go [] uris = render <$> spanDocUrisToMarkdown uris + go txt uris = init txt <> [render (last txt)] <> (render <$> spanDocUrisToMarkdown uris) + -- If the doc is not end with an '\n', we append it. + render txt + | T.null txt = txt + | T.last txt == '\n' = txt + | otherwise = txt <> T.pack "\n" spanDocUrisToMarkdown :: SpanDocUris -> [T.Text] spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes 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 @@ -1,224 +1,225 @@ -{-# LANGUAGE RankNTypes #-} --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} - -module Development.IDE.Spans.Documentation ( - getDocumentation - , getDocumentationTryGhc - , getDocumentationsTryGhc - , DocMap - , mkDocMap - ) where - -import Control.Monad -import Control.Monad.Extra (findM) -import Control.Monad.IO.Class -import Data.Either -import Data.Foldable -import Data.List.Extra -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Set as S -import qualified Data.Text as T -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 Language.LSP.Types (filePathToUri, getUri) - -mkDocMap - :: HscEnv - -> RefMap a - -> TcGblEnv - -> IO DocAndKindMap -mkDocMap env rm this_mod = - do -#if MIN_VERSION_ghc(9,2,0) - (_ , DeclDocMap this_docs, _) <- extractDocs this_mod -#else - let (_ , DeclDocMap this_docs, _) = extractDocs this_mod -#endif - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names - k <- foldrM getType (tcg_type_env this_mod) names - pure $ DKMap d k - where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist - | otherwise = do - doc <- getDocumentationTryGhc env mod n - pure $ extendNameEnv map n doc - getType n map - | isTcOcc $ occName n = do - kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map - names = rights $ S.toList idents - idents = M.keysSet rm - mod = tcg_mod this_mod - -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) -lookupKind env mod = - fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod - -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] - -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] -getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names - case res of - Left _ -> return [] - Right res -> zipWithM unwrap res names - where - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n - unwrap _ n = mkSpanDocText n - - mkSpanDocText name = - SpanDocText [] <$> getUris name - - -- Get the uris to the documentation and source html pages if they exist - getUris name = do - (docFu, srcFu) <- - case nameModule_maybe name of - Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod - return (doc, src) - Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu - srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu - selector - | isValName name = "v:" - | otherwise = "t:" - return $ SpanDocUris docUri srcUri - - toFileUriText = (fmap . fmap) (getUri . filePathToUri) - -getDocumentation - :: HasSrcSpan name - => [ParsedModule] -- ^ All of the possible modules it could be defined in. - -> name -- ^ The name you want documentation for. - -> [T.Text] --- This finds any documentation between the name you want --- documentation for and the one before it. This is only an --- approximately correct algorithm and there are easily constructed --- cases where it will be wrong (if so then usually slightly but there --- may be edge cases where it is very wrong). --- TODO : Build a version of GHC exactprint to extract this information --- more accurately. --- TODO : Implement this for GHC 9.2 with in-tree annotations --- (alternatively, just remove it and rely soley on GHC's parsing) -getDocumentation sources targetName = fromMaybe [] $ do -#if MIN_VERSION_ghc(9,2,0) - Nothing -#else - -- Find the module the target is defined in. - targetNameSpan <- realSpan $ getLoc targetName - tc <- - find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse sources -- TODO : Is reversing the list here really neccessary? - - -- Top level names bound by the module - let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc - , L _ (ValD _ hsbind) <- hsmodDecls - , Just n <- [name_of_bind hsbind] - ] - -- Sort the names' source spans. - let sortedSpans = sortedNameSpans bs - -- Now go ahead and extract the docs. - let docs = ann tc - nameInd <- elemIndex targetNameSpan sortedSpans - let prevNameSpan = - if nameInd >= 1 - then sortedSpans !! (nameInd - 1) - else zeroSpan $ srcSpanFile targetNameSpan - -- Annoyingly "-- |" documentation isn't annotated with a location, - -- so you have to pull it out from the elements. - pure - $ docHeaders - $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ fold - docs - where - -- Get the name bound by a binding. We only concern ourselves with - -- @FunBind@ (which covers functions and variables). - name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) - name_of_bind FunBind {fun_id} = Just fun_id - name_of_bind _ = Nothing - -- Get source spans from names, discard unhelpful spans, remove - -- duplicates and sort. - sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) - isBetween target before after = before <= target && target <= after -#if MIN_VERSION_ghc(9,0,0) - ann = apiAnnComments . pm_annotations -#else - ann = fmap filterReal . snd . pm_annotations - filterReal :: [Located a] -> [RealLocated a] - filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) -#endif - annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann - --- | Shows this part of the documentation -docHeaders :: [RealLocated AnnotationComment] - -> [T.Text] -docHeaders = mapMaybe (\(L _ x) -> wrk x) - where - wrk = \case - -- When `Opt_Haddock` is enabled. - AnnDocCommentNext s -> Just $ T.pack s - -- When `Opt_KeepRawTokenStream` enabled. - AnnLineComment s -> if "-- |" `isPrefixOf` s - then Just $ T.pack s - else Nothing - _ -> Nothing -#endif - --- These are taken from haskell-ide-engine's Haddock plugin - --- | 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 :: 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 :: HscEnv -> Module -> IO (Maybe FilePath) -lookupSrcHtmlForModule = - lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") - -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath hscEnv m = do - -- try all directories - 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 = 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. - mns = do - chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m - -- The file might use "." or "-" as separator - map (`intercalate` chunks) [".", "-"] - -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 . unitHaddockInterfaces <$> lookupUnit df ui +{-# LANGUAGE RankNTypes #-} +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE CPP #-} + +module Development.IDE.Spans.Documentation ( + getDocumentation + , getDocumentationTryGhc + , getDocumentationsTryGhc + , DocMap + , mkDocMap + ) where + +import Control.Monad +import Control.Monad.Extra (findM) +import Control.Monad.IO.Class +import Data.Either +import Data.Foldable +import Data.List.Extra +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Text as T +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.GHC.Util (printOutputable) +import Development.IDE.Spans.Common +import System.Directory +import System.FilePath + +import Language.LSP.Types (filePathToUri, getUri) + +mkDocMap + :: HscEnv + -> RefMap a + -> TcGblEnv + -> IO DocAndKindMap +mkDocMap env rm this_mod = + do +#if MIN_VERSION_ghc(9,2,0) + (_ , DeclDocMap this_docs, _) <- extractDocs this_mod +#else + let (_ , DeclDocMap this_docs, _) = extractDocs this_mod +#endif + d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names + k <- foldrM getType (tcg_type_env this_mod) names + pure $ DKMap d k + where + getDocs n map + | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + | otherwise = do + doc <- getDocumentationTryGhc env mod n + pure $ extendNameEnv map n doc + getType n map + | isTcOcc $ occName n = do + kind <- lookupKind env mod n + pure $ maybe map (extendNameEnv map n) kind + | otherwise = pure map + names = rights $ S.toList idents + idents = M.keysSet rm + mod = tcg_mod this_mod + +lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) +lookupKind env mod = + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod + +getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc +getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] + +getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env mod names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names + case res of + Left _ -> return [] + Right res -> zipWithM unwrap res names + where + unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n + unwrap _ n = mkSpanDocText n + + mkSpanDocText name = + SpanDocText [] <$> getUris name + + -- Get the uris to the documentation and source html pages if they exist + getUris name = do + (docFu, srcFu) <- + case nameModule_maybe name of + Just mod -> liftIO $ do + doc <- toFileUriText $ lookupDocHtmlForModule env mod + src <- toFileUriText $ lookupSrcHtmlForModule env mod + return (doc, src) + Nothing -> pure (Nothing, Nothing) + let docUri = (<> "#" <> selector <> printOutputable name) <$> docFu + srcUri = (<> "#" <> printOutputable name) <$> srcFu + selector + | isValName name = "v:" + | otherwise = "t:" + return $ SpanDocUris docUri srcUri + + toFileUriText = (fmap . fmap) (getUri . filePathToUri) + +getDocumentation + :: HasSrcSpan name + => [ParsedModule] -- ^ All of the possible modules it could be defined in. + -> name -- ^ The name you want documentation for. + -> [T.Text] +-- This finds any documentation between the name you want +-- documentation for and the one before it. This is only an +-- approximately correct algorithm and there are easily constructed +-- cases where it will be wrong (if so then usually slightly but there +-- may be edge cases where it is very wrong). +-- TODO : Build a version of GHC exactprint to extract this information +-- more accurately. +-- TODO : Implement this for GHC 9.2 with in-tree annotations +-- (alternatively, just remove it and rely soley on GHC's parsing) +getDocumentation sources targetName = fromMaybe [] $ do +#if MIN_VERSION_ghc(9,2,0) + Nothing +#else + -- Find the module the target is defined in. + targetNameSpan <- realSpan $ getLoc targetName + tc <- + find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) + $ reverse sources -- TODO : Is reversing the list here really neccessary? + + -- Top level names bound by the module + let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc + , L _ (ValD _ hsbind) <- hsmodDecls + , Just n <- [name_of_bind hsbind] + ] + -- Sort the names' source spans. + let sortedSpans = sortedNameSpans bs + -- Now go ahead and extract the docs. + let docs = ann tc + nameInd <- elemIndex targetNameSpan sortedSpans + let prevNameSpan = + if nameInd >= 1 + then sortedSpans !! (nameInd - 1) + else zeroSpan $ srcSpanFile targetNameSpan + -- Annoyingly "-- |" documentation isn't annotated with a location, + -- so you have to pull it out from the elements. + pure + $ docHeaders + $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) + $ fold + docs + where + -- Get the name bound by a binding. We only concern ourselves with + -- @FunBind@ (which covers functions and variables). + name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) + name_of_bind FunBind {fun_id} = Just fun_id + name_of_bind _ = Nothing + -- Get source spans from names, discard unhelpful spans, remove + -- duplicates and sort. + sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] + sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) + isBetween target before after = before <= target && target <= after +#if MIN_VERSION_ghc(9,0,0) + ann = apiAnnComments . pm_annotations +#else + ann = fmap filterReal . snd . pm_annotations + filterReal :: [Located a] -> [RealLocated a] + filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) +#endif + annotationFileName :: ParsedModule -> Maybe FastString + annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann + +-- | Shows this part of the documentation +docHeaders :: [RealLocated AnnotationComment] + -> [T.Text] +docHeaders = mapMaybe (\(L _ x) -> wrk x) + where + wrk = \case + -- When `Opt_Haddock` is enabled. + AnnDocCommentNext s -> Just $ T.pack s + -- When `Opt_KeepRawTokenStream` enabled. + AnnLineComment s -> if "-- |" `isPrefixOf` s + then Just $ T.pack s + else Nothing + _ -> Nothing +#endif + +-- These are taken from haskell-ide-engine's Haddock plugin + +-- | 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 :: 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 :: HscEnv -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule = + lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") + +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath hscEnv m = do + -- try all directories + 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 = 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. + mns = do + chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m + -- The file might use "." or "-" as separator + map (`intercalate` chunks) [".", "-"] + +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 . 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 @@ -1,140 +1,140 @@ -{-# LANGUAGE DerivingStrategies #-} - -module Development.IDE.Spans.LocalBindings - ( Bindings - , getLocalScope - , getFuzzyScope - , getDefiningBindings - , getFuzzyDefiningBindings - , bindings - ) where - -import Control.DeepSeq -import Control.Monad -import Data.Bifunctor -import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) -import qualified Data.IntervalMap.FingerTree as IM -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, - RefMap, Scope (..), Type, - getBindSiteFromContext, - getScopeFromContext, identInfo, - identType, isSystemName, - nameEnvElts, realSrcSpanEnd, - realSrcSpanStart, unitNameEnv) - -import Development.IDE.GHC.Error -import Development.IDE.Types.Location - ------------------------------------------------------------------------------- --- | Turn a 'RealSrcSpan' into an 'Interval'. -realSrcSpanToInterval :: RealSrcSpan -> Interval Position -realSrcSpanToInterval rss = - Interval - (realSrcLocToPosition $ realSrcSpanStart rss) - (realSrcLocToPosition $ realSrcSpanEnd rss) - -bindings :: RefMap Type -> Bindings -bindings = uncurry Bindings . localBindings - ------------------------------------------------------------------------------- --- | Compute which identifiers are in scope at every point in the AST. Use --- 'getLocalScope' to find the results. -localBindings - :: RefMap Type - -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) - , IntervalMap Position (NameEnv (Name, Maybe Type)) - ) -localBindings refmap = bimap mk mk $ unzip $ do - (ident, refs) <- M.toList refmap - Right name <- pure ident - (_, ident_details) <- refs - let ty = identType ident_details - info <- S.toList $ identInfo ident_details - pure - ( do - Just scopes <- pure $ getScopeFromContext info - scope <- scopes >>= \case - LocalScope scope -> pure $ realSrcSpanToInterval scope - _ -> [] - pure ( scope - , unitNameEnv name (name,ty) - ) - , do - Just scope <- pure $ getBindSiteFromContext info - pure ( realSrcSpanToInterval scope - , unitNameEnv name (name,ty) - ) - ) - where - mk = L.foldl' (flip (uncurry IM.insert)) mempty . join - ------------------------------------------------------------------------------- --- | The available bindings at every point in a Haskell tree. -data Bindings = Bindings - { getLocalBindings - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - , getBindingSites - :: IntervalMap Position (NameEnv (Name, Maybe Type)) - } - -instance Semigroup Bindings where - Bindings a1 b1 <> Bindings a2 b2 - = Bindings (a1 <> a2) (b1 <> b2) - -instance Monoid Bindings where - mempty = Bindings mempty mempty - -instance NFData Bindings where - rnf = rwhnf - -instance Show Bindings where - show _ = "" - - ------------------------------------------------------------------------------- --- | Given a 'Bindings' get every identifier in scope at the given --- 'RealSrcSpan', -getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getLocalScope bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding currently active at a given --- 'RealSrcSpan', -getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] -getDefiningBindings bs rss - = nameEnvElts - $ foldMap snd - $ IM.dominators (realSrcSpanToInterval rss) - $ getBindingSites bs - - --- | Lookup all names in scope in any span that intersects the interval --- defined by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` -getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyScope bs a b - = filter (not . isSystemName . fst) - $ nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getLocalBindings bs - ------------------------------------------------------------------------------- --- | Given a 'Bindings', get every binding that intersects the interval defined --- by the two positions. --- This is meant for use with the fuzzy `PositionRange` returned by --- `PositionMapping` -getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] -getFuzzyDefiningBindings bs a b - = nameEnvElts - $ foldMap snd - $ IM.intersections (Interval a b) - $ getBindingSites bs - +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Spans.LocalBindings + ( Bindings + , getLocalScope + , getFuzzyScope + , getDefiningBindings + , getFuzzyDefiningBindings + , bindings + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Bifunctor +import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) +import qualified Data.IntervalMap.FingerTree as IM +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, + RefMap, Scope (..), Type, + getBindSiteFromContext, + getScopeFromContext, identInfo, + identType, isSystemName, + nameEnvElts, realSrcSpanEnd, + realSrcSpanStart, unitNameEnv) + +import Development.IDE.GHC.Error +import Development.IDE.Types.Location + +------------------------------------------------------------------------------ +-- | Turn a 'RealSrcSpan' into an 'Interval'. +realSrcSpanToInterval :: RealSrcSpan -> Interval Position +realSrcSpanToInterval rss = + Interval + (realSrcLocToPosition $ realSrcSpanStart rss) + (realSrcLocToPosition $ realSrcSpanEnd rss) + +bindings :: RefMap Type -> Bindings +bindings = uncurry Bindings . localBindings + +------------------------------------------------------------------------------ +-- | Compute which identifiers are in scope at every point in the AST. Use +-- 'getLocalScope' to find the results. +localBindings + :: RefMap Type + -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) + , IntervalMap Position (NameEnv (Name, Maybe Type)) + ) +localBindings refmap = bimap mk mk $ unzip $ do + (ident, refs) <- M.toList refmap + Right name <- pure ident + (_, ident_details) <- refs + let ty = identType ident_details + info <- S.toList $ identInfo ident_details + pure + ( do + Just scopes <- pure $ getScopeFromContext info + scope <- scopes >>= \case + LocalScope scope -> pure $ realSrcSpanToInterval scope + _ -> [] + pure ( scope + , unitNameEnv name (name,ty) + ) + , do + Just scope <- pure $ getBindSiteFromContext info + pure ( realSrcSpanToInterval scope + , unitNameEnv name (name,ty) + ) + ) + where + mk = L.foldl' (flip (uncurry IM.insert)) mempty . join + +------------------------------------------------------------------------------ +-- | The available bindings at every point in a Haskell tree. +data Bindings = Bindings + { getLocalBindings + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + , getBindingSites + :: IntervalMap Position (NameEnv (Name, Maybe Type)) + } + +instance Semigroup Bindings where + Bindings a1 b1 <> Bindings a2 b2 + = Bindings (a1 <> a2) (b1 <> b2) + +instance Monoid Bindings where + mempty = Bindings mempty mempty + +instance NFData Bindings where + rnf = rwhnf + +instance Show Bindings where + show _ = "" + + +------------------------------------------------------------------------------ +-- | Given a 'Bindings' get every identifier in scope at the given +-- 'RealSrcSpan', +getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getLocalScope bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding currently active at a given +-- 'RealSrcSpan', +getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] +getDefiningBindings bs rss + = nameEnvElts + $ foldMap snd + $ IM.dominators (realSrcSpanToInterval rss) + $ getBindingSites bs + + +-- | Lookup all names in scope in any span that intersects the interval +-- defined by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` +getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyScope bs a b + = filter (not . isSystemName . fst) + $ nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getLocalBindings bs + +------------------------------------------------------------------------------ +-- | Given a 'Bindings', get every binding that intersects the interval defined +-- by the two positions. +-- This is meant for use with the fuzzy `PositionRange` returned by +-- `PositionMapping` +getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] +getFuzzyDefiningBindings bs a b + = nameEnvElts + $ foldMap snd + $ IM.intersections (Interval a b) + $ getBindingSites bs + diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs --- a/src/Development/IDE/Spans/Pragmas.hs +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -5,17 +5,19 @@ module Development.IDE.Spans.Pragmas ( NextPragmaInfo(..) , LineSplitTextEdits(..) - , getNextPragmaInfo ) where + , getNextPragmaInfo + , insertNewPragma ) where import Data.Bits (Bits (setBit)) import Data.Function ((&)) import qualified Data.List as List import qualified Data.Maybe as Maybe -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Data.Text as Text import Development.IDE (srcSpanToRange) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util +import GHC.LanguageExtensions.Type (Extension) import qualified Language.LSP.Types as LSP getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo @@ -28,6 +30,13 @@ ParserStateDone{ nextPragma } -> nextPragma | otherwise -> NextPragmaInfo 0 Nothing + +insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit +insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" } :: LSP.TextEdit +insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" + where + pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 + pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -- Pre-declaration comments parser ----------------------------------------------------- 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 @@ -22,19 +22,18 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Data.Hashable (Hashable) -import Data.List (isSuffixOf) +import Data.List (isSuffixOf, foldl') import Data.Text (Text, pack) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import Development.IDE.Types.Shake (WithHieDb) import GHC.Generics (Generic) import HieDb data ExportsMap = ExportsMap - { getExportsMap :: HashMap IdentifierText (HashSet IdentInfo) - , getModuleExportsMap :: HashMap ModuleNameText (HashSet IdentInfo) + { getExportsMap :: !(HashMap IdentifierText (HashSet IdentInfo)) + , getModuleExportsMap :: !(HashMap ModuleNameText (HashSet IdentInfo)) } deriving (Show) @@ -135,13 +134,11 @@ concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi) updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap -updateExportsMapMg modGuts old = - old' <> new +updateExportsMapMg modGuts old = old' <> new where new = createExportsMapMg modGuts old' = deleteAll old (Map.keys $ getModuleExportsMap new) - deleteAll = foldr deleteEntriesForModule - + deleteAll = foldl' (flip deleteEntriesForModule) createExportsMapTc :: [TcGblEnv] -> ExportsMap createExportsMapTc modIface = do @@ -156,6 +153,8 @@ nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString +type WithHieDb = forall a. (HieDb -> IO a) -> IO a + createExportsMapHieDb :: WithHieDb -> IO ExportsMap createExportsMapHieDb withHieDb = do mods <- withHieDb getAllIndexedMods @@ -179,7 +178,7 @@ | otherwise = const [] where !mod = pack $ moduleNameString mn - f id@IdentInfo {..} = (pack (prettyPrint name), moduleNameText,[id]) + f id@IdentInfo {..} = (printOutputable name, moduleNameText,[id]) identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo) 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 @@ -1,153 +1,153 @@ -module Development.IDE.Types.HscEnvEq -( HscEnvEq, - hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths, - envImportPaths, - envPackageExports, - envVisibleModuleNames, - deps -) 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 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 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 OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) -import System.FilePath - --- | 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 :: [(UnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe (Set FilePath) - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered - , envPackageExports :: IO ExportsMap - , envVisibleModuleNames :: IO (Maybe [ModuleName]) - -- ^ 'listVisibleModuleNames' is a pure function, - -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 - -- So it's wrapped in IO here for error handling - -- If Nothing, 'listVisibleModuleNames' panic - } - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 - - -- Make Absolute since targets are also absolute - importPathsCanon <- - mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) - - newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps - -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do - - let dflags = hsc_dflags hscEnv - - 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 = unitState hscEnv - depends = explicitUnits pkgst - modules = - [ m - | d <- depends - , Just pkg <- [lookupPackageConfig d hscEnv] - , (modName, maybeOtherPkgMod) <- unitExposedModules pkg - , let m = case maybeOtherPkgMod of - -- When module is re-exported from another package, - -- the origin module is represented by value in Just - Just otherPkgMod -> otherPkgMod - Nothing -> mkModule (unitInfoId pkg) modName - ] - - doOne m = do - modIface <- initIfaceLoad hscEnv $ - loadInterface "" m (ImportByUser NotBoot) - return $ case modIface of - Maybes.Failed _r -> Nothing - Maybes.Succeeded mi -> Just mi - modIfaces <- mapMaybeM doOne modules - return $ createExportsMap modIfaces - - -- similar to envPackageExports, evaluated lazily - envVisibleModuleNames <- onceAsync $ - fromRight Nothing - <$> catchSrcErrors - dflags - "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames hscEnv) - - return HscEnvEq{..} - --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc - -instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) - -instance Eq HscEnvEq where - a == b = envUnique a == envUnique b - -instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ _) = - -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d - -instance Hashable HscEnvEq where - hashWithSalt s = hashWithSalt s . envUnique - --- | 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 --- If the function raises an exception, the same exception will be reraised each time. -onceAsync :: IO a -> IO (IO a) -onceAsync act = do - var <- newVar OncePending - let run as = eitherM throwIO pure (waitCatch as) - pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of - OnceRunning x -> pure (v, unmask $ run x) - OncePending -> do - x <- async (unmask act) - pure (OnceRunning x, unmask $ run x) - -data Once a = OncePending | OnceRunning (Async a) +module Development.IDE.Types.HscEnvEq +( HscEnvEq, + hscEnv, newHscEnvEq, + hscEnvWithImportPaths, + newHscEnvEqPreserveImportPaths, + newHscEnvEqWithImportPaths, + envImportPaths, + envPackageExports, + envVisibleModuleNames, + deps +) 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 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 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 OpenTelemetry.Eventlog (withSpan) +import System.Directory (makeAbsolute) +import System.FilePath + +-- | 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 :: [(UnitId, DynFlags)] + -- ^ In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + , envImportPaths :: Maybe (Set FilePath) + -- ^ If Just, import dirs originally configured in this env + -- If Nothing, the env import dirs are unaltered + , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic + } + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq cradlePath hscEnv0 deps = do + let relativeToCradle = (takeDirectory cradlePath ) + hscEnv = removeImportPaths hscEnv0 + + -- Make Absolute since targets are also absolute + importPathsCanon <- + mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + + newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps + +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + + let dflags = hsc_dflags hscEnv + + 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 = unitState hscEnv + depends = explicitUnits pkgst + modules = + [ m + | d <- depends + , Just pkg <- [lookupPackageConfig d hscEnv] + , (modName, maybeOtherPkgMod) <- unitExposedModules pkg + , let m = case maybeOtherPkgMod of + -- When module is re-exported from another package, + -- the origin module is represented by value in Just + Just otherPkgMod -> otherPkgMod + Nothing -> mkModule (unitInfoId pkg) modName + ] + + doOne m = do + modIface <- initIfaceLoad hscEnv $ + loadInterface "" m (ImportByUser NotBoot) + return $ case modIface of + Maybes.Failed _r -> Nothing + Maybes.Succeeded mi -> Just mi + modIfaces <- mapMaybeM doOne modules + return $ createExportsMap modIfaces + + -- similar to envPackageExports, evaluated lazily + envVisibleModuleNames <- onceAsync $ + fromRight Nothing + <$> catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force . Just $ listVisibleModuleNames hscEnv) + + return HscEnvEq{..} + +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEqPreserveImportPaths + :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing + +-- | Unwrap the 'HscEnv' with the original import paths. +-- Used only for locating imports +hscEnvWithImportPaths :: HscEnvEq -> HscEnv +hscEnvWithImportPaths HscEnvEq{..} + | Just imps <- envImportPaths + = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv + | otherwise + = hscEnv + +removeImportPaths :: HscEnv -> HscEnv +removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc + +instance Show HscEnvEq where + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) + +instance Eq HscEnvEq where + a == b = envUnique a == envUnique b + +instance NFData HscEnvEq where + rnf (HscEnvEq a b c d _ _) = + -- deliberately skip the package exports map and visible module names + rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d + +instance Hashable HscEnvEq where + hashWithSalt s = hashWithSalt s . envUnique + +-- | 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 +-- If the function raises an exception, the same exception will be reraised each time. +onceAsync :: IO a -> IO (IO a) +onceAsync act = do + var <- newVar OncePending + let run as = eitherM throwIO pure (waitCatch as) + pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of + OnceRunning x -> pure (v, unmask $ run x) + OncePending -> do + x <- async (unmask act) + pure (OnceRunning x, unmask $ run x) + +data Once a = OncePending | OnceRunning (Async a) 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 @@ -8,18 +8,68 @@ module Development.IDE.Types.Logger ( Priority(..) , Logger(..) - , logError, logWarning, logInfo, logDebug, logTelemetry + , Recorder(..) + , logError, logWarning, logInfo, logDebug , noLogging + , WithPriority(..) + , logWith + , cmap + , cmapIO + , cfilter + , withDefaultRecorder + , makeDefaultStderrRecorder + , priorityToHsLoggerPriority + , LoggingColumn(..) + , cmapWithPrio + , withBacklog + , lspClientMessageRecorder + , lspClientLogRecorder + , module PrettyPrinterModule + , renderStrict ) where -import qualified Data.Text as T - +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Concurrent.STM (atomically, + newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue) +import Control.Exception (IOException) +import Control.Monad (forM_, when, (>=>), unless) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Foldable (for_) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, formatTime, + getCurrentTime) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) +import Language.LSP.Server +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (LogMessageParams (..), + MessageType (..), + SMethod (SWindowLogMessage, SWindowShowMessage), + ShowMessageParams (..)) +import Prettyprinter as PrettyPrinterModule +import Prettyprinter.Render.Text (renderStrict) +import System.IO (Handle, IOMode (AppendMode), + hClose, hFlush, hSetEncoding, + openFile, stderr, utf8) +import qualified System.Log.Formatter as HSL +import qualified System.Log.Handler as HSL +import qualified System.Log.Handler.Simple as HSL +import qualified System.Log.Logger as HsLogger +import UnliftIO (MonadUnliftIO, displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord -- instance - = Telemetry -- ^ Events that are useful for gathering user metrics. - | Debug -- ^ Verbose debug logging. + = Debug -- ^ Verbose debug logging. | Info -- ^ Useful information in case an error has to be understood. | Warning -- ^ These error messages should not occur in a expected usage, and @@ -27,7 +77,6 @@ | Error -- ^ Such log messages must never occur in expected usage. deriving (Eq, Show, Ord, Enum, Bounded) - -- | Note that this is logging actions _of the program_, not of the user. -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). @@ -51,9 +100,263 @@ logDebug :: Logger -> T.Text -> IO () logDebug x = logPriority x Debug -logTelemetry :: Logger -> T.Text -> IO () -logTelemetry x = logPriority x Telemetry - - noLogging :: Logger noLogging = Logger $ \_ _ -> return () + +data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor + +-- | Note that this is logging actions _of the program_, not of the user. +-- You shouldn't call warning/error if the user has caused an error, only +-- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). +newtype Recorder msg = Recorder + { logger_ :: forall m. (MonadIO m) => msg -> m () } + +logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () +logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) + +instance Semigroup (Recorder msg) where + (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = + Recorder + { logger_ = \msg -> logger_1 msg >> logger_2 msg } + +instance Monoid (Recorder msg) where + mempty = + Recorder + { logger_ = \_ -> pure () } + +instance Contravariant Recorder where + contramap f Recorder{ logger_ } = + Recorder + { logger_ = logger_ . f } + +cmap :: (a -> b) -> Recorder b -> Recorder a +cmap = contramap + +cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a) +cmapWithPrio f = cmap (fmap f) + +cmapIO :: (a -> IO b) -> Recorder b -> Recorder a +cmapIO f Recorder{ logger_ } = + Recorder + { logger_ = (liftIO . f) >=> logger_ } + +cfilter :: (a -> Bool) -> Recorder a -> Recorder a +cfilter p Recorder{ logger_ } = + Recorder + { logger_ = \msg -> when (p msg) (logger_ msg) } + +textHandleRecorder :: Handle -> Recorder Text +textHandleRecorder handle = + Recorder + { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } + +-- | Priority is actually for hslogger compatibility +makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a))) +makeDefaultStderrRecorder columns minPriority = do + lock <- liftIO newLock + makeDefaultHandleRecorder columns minPriority lock stderr + +-- | If no path given then use stderr, otherwise use file. +-- Kinda complicated because we also need to setup `hslogger` for +-- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our +-- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can +-- be removed completely. See `setupHsLogger` comment. +withDefaultRecorder + :: MonadUnliftIO m + => Maybe FilePath + -- ^ Log file path. `Nothing` uses stderr + -> Maybe [LoggingColumn] + -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` + -> Priority + -- ^ min priority for hslogger compatibility + -> (Recorder (WithPriority (Doc d)) -> m a) + -- ^ action given a recorder + -> m a +withDefaultRecorder path columns minPriority action = do + lock <- liftIO newLock + let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock + case path of + Nothing -> do + recorder <- makeHandleRecorder stderr + let message = "No log file specified; using stderr." + logWith recorder Info message + action recorder + Just path -> do + fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) + case fileHandle of + Left e -> do + recorder <- makeHandleRecorder stderr + let exceptionMessage = pretty $ displayException e + let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] + logWith recorder Warning message + action recorder + Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) + +makeDefaultHandleRecorder + :: MonadIO m + => Maybe [LoggingColumn] + -- ^ built-in logging columns to display. Nothing uses the default + -> Priority + -- ^ min priority for hslogger compatibility + -> Lock + -- ^ lock to take when outputting to handle + -> Handle + -- ^ handle to output to + -> m (Recorder (WithPriority (Doc a))) +makeDefaultHandleRecorder columns minPriority lock handle = do + let Recorder{ logger_ } = textHandleRecorder handle + let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } + let loggingColumns = fromMaybe defaultLoggingColumns columns + let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder + -- see `setupHsLogger` comment + liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority) + pure (cmap docToText textWithPriorityRecorder) + where + docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) + +priorityToHsLoggerPriority :: Priority -> HsLogger.Priority +priorityToHsLoggerPriority = \case + Debug -> HsLogger.DEBUG + Info -> HsLogger.INFO + Warning -> HsLogger.WARNING + Error -> HsLogger.ERROR + +-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses +-- `hslogger` to output compilation logs. The easiest way to merge these logs +-- with our log output is to setup an `hslogger` that uses the same handle +-- and same lock as our loggers. That way the output from our loggers and +-- `hie-bios` don't interleave strangely. +-- It may be possible to have `hie-bios` use our logger by decorating the +-- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from +-- `HieBios.findCradle`, but I remember trying that and something not good +-- happened. I'd have to try it again to remember if that was a real issue. +-- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all +-- references to `hslogger` can be removed entirely. +setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO () +setupHsLogger lock handle extraLogNames level = do + hSetEncoding handle utf8 + + logH <- HSL.streamHandler handle level + + let logHandle = logH + { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s } + logFormatter = HSL.tfLogFormatter logDateFormat logFormat + logHandler = HSL.setFormatter logHandle logFormatter + + HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle]) + HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler] + HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level + + -- Also route the additional log names to the same log + forM_ extraLogNames $ \logName -> do + HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler] + HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level + where + logFormat = "$time [$tid] $prio $loggername:\t$msg" + logDateFormat = "%Y-%m-%d %H:%M:%S%Q" + +data LoggingColumn + = TimeColumn + | ThreadIdColumn + | PriorityColumn + | DataColumn + | SourceLocColumn + +defaultLoggingColumns :: [LoggingColumn] +defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] + +textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text +textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do + textColumns <- mapM loggingColumnToText columns + pure $ Text.intercalate " | " textColumns + where + showAsText :: Show a => a -> Text + showAsText = Text.pack . show + + utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime + + priorityToText :: Priority -> Text + priorityToText = showAsText + + threadIdToText = showAsText + + callStackToSrcLoc :: CallStack -> Maybe SrcLoc + callStackToSrcLoc callStack = + case getCallStack callStack of + (_, srcLoc) : _ -> Just srcLoc + _ -> Nothing + + srcLocToText = \case + Nothing -> "" + Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } -> + Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol + + loggingColumnToText :: LoggingColumn -> IO Text + loggingColumnToText = \case + TimeColumn -> do + utcTime <- getCurrentTime + pure (utcTimeToText utcTime) + SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_ + ThreadIdColumn -> do + threadId <- myThreadId + pure (threadIdToText threadId) + PriorityColumn -> pure (priorityToText priority) + DataColumn -> pure payload + +-- | Given a 'Recorder' that requires an argument, produces a 'Recorder' +-- that queues up messages until the argument is provided using the callback, at which +-- point it sends the backlog and begins functioning normally. +withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ()) +withBacklog recFun = do + -- Arbitrary backlog capacity + backlog <- newTBQueueIO 100 + let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do + -- If the queue is full just drop the message on the floor. This is most likely + -- to happen if the callback is just never going to be called; in which case + -- we want neither to build up an unbounded backlog in memory, nor block waiting + -- for space! + full <- isFullTBQueue backlog + unless full $ writeTBQueue backlog it + + -- The variable holding the recorder starts out holding the recorder that writes + -- to the backlog. + recVar <- newTVarIO backlogRecorder + -- The callback atomically swaps out the recorder for the final one, and flushes + -- the backlog to it. + let cb arg = do + let recorder = recFun arg + toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog + for_ toRecord (logger_ recorder) + + -- The recorder we actually return looks in the variable and uses whatever is there. + let varRecorder = Recorder $ \it -> do + r <- liftIO $ readTVarIO recVar + logger_ r it + + pure (varRecorder, cb) + +-- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications. +lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) +lspClientMessageRecorder env = Recorder $ \WithPriority {..} -> + liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage + ShowMessageParams + { _xtype = priorityToLsp priority, + _message = payload + } + +-- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications. +lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) +lspClientLogRecorder env = Recorder $ \WithPriority {..} -> + liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage + LogMessageParams + { _xtype = priorityToLsp priority, + _message = payload + } + +priorityToLsp :: Priority -> MessageType +priorityToLsp = + \case + Debug -> MtLog + Info -> MtInfo + Warning -> MtWarning + Error -> MtError 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 @@ -17,7 +17,7 @@ , IdeGhcSession(..) , OptHaddockParse(..) , ProgressReportingStyle(..) - ,optShakeFiles) where + ) where import qualified Data.Text as T import Data.Typeable @@ -85,13 +85,6 @@ -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed } -optShakeFiles :: IdeOptions -> Maybe FilePath -optShakeFiles opts - | value == defValue = Nothing - | otherwise = Just value - where - value = shakeFiles (optShakeOptions opts) - defValue = shakeFiles (optShakeOptions $ defaultIdeOptions undefined) data OptHaddockParse = HaddockParse | NoHaddockParse deriving (Eq,Ord,Show,Enum) @@ -127,9 +120,6 @@ ,optExtensions = ["hs", "lhs"] ,optPkgLocationOpts = defaultIdePkgLocationOptions ,optShakeOptions = shakeOptions - {shakeThreads = 0 - ,shakeFiles = "/dev/null" - } ,optShakeProfiling = Nothing ,optOTMemoryProfiling = IdeOTMemoryProfiling False ,optReportProgress = IdeReportProgress False 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 @@ -31,21 +31,21 @@ import Development.IDE.Types.Location import GHC.Generics import HieDb.Types (HieDb) -import Language.LSP.Types import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), pattern App, pattern Con, typeOf, typeRep, typeRepTyCon) import Unsafe.Coerce (unsafeCoerce) +import Development.IDE.Core.RuleTypes (FileVersion) -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a data Value v - = Succeeded TextDocumentVersion v - | Stale (Maybe PositionDelta) TextDocumentVersion v + = Succeeded (Maybe FileVersion) v + | Stale (Maybe PositionDelta) (Maybe FileVersion) v | Failed Bool -- True if we already tried the persistent rule deriving (Functor, Generic, Show) diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -1,124 +1,124 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE RankNTypes #-} - --- | Custom SYB traversals explicitly designed for operating over the GHC AST. -module Generics.SYB.GHC - ( genericIsSubspan, - mkBindListT, - everywhereM', - smallestM, - largestM - ) where - -import Control.Monad -import Data.Functor.Compose (Compose (Compose)) -import Data.Monoid (Any (Any)) -import Development.IDE.GHC.Compat -import Development.IDE.Graph.Classes -import Generics.SYB - - --- | A generic query intended to be used for calling 'smallestM' and --- 'largestM'. If the current node is a 'Located', returns whether or not the --- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which --- indicates uncertainty. The search strategy in 'smallestM' et al. will --- continue searching uncertain nodes. -genericIsSubspan :: - forall ast. - Typeable ast => - -- | The type of nodes we'd like to consider. - Proxy (Located ast) -> - SrcSpan -> - GenericQ (Maybe (Bool, ast)) -genericIsSubspan _ dst = mkQ Nothing $ \case - (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) - - --- | Lift a function that replaces a value with several values into a generic --- function. The result doesn't perform any searching, so should be driven via --- 'everywhereM' or friends. --- --- The 'Int' argument is the index in the list being bound. -mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m -mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] - - --- | Apply a monadic transformation everywhere in a top-down manner. -everywhereM' :: forall m. Monad m => GenericM m -> GenericM m -everywhereM' f = go - where - go :: GenericM m - go = gmapM go <=< f - - ------------------------------------------------------------------------------- --- Custom SYB machinery ------------------------------------------------------------------------------- - --- | Generic monadic transformations that return side-channel data. -type GenericMQ r m = forall a. Data a => a -> m (r, a) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at all every node whose children fail the --- 'GenericQ', but which passes the query itself. --- --- The query must be a monotonic function when it returns 'Just'. That is, if --- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It --- is the True-to-false edge of the query that triggers the transformation. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m -smallestM q f = fmap snd . go - where - go :: GenericMQ Any m - go x = do - case q x of - Nothing -> gmapMQ go x - Just (True, a) -> do - it@(r, x') <- gmapMQ go x - case r of - Any True -> pure it - Any False -> fmap (Any True,) $ f a x' - Just (False, _) -> pure (mempty, x) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but --- don't descend into children if the query matches. Because this traversal is --- root-first, this policy will find the largest subtrees for which the query --- holds true. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m -largestM q f = go - where - go :: GenericM m - go x = do - case q x of - Just (True, a) -> f a x - Just (False, _) -> pure x - Nothing -> gmapM go x - -newtype MonadicQuery r m a = MonadicQuery - { runMonadicQuery :: m (r, a) - } - deriving stock (Functor) - deriving Applicative via Compose m ((,) r) - - ------------------------------------------------------------------------------- --- | Like 'gmapM', but also returns side-channel data. -gmapMQ :: - forall f r a. (Monoid r, Data a, Applicative f) => - (forall d. Data d => d -> f (r, d)) -> - a -> - f (r, a) -gmapMQ f = runMonadicQuery . gfoldl k pure - where - k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b - k c x = c <*> MonadicQuery (f x) +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} + +-- | Custom SYB traversals explicitly designed for operating over the GHC AST. +module Generics.SYB.GHC + ( genericIsSubspan, + mkBindListT, + everywhereM', + smallestM, + largestM + ) where + +import Control.Monad +import Data.Functor.Compose (Compose (Compose)) +import Data.Monoid (Any (Any)) +import Development.IDE.GHC.Compat +import Development.IDE.Graph.Classes +import Generics.SYB + + +-- | A generic query intended to be used for calling 'smallestM' and +-- 'largestM'. If the current node is a 'Located', returns whether or not the +-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which +-- indicates uncertainty. The search strategy in 'smallestM' et al. will +-- continue searching uncertain nodes. +genericIsSubspan :: + forall ast. + Typeable ast => + -- | The type of nodes we'd like to consider. + Proxy (Located ast) -> + SrcSpan -> + GenericQ (Maybe (Bool, ast)) +genericIsSubspan _ dst = mkQ Nothing $ \case + (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) + + +-- | Lift a function that replaces a value with several values into a generic +-- function. The result doesn't perform any searching, so should be driven via +-- 'everywhereM' or friends. +-- +-- The 'Int' argument is the index in the list being bound. +mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m +mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] + + +-- | Apply a monadic transformation everywhere in a top-down manner. +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f + + +------------------------------------------------------------------------------ +-- Custom SYB machinery +------------------------------------------------------------------------------ + +-- | Generic monadic transformations that return side-channel data. +type GenericMQ r m = forall a. Data a => a -> m (r, a) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at all every node whose children fail the +-- 'GenericQ', but which passes the query itself. +-- +-- The query must be a monotonic function when it returns 'Just'. That is, if +-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It +-- is the True-to-false edge of the query that triggers the transformation. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +smallestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m +smallestM q f = fmap snd . go + where + go :: GenericMQ Any m + go x = do + case q x of + Nothing -> gmapMQ go x + Just (True, a) -> do + it@(r, x') <- gmapMQ go x + case r of + Any True -> pure it + Any False -> fmap (Any True,) $ f a x' + Just (False, _) -> pure (mempty, x) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but +-- don't descend into children if the query matches. Because this traversal is +-- root-first, this policy will find the largest subtrees for which the query +-- holds true. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +largestM :: forall m a. Monad m => GenericQ (Maybe (Bool, a)) -> (a -> GenericM m) -> GenericM m +largestM q f = go + where + go :: GenericM m + go x = do + case q x of + Just (True, a) -> f a x + Just (False, _) -> pure x + Nothing -> gmapM go x + +newtype MonadicQuery r m a = MonadicQuery + { runMonadicQuery :: m (r, a) + } + deriving stock (Functor) + deriving Applicative via Compose m ((,) r) + + +------------------------------------------------------------------------------ +-- | Like 'gmapM', but also returns side-channel data. +gmapMQ :: + forall f r a. (Monoid r, Data a, Applicative f) => + (forall d. Data d => d -> f (r, d)) -> + a -> + f (r, a) +gmapMQ f = runMonadicQuery . gfoldl k pure + where + k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b + k c x = c <*> MonadicQuery (f x) 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 @@ -1,96 +1,91 @@ -- | Parallel versions of 'filter' and 'simpleFilter' + module Text.Fuzzy.Parallel ( filter, simpleFilter, - Scored(..), - -- reexports - Fuzzy, + match, + Scored(..) ) where -import Control.Monad.ST (runST) -import Control.Parallel.Strategies (Eval, Strategy, evalTraversable, - parTraversable, rseq, using) -import Data.Monoid.Textual (TextualMonoid) -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V --- need to use a stable sort -import Data.Bifunctor (second) -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import qualified Data.Monoid.Textual as T +import Control.Parallel.Strategies (rseq, using, parList, evalList) +import Data.Bits ((.|.)) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Text as T +import qualified Data.Text.Internal as T +import qualified Data.Text.Array as TA import Prelude hiding (filter) -import Text.Fuzzy (Fuzzy (..)) -data Scored a = Scored {score_ :: !Int, original:: !a} - deriving (Functor,Show) +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 "fnt" "infinite" +-- Just 3 -- --- >>> match "hsk" ("Haskell",1995) "<" ">" fst False --- Just ("aell",5) +-- >>> match "hsk" "Haskell" +-- Just 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 +match :: T.Text -- ^ Pattern in lowercase except for first character + -> T.Text -- ^ The text to search in. + -> Maybe Int -- ^ The score +match (T.Text pArr pOff pLen) (T.Text sArr sOff sLen) = go 0 1 pOff sOff where - null :: (T.TextualMonoid s) => s -> Bool - null = not . T.any (const True) + pTotal = pOff + pLen + sDelta = sOff + sLen - pTotal - 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 + go !totalScore !currScore !currPOff !currSOff + -- If pattern has been matched in full + | currPOff >= pTotal + = Just totalScore + -- If there is not enough left to match the rest of the pattern, equivalent to + -- (sOff + sLen - currSOff) < (pOff + pLen - currPOff) + | currSOff > currPOff + sDelta + = Nothing + -- This is slightly broken for non-ASCII: + -- 1. If code units, consisting a single pattern code point, are found as parts + -- of different code points, it counts as a match. Unless you use a ton of emojis + -- as identifiers, such false positives should not be be a big deal, + -- and anyways HLS does not currently support such use cases, because it uses + -- code point and UTF-16 code unit positions interchangeably. + -- 2. Case conversions is not applied to non-ASCII code points, because one has + -- to call T.toLower (not T.map toLower), reallocating the string in full, which + -- is too much of performance penalty for fuzzy search. Again, anyway HLS does not + -- attempt to do justice to Unicode: proper Unicode text matching requires + -- `unicode-transforms` and friends. + -- Altogether we sacrifice correctness for the sake of performance, which + -- is a right trade-off for fuzzy search. + | pByte <- TA.unsafeIndex pArr currPOff + , sByte <- TA.unsafeIndex sArr currSOff + -- First byte (currPOff == pOff) should match exactly, otherwise - up to case. + , pByte == sByte || (currPOff /= pOff && pByte == toLowerAscii sByte) + = let curr = currScore * 2 + 1 in + go (totalScore + curr) curr (currPOff + 1) (currSOff + 1) + | otherwise + = go totalScore 0 currPOff (currSOff + 1) + toLowerAscii w = if (w - 65) < 26 then w .|. 0x20 else w + -- | 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. - -> Int -- ^ Max. number of results wanted - -> s -- ^ Pattern. - -> [t] -- ^ The list of values 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. - -> [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) (V.fromList ts) - `using` - parVectorChunk chunkSize (evalTraversable forceScore)) - perfectScore = score $ fromMaybe (error $ T.toString undefined pattern) $ - match pattern' pattern' "" "" id - return $ partialSortByAscScore maxRes perfectScore v +filter :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +filter chunkSize maxRes pattern ts extract = partialSortByAscScore maxRes perfectScore (concat vss) 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 + pattern' = case T.uncons pattern of + Just (c, rest) -> T.cons c (T.toLower rest) + _ -> pattern + vss = map (mapMaybe (\t -> flip Scored t <$> match pattern' (extract t))) (chunkList chunkSize ts) + `using` parList (evalList rseq) + perfectScore = fromMaybe (error $ T.unpack pattern) $ match pattern' pattern' -- | Return all elements of the list that have a fuzzy -- match against the pattern. Runs with default settings where @@ -99,84 +94,44 @@ -- >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"] -- ["vim","virtual machine"] {-# INLINABLE simpleFilter #-} -simpleFilter :: (TextualMonoid s) - => Int -- ^ Chunk size. 1000 works well. - -> Int -- ^ Max. number of results wanted - -> s -- ^ Pattern to look for. - -> [s] -- ^ List of texts to check. - -> [Scored s] -- ^ The ones that match. +simpleFilter :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern to look for. + -> [T.Text] -- ^ List of texts to check. + -> [Scored T.Text] -- ^ The ones that match. simpleFilter chunk maxRes pattern xs = - filter chunk maxRes pattern xs mempty mempty id - --------------------------------------------------------------------------------- - --- | Evaluation that forces the 'score' field -forceScore :: TextualMonoid s => Fuzzy t s -> Eval(Fuzzy t s) -forceScore it@Fuzzy{score} = do - score' <- rseq score - return it{score = score'} + filter chunk maxRes pattern xs id -------------------------------------------------------------------------------- --- | Divides a vector in chunks, applies the strategy in parallel to each chunk. -parVectorChunk :: Int -> Strategy a -> Vector a -> Eval (Vector a) -parVectorChunk chunkSize st v = - V.concat <$> parTraversable (evalTraversable st) (chunkVector chunkSize v) - --- >>> chunkVector 3 (V.fromList [0..10]) --- >>> chunkVector 3 (V.fromList [0..11]) --- >>> chunkVector 3 (V.fromList [0..12]) --- [[0,1,2],[3,4,5],[6,7,8],[9,10]] --- [[0,1,2],[3,4,5],[6,7,8],[9,10,11]] --- [[0,1,2],[3,4,5],[6,7,8],[9,10,11],[12]] -chunkVector :: Int -> Vector a -> [Vector a] -chunkVector chunkSize v = do - let indices = chunkIndices chunkSize (0,V.length v) - [V.slice l (h-l+1) v | (l,h) <- indices] - --- >>> chunkIndices 3 (0,9) --- >>> chunkIndices 3 (0,10) --- >>> chunkIndices 3 (0,11) --- [(0,2),(3,5),(6,8)] --- [(0,2),(3,5),(6,8),(9,9)] --- [(0,2),(3,5),(6,8),(9,10)] -chunkIndices :: Int -> (Int,Int) -> [(Int,Int)] -chunkIndices chunkSize (from,to) = - map (second pred) $ - pairwise $ - [from, from+chunkSize .. to-1] ++ [to] - -pairwise :: [a] -> [(a,a)] -pairwise [] = [] -pairwise [_] = [] -pairwise (x:y:xs) = (x,y) : pairwise (y:xs) +chunkList :: Int -> [a] -> [[a]] +chunkList chunkSize = go + where + go [] = [] + go xs = ys : go zs + where + (ys, zs) = splitAt chunkSize xs -- | A stable partial sort ascending by score. O(N) best case, O(wanted*N) worst case -partialSortByAscScore :: TextualMonoid s - => Int -- ^ Number of items needed +partialSortByAscScore + :: Int -- ^ Number of items needed -> Int -- ^ Value of a perfect score - -> Vector (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 + -> [Scored t] +partialSortByAscScore wantedCount perfectScore orig = loop orig (SortState minBound perfectScore 0) [] where + loop [] st@SortState{..} acc | foundCount == wantedCount = reverse acc - | index == l --- ProgressCancelledException - = if bestScoreSeen < scoreWanted - then loop 0 st{scoreWanted = bestScoreSeen, bestScoreSeen = minBound} acc + | otherwise = if bestScoreSeen < scoreWanted + then loop orig st{scoreWanted = bestScoreSeen, bestScoreSeen = minBound} acc else reverse acc - | otherwise = - case v!index of - x | score x == scoreWanted - -> 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 + loop (x : xs) st@SortState{..} acc + | foundCount == wantedCount = reverse acc + | score x == scoreWanted + = loop xs st{foundCount = foundCount+1} (x:acc) + | score x < scoreWanted && score x > bestScoreSeen + = loop xs st{bestScoreSeen = score x} acc + | otherwise + = loop xs st acc data SortState a = SortState { bestScoreSeen :: !Int diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [0,1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs --- a/test/data/hover/GotoHover.hs +++ b/test/data/hover/GotoHover.hs @@ -61,3 +61,6 @@ hole :: Int hole = _ + +hole2 :: a -> Maybe a +hole2 = _ diff --git a/test/data/multi/a/A.hs b/test/data/multi/a/A.hs --- a/test/data/multi/a/A.hs +++ b/test/data/multi/a/A.hs @@ -1,3 +1,3 @@ module A(foo) where - +import Control.Concurrent.Async foo = () diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal --- a/test/data/multi/a/a.cabal +++ b/test/data/multi/a/a.cabal @@ -4,6 +4,6 @@ cabal-version: >= 1.2 library - build-depends: base + build-depends: base, async exposed-modules: A hs-source-dirs: . diff --git a/test/data/multi/c/C.hs b/test/data/multi/c/C.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/test/data/multi/c/c.cabal b/test/data/multi/c/c.cabal new file mode 100644 --- /dev/null +++ b/test/data/multi/c/c.cabal @@ -0,0 +1,9 @@ +name: c +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: C + hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project --- a/test/data/multi/cabal.project +++ b/test/data/multi/cabal.project @@ -1,1 +1,1 @@ -packages: a b +packages: a b c diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -module Paths_b ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - -import qualified Control.Exception as Exception -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath - -bindir = "/Users/pepeiborra/.cabal/bin" -libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" -dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" -datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" -libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" -sysconfdir = "/Users/pepeiborra/.cabal/etc" - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath -getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir ++ "/" ++ name) diff --git a/test/data/multi/hie.yaml b/test/data/multi/hie.yaml --- a/test/data/multi/hie.yaml +++ b/test/data/multi/hie.yaml @@ -4,3 +4,5 @@ component: "lib:a" - path: "./b" component: "lib:b" + - path: "./c" + component: "lib:c" diff --git a/test/exe/FuzzySearch.hs b/test/exe/FuzzySearch.hs new file mode 100644 --- /dev/null +++ b/test/exe/FuzzySearch.hs @@ -0,0 +1,132 @@ +module FuzzySearch (tests) where + +import Control.Monad (guard) +import Data.Char (toLower) +import Data.Maybe (catMaybes) +import qualified Data.Monoid.Textual as T +import Data.Text (Text, inits, pack) +import qualified Data.Text as Text +import System.Directory (doesFileExist) +import System.IO.Unsafe (unsafePerformIO) +import System.Info.Extra (isWindows) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) +import Text.Fuzzy (Fuzzy (..)) +import qualified Text.Fuzzy as Fuzzy +import Text.Fuzzy.Parallel +import Prelude hiding (filter) + +tests :: TestTree +tests = + testGroup + "Fuzzy search" + [ needDictionary $ + testGroup + "match works as expected on the english dictionary" + [ testProperty "for legit words" propLegit, + testProperty "for prefixes" propPrefix, + testProperty "for typos" propTypo + ] + ] + +test :: Text -> Bool +test candidate = do + let previous = + catMaybes + [ (d,) . Fuzzy.score + <$> referenceImplementation candidate d "" "" id + | d <- dictionary + ] + new = catMaybes [(d,) <$> match candidate d | d <- dictionary] + previous == new + +propLegit :: Property +propLegit = forAll (elements dictionary) test + +propPrefix :: Property +propPrefix = forAll (elements dictionary >>= elements . inits) test + +propTypo :: Property +propTypo = forAll typoGen test + +typoGen :: Gen Text +typoGen = do + w <- elements dictionary + l <- elements [0 .. Text.length w -1] + let wl = Text.index w l + c <- elements [ c | c <- ['a' .. 'z'], c /= wl] + return $ replaceAt w l c + +replaceAt :: Text -> Int -> Char -> Text +replaceAt t i c = + let (l, r) = Text.splitAt i t + in l <> Text.singleton c <> r + +dictionaryPath :: FilePath +dictionaryPath = "/usr/share/dict/words" + +{-# NOINLINE dictionary #-} +dictionary :: [Text] +dictionary = unsafePerformIO $ do + existsDictionary <- doesFileExist dictionaryPath + if existsDictionary + then map pack . words <$> readFile dictionaryPath + else pure [] + +referenceImplementation :: + (T.TextualMonoid s) => + -- | Pattern in lowercase except for first character + s -> + -- | The value containing the text to search in. + t -> + -- | The text to add before each match. + s -> + -- | The text to add after each match. + s -> + -- | The function to extract the text from the container. + (t -> s) -> + -- | The original value, rendered string and score. + Maybe (Fuzzy t s) +referenceImplementation 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 + +needDictionary :: TestTree -> TestTree +needDictionary + | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath) + | otherwise = id diff --git a/test/exe/HieDbRetry.hs b/test/exe/HieDbRetry.hs --- a/test/exe/HieDbRetry.hs +++ b/test/exe/HieDbRetry.hs @@ -5,25 +5,34 @@ withVar) import Control.Exception (ErrorCall (ErrorCall), evaluate, throwIO, tryJust) -import Data.Text (Text) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Tuple.Extra (dupe) import qualified Database.SQLite.Simple as SQLite import Development.IDE.Session (retryOnException, retryOnSqliteBusy) -import Development.IDE.Types.Logger (Logger (Logger), Priority, - noLogging) +import qualified Development.IDE.Session as Session +import Development.IDE.Types.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) import qualified System.Random as Random import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) -makeLogger :: Var [(Priority, Text)] -> Logger -makeLogger msgsVar = Logger $ \priority msg -> modifyVar msgsVar (\msgs -> pure ((priority, msg) : msgs, ())) +data Log + = LogSession Session.Log + deriving Show +makeLogger :: Var [Log] -> Recorder (WithPriority Log) +makeLogger msgsVar = + Recorder { + logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) + } + rng :: Random.StdGen rng = Random.mkStdGen 0 -retryOnSqliteBusyForTest :: Logger -> Int -> IO a -> IO a -retryOnSqliteBusyForTest logger maxRetryCount = retryOnException isErrorBusy logger 1 1 maxRetryCount rng +retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a +retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError isErrorBusy e @@ -60,7 +69,7 @@ let expected = 1 :: Int let maxRetryCount = 0 - actual <- retryOnSqliteBusyForTest noLogging maxRetryCount (pure expected) + actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) actual @?= expected @@ -69,7 +78,7 @@ let maxRetryCount = 3 let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest noLogging maxRetryCount incrementThenThrow) + _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) withVar countVar $ \count -> count @?= maxRetryCount + 1 @@ -86,7 +95,7 @@ modifyVar countVar (\count -> pure (dupe (count + 1))) - _ <- tryJust isErrorCall (retryOnSqliteBusyForTest noLogging maxRetryCount throwThenIncrement) + _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) withVar countVar $ \count -> count @?= 0 @@ -101,27 +110,29 @@ else modifyVar countVar (\count -> pure (dupe (count + 1))) - _ <- retryOnSqliteBusy noLogging rng incrementThenThrowThenIncrement + _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement withVar countVar $ \count -> count @?= 2 , testCase "retryOnException exponentially backs off" $ do - logMsgsVar <- newVar ([] :: [(Priority, Text)]) + logMsgsVar <- newVar ([] :: [Log]) let maxDelay = 100 let baseDelay = 1 let maxRetryCount = 6 let logger = makeLogger logMsgsVar - result <- tryJust isErrorBusy (retryOnException isErrorBusy logger maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) case result of Left _ -> do withVar logMsgsVar $ \logMsgs -> - if | ((_, lastLogMsg) : _) <- logMsgs -> - -- uses log messages to indirectly check backoff... - lastLogMsg @?= "Retries exhausted - base delay: 64, maximumDelay: 100, maxRetryCount: 0, exception: SQLite3 returned ErrorBusy while attempting to perform : " + -- uses log messages to check backoff... + if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do + baseDelay @?= 64 + maximumDelay @?= 100 + maxRetryCount @?= 0 | otherwise -> assertFailure "Expected more than 0 log messages" Right _ -> assertFailure "Expected ErrorBusy exception" ] diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -55,6 +55,8 @@ flushMessages, getInterfaceFilesDir, getStoredKeys, + isReferenceReady, + referenceReady, standardizeQuotes, waitForAction, waitForGC, @@ -93,8 +95,9 @@ import Test.QuickCheck -- import Test.QuickCheck.Instances () import Control.Concurrent.Async -import Control.Lens (to, (^.)) +import Control.Lens (to, (^.), (.~)) import Control.Monad.Extra (whenJust) +import Data.Function ((&)) import Data.IORef import Data.IORef.Extra (atomicModifyIORef_) import Data.String (IsString (fromString)) @@ -105,11 +108,23 @@ import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) +import Development.IDE.Types.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, + cmapWithPrio, + makeDefaultStderrRecorder) +import qualified FuzzySearch +import GHC.Stack (emptyCallStack) import qualified HieDbRetry import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as L +import Language.LSP.Types.Lens (workspace, didChangeWatchedFiles) import qualified Progress import System.Time.Extra import Test.Tasty @@ -120,6 +135,15 @@ import Text.Printf (printf) import Text.Regex.TDFA ((=~)) +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -148,6 +172,18 @@ main :: IO () main = do + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + + let recorder = docWithFilteredPriorityRecorder + & cmapWithPrio pretty + -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do @@ -171,7 +207,7 @@ , thTests , symlinkTests , safeTests - , unitTests + , unitTests recorder logger , haddockTests , positionMappingTests , watchedFilesTests @@ -386,9 +422,12 @@ let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] - , ignoreInWindowsBecause "Broken in windows" $ testSessionWait "add missing module (non workspace)" $ do - -- need to canonicalize in Mac Os - tmpDir <- liftIO $ canonicalizePath =<< getTemporaryDirectory + , testCase "add missing module (non workspace)" $ + -- By default lsp-test sends FileWatched notifications for all files, which we don't want + -- as non workspace modules will not be watched by the LSP server. + -- To work around this, we tell lsp-test that our client doesn't have the + -- FileWatched capability, which is enough to disable the notifications + withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do let contentB = T.unlines [ "module ModuleB where" , "import ModuleA ()" @@ -1153,73 +1192,71 @@ typeWildCardActionTests :: TestTree typeWildCardActionTests = testGroup "type wildcard actions" - [ testSession "global signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x = x" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (p -> p)" - , "func x = x" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "multi-line message" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x y = x + y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (Integer -> Integer -> Integer)" - , "func x y = x + y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "local signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - doc <- createDoc "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: (Int)" - , " y = x * 2" - , " in y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction + [ testUseTypeSignature "global signature" + [ "func :: _" + , "func x = x" + ] + [ "func :: (p -> p)" + , "func x = x" + ] + , testUseTypeSignature "local signature" + [ "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + [ "func :: Int -> Int" + , "func x =" + , " let y :: Int" + , " y = x * 2" + , " in y" + ] + , testUseTypeSignature "multi-line message" + [ "func :: _" + , "func x y = x + y" + ] + [ "func :: (Integer -> Integer -> Integer)" + , "func x y = x + y" + ] + , testUseTypeSignature "type in parentheses" + [ "func :: a -> _" + , "func x = (x, const x)" + ] + [ "func :: a -> (a, b -> a)" + , "func x = (x, const x)" + ] + , testUseTypeSignature "type in brackets" + [ "func :: _ -> Maybe a" + , "func xs = head xs" + ] + [ "func :: [Maybe a] -> Maybe a" + , "func xs = head xs" + ] + , testUseTypeSignature "unit type" + [ "func :: IO _" + , "func = putChar 'H'" + ] + [ "func :: IO ()" + , "func = putChar 'H'" + ] ] + where + -- | Test session of given name, checking action "Use type signature..." + -- on a test file with given content and comparing to expected result. + testUseTypeSignature name textIn textOut = testSession name $ do + let fileStart = "module Testing where" + content = T.unlines $ fileStart : textIn + expectedContentAfterAction = T.unlines $ fileStart : textOut + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getAllCodeActions doc + let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + liftIO $ expectedContentAfterAction @=? contentAfterAction {-# HLINT ignore "Use nubOrd" #-} removeImportTests :: TestTree @@ -1480,9 +1517,110 @@ ] where tests overrideCheckProject = - [ testSession "extend single line import with value" $ template + [ testSession "extend all constructors for record field" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" + , "data A = B { a :: Int }" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (A(B))" + , "f = a" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(a) to the import list of ModuleA" + , "Add a to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(..))" + , "f = a" + ]) + , testSession "extend all constructors with sibling" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors with comment" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "data Foo" + , "data Bar" + , "data A = B | C" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (C{-comment--}) , Bar ) " + , "f = B" + ]) + (Range (Position 2 4) (Position 2 5)) + [ "Add A(..) to the import list of ModuleA" + , "Add A(B) to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA ( Foo, A (..{-comment--}) , Bar ) " + , "f = B" + ]) + , testSession "extend all constructors for type operator" $ template + [] + ("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + (Range (Position 3 17) (Position 3 18)) + [ "Add (:~:)(..) to the import list of Data.Type.Equality" + , "Add type (:~:)(Refl) to the import list of Data.Type.Equality"] + (T.unlines + [ "module ModuleA where" + , "import Data.Type.Equality ((:~:) (..))" + , "x :: (:~:) [] []" + , "x = Refl" + ]) + , testSession "extend all constructors for class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + [ "Add C(..) to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + ] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(..))" + , "b = m2" + ]) + , testSession "extend single line import with value" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" , "stuffA :: Double" , "stuffA = 0.00750" , "stuffB :: Integer" @@ -1520,6 +1658,40 @@ , "import ModuleA as A (stuffB, (.*))" , "main = print (stuffB .* stuffB)" ]) + , testSession "extend single line import with infix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList)" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + (Range (Position 2 5) (Position 2 6)) + [ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty" + , "Add NonEmpty(..) to the import list of Data.List.NonEmpty" + ] + (T.unlines + [ "module ModuleB where" + , "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))" + , "main = case (fromList []) of _ :| _ -> pure ()" + ]) + , testSession "extend single line import with prefix constructor" $ template + [] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes)" + , "x = Just 10" + ]) + (Range (Position 3 5) (Position 2 6)) + [ "Add Maybe(Just) to the import list of Data.Maybe" + , "Add Maybe(..) to the import list of Data.Maybe" + ] + (T.unlines + [ "module ModuleB where" + , "import Prelude hiding (Maybe(..))" + , "import Data.Maybe (catMaybes, Maybe (Just))" + , "x = Just 10" + ]) , testSession "extend single line import with type" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" @@ -1551,7 +1723,9 @@ , "b = Constructor" ]) (Range (Position 3 5) (Position 3 5)) - ["Add A(Constructor) to the import list of ModuleA"] + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] (T.unlines [ "module ModuleB where" , "import ModuleA (A (Constructor))" @@ -1570,7 +1744,9 @@ , "b = Constructor" ]) (Range (Position 3 5) (Position 3 5)) - ["Add A(Constructor) to the import list of ModuleA"] + [ "Add A(Constructor) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] (T.unlines [ "module ModuleB where" , "import ModuleA (A (Constructor{-Constructor-}))" @@ -1590,7 +1766,9 @@ , "b = ConstructorFoo" ]) (Range (Position 3 5) (Position 3 5)) - ["Add A(ConstructorFoo) to the import list of ModuleA"] + [ "Add A(ConstructorFoo) to the import list of ModuleA" + , "Add A(..) to the import list of ModuleA" + ] (T.unlines [ "module ModuleB where" , "import ModuleA (A (ConstructorBar, ConstructorFoo), a)" @@ -1652,8 +1830,10 @@ , "b = m2" ]) (Range (Position 2 5) (Position 2 5)) - ["Add C(m2) to the import list of ModuleA", - "Add m2 to the import list of ModuleA"] + [ "Add C(m2) to the import list of ModuleA" + , "Add m2 to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] (T.unlines [ "module ModuleB where" , "import ModuleA (C(m1, m2))" @@ -1672,8 +1852,10 @@ , "b = m2" ]) (Range (Position 2 5) (Position 2 5)) - ["Add m2 to the import list of ModuleA", - "Add C(m2) to the import list of ModuleA"] + [ "Add m2 to the import list of ModuleA" + , "Add C(m2) to the import list of ModuleA" + , "Add C(..) to the import list of ModuleA" + ] (T.unlines [ "module ModuleB where" , "import ModuleA (C(m1), m2)" @@ -1714,7 +1896,8 @@ , "x = Refl" ]) (Range (Position 3 17) (Position 3 18)) - ["Add type (:~:)(Refl) to the import list of Data.Type.Equality"] + [ "Add type (:~:)(Refl) to the import list of Data.Type.Equality" + , "Add (:~:)(..) to the import list of Data.Type.Equality"] (T.unlines [ "module ModuleA where" , "import Data.Type.Equality ((:~:) (Refl))" @@ -1754,7 +1937,7 @@ , "f = Foo 1" ]) (Range (Position 3 4) (Position 3 6)) - ["Add Foo(Foo) to the import list of ModuleA"] + ["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"] (T.unlines [ "module ModuleB where" , "import ModuleA(Foo (Foo))" @@ -1934,11 +2117,14 @@ , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" -- don't suggest data constructor when we only need the type , test False [] "f :: Bar" [] "import Bar (Bar(Bar))" + -- don't suggest all data constructors for the data type + , test False [] "f :: Bar" [] "import Bar (Bar(..))" ] , testGroup "want suggestion" [ wantWait [] "f = foo" [] "import Foo (foo)" , wantWait [] "f = Bar" [] "import Bar (Bar(Bar))" , wantWait [] "f :: Bar" [] "import Bar (Bar)" + , wantWait [] "f = Bar" [] "import Bar (Bar(..))" , test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" @@ -1980,12 +2166,15 @@ , "qualified Data.Functor as T" , "qualified Data.Data as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" ] - , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" ] where test = test' False wantWait = test' True True + test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do configureCheckProject waitForCheckProject let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other @@ -1995,7 +2184,7 @@ liftIO $ writeFileUTF8 (dir "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"] doc <- createDoc "Test.hs" "haskell" before waitForProgressDone - _diags <- waitForDiagnostics + _ <- waitForDiagnostics -- there isn't a good way to wait until the whole project is checked atm when waitForCheckProject $ liftIO $ sleep 0.5 let defLine = fromIntegral $ length imps + 1 @@ -2354,7 +2543,7 @@ liftIO $ contentAfterAction @?= T.unlines (txtB ++ [ "" , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" + , "select = _" ] ++ txtB') , testSession "define a hole" $ do @@ -2381,9 +2570,61 @@ ,"foo False = False" , "" , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" + , "select = _" ] ++ txtB') + , testSession "insert new function definition - Haddock comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- | This is a haddock comment" + , "haddock :: Int -> Int" + , "haddock = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected + , testSession "insert new function definition - normal comments" $ do + let start = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined" + ] + let expected = ["foo :: Int -> Bool" + , "foo x = select (x + 1)" + , "" + , "select :: Int -> Bool" + , "select = _" + , "" + , "-- This is a normal comment" + , "normal :: Int -> Int" + , "normal = undefined"] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines start) + _ <- waitForDiagnostics + InR action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(InR CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 0 50) + liftIO $ actionTitle @?= "Define select :: Int -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines expected ] @@ -3942,7 +4183,9 @@ , testGroup "hover" $ mapMaybe snd tests , checkFileCompiles sourceFilePath $ expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ] + [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) + ] , testGroup "type-definition" typeDefinitionTests ] typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" @@ -3994,6 +4237,7 @@ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]] imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14] @@ -4048,6 +4292,7 @@ , test no yes outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" + , test no yes holeL65 hleInfo2 "hole with variable" , test no skip cccL17 docLink "Haddock html links" , testM yes yes imported importedSig "Imported symbol" , testM yes yes reexported reexportedSig "Imported symbol (reexported)" @@ -4370,6 +4615,7 @@ , testGroup "package" packageCompletionTests , testGroup "project" projectCompletionTests , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests ] completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree @@ -4594,13 +4840,13 @@ "constructor" ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] (Position 2 8) - [ ("True", CiConstructor, "True ", True, True, Nothing) + [ ("True", CiConstructor, "True", True, True, Nothing) ], completionTest "type" ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] (Position 2 8) - [ ("Bool", CiStruct, "Bool ", True, True, Nothing) + [ ("Bool", CiStruct, "Bool", True, True, Nothing) ], completionTest "qualified" @@ -4623,6 +4869,15 @@ ] (Position 3 6) [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] + ], testGroup "auto import snippets" [ completionCommandTest "show imports not in list - simple" @@ -4766,7 +5021,7 @@ -- This should be sufficient to detect that we are in a -- type context and only show the completion to the type. (Position 3 11) - [("Integer", CiStruct, "Integer ", True, True, Nothing)], + [("Integer", CiStruct, "Integer", True, True, Nothing)], testSession "duplicate record fields" $ do void $ @@ -4813,7 +5068,7 @@ _ <- waitForDiagnostics compls <- getCompletions doc (Position 2 12) let compls' = - [T.drop 1 $ T.dropEnd 10 d + [T.drop 1 $ T.dropEnd 3 d | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} <- compls , _label == "fromList" @@ -4833,7 +5088,7 @@ _ <- waitForDiagnostics compls <- getCompletions doc (Position 2 7) let compls' = - [T.drop 1 $ T.dropEnd 10 d + [T.drop 1 $ T.dropEnd 3 d | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} <- compls , _label == "Map" @@ -4917,7 +5172,7 @@ ] compls <- getCompletions doc (Position 1 10) let compls' = - [T.drop 1 $ T.dropEnd 10 d + [T.drop 1 $ T.dropEnd 3 d | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} <- compls , _label == "anidentifier" @@ -4976,6 +5231,97 @@ item ^. L.label @?= "anidentifier" ] +completionDocTests :: [TestTree] +completionDocTests = + [ testSession "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSession "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] + , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] + , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n abcabc\n\ndef\n"] + , testSession "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = no" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" + test doc (Position 1 8) "not" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSession "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92]) "Completion doc doesn't support ghc9" + brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2" + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92]) "Extern doc doesn't support MacOS for ghc9" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls + , _label == label + ] + liftIO $ compls' @?= expected + highlightTests :: TestTree highlightTests = testGroup "highlight" [ testSessionWait "value" $ do @@ -5229,33 +5575,62 @@ xfail = flip expectFailBecause ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause - | isWindows = ignoreTestBecause - | otherwise = \_ x -> x +ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -ignoreInWindowsForGHC88And810 - | ghcVersion `elem` [GHC88, GHC810] = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" - | otherwise = id +ignoreInWindowsForGHC88And810 = + ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10" ignoreForGHC92 :: String -> TestTree -> TestTree -ignoreForGHC92 msg - | ghcVersion == GHC92 = ignoreTestBecause msg - | otherwise = id +ignoreForGHC92 = ignoreFor (BrokenForGHC [GHC92]) ignoreInWindowsForGHC88 :: TestTree -> TestTree -ignoreInWindowsForGHC88 - | ghcVersion == GHC88 = - ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" - | otherwise = id +ignoreInWindowsForGHC88 = + ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8" knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree -knownBrokenForGhcVersions ghcVers - | ghcVersion `elem` ghcVers = expectFailBecause - | otherwise = \_ x -> x +knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) +data BrokenOS = Linux | MacOS | Windows deriving (Show) +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = \_ -> id + data Expect = ExpectRange Range -- Both gotoDef and hover should report this range | ExpectLocation Location @@ -5334,7 +5709,7 @@ [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] ,testGroup "sub-directory" [simpleSubDirectoryTest] ] @@ -5454,12 +5829,10 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc liftIO $ assertBool "A should typecheck" ideResultSuccess - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc liftIO $ assertBool "B should typecheck" ideResultSuccess locs <- getDefinitions bdoc (Position 2 7) @@ -5472,18 +5845,33 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - expectNoMoreDiagnostics 10 - aSource <- liftIO $ readFileUtf8 aPath - (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource - -- Need to have some delay here or the test fails - expectNoMoreDiagnostics 10 + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL adoc 2 0 2 3 + let fooL = mkL auri 2 0 2 3 checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 +-- Now with 3 components +simpleMultiTest3 :: TestTree +simpleMultiTest3 = + testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + cPath = dir "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + -- Like simpleMultiTest but open the files in component 'a' in a seperate session simpleMultiDefTest :: TestTree simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do @@ -5492,11 +5880,7 @@ adoc <- liftIO $ runInDir dir $ do aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - if equalFilePath fp' aPath then pure () else Nothing - _ -> Nothing + skipManyTill anyMessage $ isReferenceReady aPath closeDoc adoc pure adoc bSource <- liftIO $ readFileUtf8 bPath @@ -5523,12 +5907,22 @@ -- Dirty the cache liftIO $ runInDir dir $ do cDoc <- createDoc cPath "haskell" cSource - _ <- getHover cDoc $ Position 4 3 - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - if equalFilePath fp' cPath then pure () else Nothing - _ -> Nothing + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest STextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId STextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse closeDoc cDoc cdoc <- createDoc cPath "haskell" cSource locs <- getDefinitions cdoc (Position 7 4) @@ -5938,11 +6332,7 @@ loop :: [FilePath] -> Session () loop [] = pure () loop docs = do - doc <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do - A.Success fp' <- pure $ fromJSON fp - find (fp' ==) docs - _ -> Nothing + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) loop (delete doc docs) loop docs f dir @@ -6041,7 +6431,18 @@ -- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' dir startExeIn startSessionIn extraOptions s = do +runInDir' = runInDir'' lspTestCaps + +runInDir'' + :: ClientCapabilities + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> Session b + -> IO b +runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do + ghcideExe <- locateGhcideExecutable let startDir = dir startExeIn let projDir = dir startSessionIn @@ -6061,10 +6462,11 @@ -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspTestCaps projDir $ do + runSessionWithConfig conf cmd lspCaps projDir $ do configureCheckProject False s + getConfigFromEnv :: IO SessionConfig getConfigFromEnv = do logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" @@ -6082,6 +6484,9 @@ lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing + openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do source <- liftIO $ readFileUtf8 $ "test/data" path @@ -6116,8 +6521,8 @@ findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction findCodeAction doc range t = head <$> findCodeActions doc range [t] -unitTests :: TestTree -unitTests = do +unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree +unitTests recorder logger = do testGroup "Unit" [ testCase "empty file path does NOT work with the empty String literal" $ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." @@ -6152,14 +6557,14 @@ let plugins = pluginDescToIdePlugins $ [ (defaultPluginDescriptor $ fromString $ show i) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ -> + [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> liftIO $ atomicModifyIORef_ orderRef (i:) ] } | i <- [(1::Int)..20] - ] ++ Ghcide.descriptors + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - testIde IDE.testing{IDE.argsHlsPlugins = plugins} $ do + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef @@ -6171,6 +6576,7 @@ let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us assertBool msg (resolution_us <= 1000) , Progress.tests + , FuzzySearch.tests ] garbageCollectionTests :: TestTree @@ -6257,16 +6663,14 @@ if t /= t' then return delay_us else findResolution_us (delay_us * 10) -testIde :: IDE.Arguments -> Session a -> IO a -testIde = testIde' "." - -testIde' :: FilePath -> IDE.Arguments -> Session a -> IO a -testIde' projDir arguments session = do +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do config <- getConfigFromEnv cwd <- getCurrentDirectory (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe - let server = IDE.defaultMain arguments + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite } 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 @@ -29,7 +29,14 @@ , getStoredKeys , waitForCustomMessage , waitForGC - ,getBuildKeysBuilt,getBuildKeysVisited,getBuildKeysChanged,getBuildEdgesCount,configureCheckProject) where + , getBuildKeysBuilt + , getBuildKeysVisited + , getBuildKeysChanged + , getBuildEdgesCount + , getRebuildsCount + , configureCheckProject + , isReferenceReady + , referenceReady) where import Control.Applicative.Combinators import Control.Lens hiding (List) @@ -58,6 +65,7 @@ import System.Directory (canonicalizePath) import System.Time.Extra import Test.Tasty.HUnit +import System.FilePath (equalFilePath) requireDiagnosticM :: (Foldable f, Show (f Diagnostic), HasCallStack) @@ -218,6 +226,9 @@ getBuildEdgesCount :: Session (Either ResponseError Int) getBuildEdgesCount = tryCallTestPlugin GetBuildEdgesCount +getRebuildsCount :: Session (Either ResponseError Int) +getRebuildsCount = tryCallTestPlugin GetRebuildsCount + getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) @@ -254,3 +265,16 @@ sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) + +-- | Pattern match a message from ghcide indicating that a file has been indexed +isReferenceReady :: FilePath -> Session () +isReferenceReady p = void $ referenceReady (equalFilePath p) + +referenceReady :: (FilePath -> Bool) -> Session FilePath +referenceReady pred = satisfyMaybe $ \case + FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params}) + | A.Success fp <- A.fromJSON _params + , pred fp + -> Just fp + _ -> Nothing +