diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index fd920f71d..848323344 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -54,7 +54,7 @@ jobs: # change of the strategy may require changing the bootstrapping/run code steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - run: git fetch origin master # check the master branch for benchmarking diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index f40e6f57e..aef79ec63 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -25,7 +25,7 @@ jobs: runs-on: ubuntu-18.04 steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - name: Set hls release version run: | @@ -117,7 +117,7 @@ jobs: # from https://github.com/actions/upload-release-asset/issues/47#issuecomment-659071145 - name: Upload binaries tarball to the release if: ${{ github.event.release.upload_url != '' }} - uses: actions/github-script@v2 + uses: actions/github-script@v6 with: github-token: ${{secrets.GITHUB_TOKEN}} script: | diff --git a/.github/workflows/caching.yml b/.github/workflows/caching.yml index 2473f7ad7..ab4aed03f 100644 --- a/.github/workflows/caching.yml +++ b/.github/workflows/caching.yml @@ -95,7 +95,7 @@ jobs: ] steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: ./.github/actions/setup-build with: diff --git a/.github/workflows/flags.yml b/.github/workflows/flags.yml index c23533430..1ae1f3e14 100644 --- a/.github/workflows/flags.yml +++ b/.github/workflows/flags.yml @@ -55,7 +55,7 @@ jobs: ] steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: ./.github/actions/setup-build with: diff --git a/.github/workflows/hackage.yml b/.github/workflows/hackage.yml index 71be69f74..8aea5f8de 100644 --- a/.github/workflows/hackage.yml +++ b/.github/workflows/hackage.yml @@ -49,7 +49,7 @@ jobs: steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: ./.github/actions/setup-build with: diff --git a/.github/workflows/hlint.yml b/.github/workflows/hlint.yml index c71a5722e..f39191b48 100644 --- a/.github/workflows/hlint.yml +++ b/.github/workflows/hlint.yml @@ -10,7 +10,7 @@ jobs: name: "Hlint check run" runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - name: 'Installing' uses: rwe/actions-hlint-setup@v1 diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index e71e6a60b..e9c2106d1 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -54,7 +54,7 @@ jobs: os: [ubuntu-latest, macOS-latest] steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: cachix/install-nix-action@v16 with: @@ -88,7 +88,7 @@ jobs: os: [ubuntu-latest, macOS-latest] steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: cachix/install-nix-action@v16 with: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index ef51c971a..64d69e2eb 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -107,7 +107,7 @@ jobs: ghc: '8.8.4' steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: ./.github/actions/setup-build with: @@ -133,6 +133,10 @@ jobs: path: "**/.tasty-rerun-log*" key: v1-${{ runner.os }}-${{ matrix.ghc }}-test-log-${{ github.sha }} + - if: matrix.test + name: Test hls-graph + run: cabal test hls-graph --test-options="$TEST_OPTS" + - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory @@ -164,7 +168,7 @@ jobs: name: Test hls-floskell-plugin run: cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-floskell-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2.1' + - if: matrix.test name: Test hls-class-plugin run: cabal test hls-class-plugin --test-options="$TEST_OPTS" || cabal test hls-class-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="$TEST_OPTS" @@ -224,7 +228,7 @@ jobs: name: Test hls-module-name-plugin test suite run: cabal test hls-module-name-plugin --test-options="$TEST_OPTS" || cabal test hls-module-name-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-module-name-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.2.1' + - if: matrix.test name: Test hls-alternate-number-format-plugin test suite run: cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" || cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" @@ -236,6 +240,10 @@ jobs: name: Test hls-selection-range-plugin test suite run: cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" || cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-selection-range-plugin --test-options="$TEST_OPTS" + - if: matrix.test + name: Test hls-change-type-signature test suite + run: cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/bindist/GNUmakefile.in b/bindist/GNUmakefile.in index 5e1b01de2..aec8480fc 100644 --- a/bindist/GNUmakefile.in +++ b/bindist/GNUmakefile.in @@ -5,6 +5,7 @@ BINDIR ?= $(PREFIX)/bin HLS_VERSION := @@HLS_VERSION@@ +FIND := find INSTALL := install INSTALL_D := $(INSTALL) -d INSTALL_X := $(INSTALL) -vm 755 @@ -18,10 +19,7 @@ install: $(INSTALL_D) "$(DESTDIR)$(BINDIR)" $(INSTALL_D) "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/lib" $(INSTALL_D) "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/bin" - for f in $(wildcard lib/*/*) ; do \ - $(INSTALL_D) "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/`dirname $$f`" && \ - $(INSTALL_X) "$$f" "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/$$f" ; \ - done + $(FIND) lib -mindepth 2 -type f -exec sh -c '$(INSTALL_D) "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/`dirname $$1`" && $(INSTALL_X) "$$1" "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/$$1"' sh '{}' \; for b in $(wildcard bin/*) ; do \ $(INSTALL_D) "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/" && \ $(INSTALL_X) "$$b" "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/$$b" ; \ @@ -31,7 +29,7 @@ install: "$$h" > "$(DESTDIR)$(BINDIR)/$${h%.in}" && \ $(CHMOD_X) "$(DESTDIR)$(BINDIR)/$${h%.in}" ; \ done - $(LN_S) "`scripts/relpath.sh "$(BINDIR)" "$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/bin/haskell-language-server-wrapper"`" \ + $(LN_S) "`scripts/relpath.sh "$(DESTDIR)$(BINDIR)" "$(DESTDIR)$(LIBDIR)/haskell-language-server-$(HLS_VERSION)/bin/haskell-language-server-wrapper"`" \ "$(DESTDIR)$(BINDIR)/haskell-language-server-wrapper" version: diff --git a/cabal-ghc90.project b/cabal-ghc90.project index 38f318fdc..c80819263 100644 --- a/cabal-ghc90.project +++ b/cabal-ghc90.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin tests: true @@ -36,7 +37,7 @@ package * write-ghc-environment-files: never -index-state: 2022-02-25T21:47:10Z +index-state: 2022-03-08T10:53:01Z constraints: -- These plugins don't work on GHC9 yet diff --git a/cabal-ghc921.project b/cabal-ghc921.project index 8d2233301..b0e9ecad8 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin with-compiler: ghc-9.2.1 @@ -38,14 +39,13 @@ package * write-ghc-environment-files: never -index-state: 2022-02-25T21:47:10Z +index-state: 2022-03-08T10:53:01Z constraints: -- These plugins don't build/work on GHC92 yet haskell-language-server +ignore-plugins-ghc-bounds -brittany - -class -haddockComments -hlint -retrie diff --git a/cabal.project b/cabal.project index e1c8aa98c..2057ab1ab 100644 --- a/cabal.project +++ b/cabal.project @@ -27,6 +27,7 @@ packages: ./plugins/hls-alternate-number-format-plugin ./plugins/hls-qualify-imported-names-plugin ./plugins/hls-selection-range-plugin + ./plugins/hls-change-type-signature-plugin -- Standard location for temporary packages needed for particular environments -- For example it is used in the project gitlab mirror to help in the MAcOS M1 build script @@ -41,7 +42,7 @@ package * write-ghc-environment-files: never -index-state: 2022-02-25T21:47:10Z +index-state: 2022-03-08T10:53:01Z constraints: hyphenation +embed diff --git a/docs/features.md b/docs/features.md index 2939daee0..dfb0b6b51 100644 --- a/docs/features.md +++ b/docs/features.md @@ -18,7 +18,7 @@ Many of these are standard LSP features, but a lot of special features are provi | [Highlight references](#highlight-references) | `textDocument/documentHighlight` | | [Code actions](#code-actions) | `textDocument/codeAction` | | [Code lenses](#code-lenses) | `textDocument/codeLens` | -| [Selection range](#selection-range) | `textDocument/selectionRange` | +| [Selection range](#selection-range) | `textDocument/selectionRange` | The individual sections below also identify which [HLS plugin](./what-is-hls.md#hls-plugins) is responsible for providing the given functionality, which is useful if you want to raise an issue report or contribute! Additionally, not all plugins are supported on all versions of GHC, see the [GHC version support page](supported-versions.md) for details. @@ -237,6 +237,26 @@ Provides a variety of code actions for interactive code development, see makeDefaultStderrRecorder Nothing Info args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) + (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 (minPriority, logFilePath, includeExamplePlugins) = case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> @@ -42,9 +59,29 @@ main = do _ -> (Info, Nothing, False) withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do - let recorder = - textWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio pretty + let + recorder = cmapWithPrio pretty $ mconcat + [textWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + , lspMessageRecorder + & cfilter (\WithPriority{ priority } -> priority >= Error) + & cmapWithPrio renderDoc + , lspLogRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) + ] + plugins = (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) - defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) + defaultMain + (cmapWithPrio LogIdeMain recorder) + args + (plugins <> pluginDescToIdePlugins [lspRecorderPlugin]) + +renderDoc :: Doc a -> Text +renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep + ["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): " + ,d + ] + +issueTrackerUrl :: Doc a +issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 7a55c5ea0..05ccc8fb2 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -79,6 +79,9 @@ import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat import Ide.Plugin.SelectionRange as SelectionRange #endif +#if changeTypeSignature +import Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +#endif -- formatters #if floskell @@ -184,6 +187,9 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins #endif #if selectionRange SelectionRange.descriptor "selectionRange" : +#endif +#if changeTypeSignature + ChangeTypeSignature.descriptor "changeTypeSignature" : #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index ffc8db438..b721a4f3f 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -115,7 +115,7 @@ launchHaskellLanguageServer parsedArgs = do #else let Cradle { cradleOptsProg = CradleAction { runGhcCmd } } = cradle -- we need to be compatible with NoImplicitPrelude - ghcBinary <- (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-e", "do e <- System.Environment.getExecutablePath ; System.IO.putStr e"]) + ghcBinary <- (fmap trim <$> runGhcCmd ["-v0", "-package-env=-", "-ignore-dot-ghci", "-e", "Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"]) >>= cradleResult "Failed to get project GHC executable path" libdir <- HieBios.getRuntimeGhcLibDir cradle >>= cradleResult "Failed to get project GHC libdir path" diff --git a/flake.nix b/flake.nix index 63fc3d81c..5676f5a5f 100644 --- a/flake.nix +++ b/flake.nix @@ -60,7 +60,7 @@ flake = false; }; hie-bios = { - url = "https://hackage.haskell.org/package/hie-bios-0.9.0/hie-bios-0.9.0.tar.gz"; + url = "https://hackage.haskell.org/package/hie-bios-0.9.1/hie-bios-0.9.1.tar.gz"; flake = false; }; }; @@ -112,7 +112,7 @@ with haskell.lib; { # Patches don't apply github = overrideCabal hsuper.github (drv: { patches = []; }); - # GHCIDE requires hie-bios ^>=0.9.0 + # GHCIDE requires hie-bios ^>=0.9.1 hie-bios = hself.callCabal2nix "hie-bios" inputs.hie-bios {}; # We need an older version hiedb = hself.hiedb_0_4_1_0; diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 178052da7..6e7f169ad 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,6 +8,7 @@ module Main(main) where import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless) +import Control.Monad.IO.Class (liftIO) import Data.Default (def) import Data.Function ((&)) import Data.Version (showVersion) @@ -17,22 +18,24 @@ 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 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), + Priority (Debug, Info, Error), Recorder (Recorder), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, - makeDefaultStderrRecorder) + 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) @@ -86,12 +89,25 @@ main = withTelemetryLogger $ \telemetryLogger -> do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority - let docWithFilteredPriorityRecorder@Recorder{ logger_ } = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) + (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_ (WithPriority p emptyCallStack (pretty m)) + let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m)) let recorder = docWithFilteredPriorityRecorder & cmapWithPrio pretty @@ -105,6 +121,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do { 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 @@ -121,7 +138,6 @@ main = withTelemetryLogger $ \telemetryLogger -> do 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/ghcide.cabal b/ghcide/ghcide.cabal index 1a0775714..b34170e68 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -105,7 +105,7 @@ library ghc-check >=0.5.0.4, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios ^>= 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) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 07d459565..f8492464a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -99,6 +99,7 @@ import HieDb.Types import HieDb.Utils import System.Random (RandomGen) import qualified System.Random as Random +import Control.Monad.IO.Unlift (MonadUnliftIO) data Log = LogSettingInitialDynFlags @@ -253,7 +254,7 @@ getInitialGhcLibDirDefault recorder rootDir = do case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - log Warning $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle + log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do log Warning LogGetInitialGhcLibDirDefaultCradleNone @@ -845,7 +846,7 @@ should be filtered out, such that we dont have to re-compile everything. -- | 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 => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags setCacheDirs recorder CacheDirs{..} dflags = do logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 29325813d..74cd92f8b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -628,14 +628,14 @@ readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row - logWith recorder Logger.Debug $ LogLoadingHieFile file + liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file exceptToMaybeT $ readHieFileFromDisk recorder hie_loc readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - let log = logWith recorder + let log = (liftIO .) . logWith recorder case res of Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc @@ -717,15 +717,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do 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 (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 10056da60..546d61c55 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -42,7 +42,6 @@ module Development.IDE.Core.Shake( RuleBody(..), define, defineNoDiagnostics, defineEarlyCutoff, - defineOnDisk, needOnDisk, needOnDisks, defineNoFile, defineEarlyCutOffNoFile, getDiagnostics, mRunLspT, mRunLspTCallback, @@ -63,7 +62,6 @@ module Development.IDE.Core.Shake( Priority(..), updatePositionMapping, deleteValue, recordDirtyKeys, - OnDiskRule(..), WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -137,7 +135,7 @@ import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, - shakeOpenDatabase, + shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule @@ -168,6 +166,7 @@ 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 data Log @@ -457,7 +456,6 @@ newtype ShakeSession = ShakeSession data IdeState = IdeState {shakeDb :: ShakeDatabase ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) } @@ -600,11 +598,10 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer -- Take one VFS snapshot at the start vfs <- atomically . newTVar =<< vfsSnapshot lspEnv pure ShakeExtras{..} - (shakeDbM, shakeClose) <- - shakeOpenDatabase + shakeDb <- + shakeNewDatabase opts { shakeExtra = newShakeExtra shakeExtras } rules - shakeDb <- shakeDbM shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} @@ -652,7 +649,6 @@ shakeShut IdeState{..} = do -- request so we first abort that. for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb - shakeClose progressStop $ progress shakeExtras @@ -1026,6 +1022,10 @@ usesWithStale key files = do -- 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)) @@ -1044,28 +1044,28 @@ defineEarlyCutoff -> Rules () 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 recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + 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 diags = do + let diagnostics _ver diags = do traceDiagnostics diags 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 - let diagnostics diags = do + let diagnostics _ver diags = do traceDiagnostics diags mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ 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 diags = do + let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ 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 => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () @@ -1080,7 +1080,7 @@ defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnost defineEarlyCutoff' :: forall k v. IdeRule k v - => ([FileDiagnostic] -> Action ()) -- ^ update diagnostics + => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k @@ -1099,8 +1099,9 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do 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 state key (Just x) file + doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> @@ -1120,18 +1121,13 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- case eqT @k @GetModificationTime of - Just Refl -> pure res - Nothing - | file == emptyFilePath -> pure Nothing - | otherwise -> liftIO $ (currentValue . fst =<<) <$> atomicallyNamed "define - read 2" (getValues state GetModificationTime file) - + ver <- estimateFileVersionUnsafely state key res file (bs, res) <- case res of Nothing -> do pure (toShakeValue ShakeStale bs, staleV) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded modTime v) + 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 @@ -1144,117 +1140,74 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do 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 + => Values + -> k + -> Maybe v + -> NormalizedFilePath + -> Action (Maybe FileVersion) + estimateFileVersionUnsafely state _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 ~ ()) - => Recorder (WithPriority Log) - -> (k -> NormalizedFilePath -> OnDiskRule) - -> Rules () -defineOnDisk recorder 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 recorder 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 recorder 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 => Recorder (WithPriority Log) -> NormalizedFilePath + -> TextDocumentVersion -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics recorder fp k ShakeExtras{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. logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) - Just env -> LSP.runLspT env $ + 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 @@ -1276,26 +1229,33 @@ type STMDiagnosticStore = STM.Map NormalizedUri StoreItem 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 diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index f4c886e9b..2ca694781 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -71,9 +71,6 @@ instance Pretty Log where "Cancelled request" <+> viaShow requestId LogSession log -> pretty log -issueTrackerUrl :: T.Text -issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" - -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -184,20 +181,11 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur let handleServerException (Left e) = do log Error $ LogReactorThreadException e - sendErrorMessage 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 log Error $ LogReactorMessageActionException e - sendErrorMessage e checkCancelled _id act k = flip finally (clearReqId _id) $ diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3152ce9ce..43e9827c8 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -31,7 +31,7 @@ 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, @@ -336,7 +336,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re _mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log Debug (LogSetInitialDynFlagsException e) >> pure Nothing) + `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index c3339d04d..32c7d640a 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -1529,14 +1529,22 @@ mkRenameEdit contents range name = 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 diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index da0912861..c57dc0f52 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -21,37 +21,50 @@ module Development.IDE.Types.Logger , priorityToHsLoggerPriority , LoggingColumn(..) , cmapWithPrio + , withBacklog + , lspClientMessageRecorder + , lspClientLogRecorder , module PrettyPrinterModule + , renderStrict ) where -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Exception (IOException) -import Control.Monad (forM_, when, (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -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 Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) -import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, hSetEncoding, - openFile, stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import 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 @@ -95,7 +108,7 @@ data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallSta -- | 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). -data Recorder msg = Recorder +newtype Recorder msg = Recorder { logger_ :: forall m. (MonadIO m) => msg -> m () } logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () @@ -203,10 +216,10 @@ makeDefaultHandleRecorder columns minPriority lock handle = do priorityToHsLoggerPriority :: Priority -> HsLogger.Priority priorityToHsLoggerPriority = \case - Debug -> HsLogger.DEBUG - Info -> HsLogger.INFO - Warning -> HsLogger.WARNING - Error -> HsLogger.ERROR + 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 @@ -290,6 +303,60 @@ textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = d 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/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index bfd11413f..2c536026c 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -17,7 +17,7 @@ module Development.IDE.Types.Options , IdeGhcSession(..) , OptHaddockParse(..) , ProgressReportingStyle(..) - ,optShakeFiles) where + ) where import qualified Data.Text as T import Data.Typeable @@ -85,13 +85,6 @@ data IdeOptions = IdeOptions -- ^ 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 @@ defaultIdeOptions session = IdeOptions ,optExtensions = ["hs", "lhs"] ,optPkgLocationOpts = defaultIdePkgLocationOptions ,optShakeOptions = shakeOptions - {shakeThreads = 0 - ,shakeFiles = "/dev/null" - } ,optShakeProfiling = Nothing ,optOTMemoryProfiling = IdeOTMemoryProfiling False ,optReportProgress = IdeReportProgress False diff --git a/ghcide/test/data/hover/GotoHover.hs b/ghcide/test/data/hover/GotoHover.hs index ae261c6bd..e1802580e 100644 --- a/ghcide/test/data/hover/GotoHover.hs +++ b/ghcide/test/data/hover/GotoHover.hs @@ -61,3 +61,6 @@ aa2 = $(id [| True |]) hole :: Int hole = _ + +hole2 :: a -> Maybe a +hole2 = _ diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f82cc9509..73de4078d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1188,73 +1188,71 @@ renameActionTests = testGroup "rename actions" 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 @@ -4059,7 +4057,9 @@ findDefinitionAndHoverTests = let , 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" @@ -4111,6 +4111,7 @@ findDefinitionAndHoverTests = let 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] @@ -4165,6 +4166,11 @@ findDefinitionAndHoverTests = let , 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" + , if ghcVersion >= GHC92 then + -- Broken on GHC 9.2 and above due to printing of uniques + test no yes holeL65 [] "hole with variable" + else + 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)" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 2df0e33d3..23b67b1ee 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -77,7 +77,6 @@ library , hie-bios , hiedb , hls-plugin-api ^>=1.3 - , hslogger , optparse-applicative , optparse-simple , process @@ -182,6 +181,11 @@ flag selectionRange default: True manual: True +flag changeTypeSignature + description: Enable changeTypeSignature plugin + default: True + manual: True + -- formatters flag floskell @@ -299,6 +303,11 @@ common selectionRange build-depends: hls-selection-range-plugin ^>=1.0.0.0 cpp-options: -DselectionRange +common changeTypeSignature + if flag(changeTypeSignature) + build-depends: hls-change-type-signature-plugin ^>=1.0.0.0 + cpp-options: -DchangeTypeSignature + -- formatters common floskell @@ -334,6 +343,7 @@ executable haskell-language-server -- plugins , example-plugins , callHierarchy + , changeTypeSignature , class , haddockComments , eval @@ -399,7 +409,6 @@ executable haskell-language-server , hiedb , lens , regex-tdfa - , hslogger , optparse-applicative , hls-plugin-api , lens diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index c31c3dd75..0d813a430 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -104,3 +104,33 @@ library DataKinds KindSignatures TypeOperators + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: + ActionSpec + DatabaseSpec + Example + RulesSpec + Spec + + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts + build-depends: + , base + , containers + , directory + , extra + , filepath + , hls-graph + , hspec + , stm + , stm-containers + , tasty + , tasty-hspec + , tasty-hunit + , tasty-rerun + , text + build-tool-depends: hspec-discover:hspec-discover -any diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 9f70b9f61..ce0711aba 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -5,7 +5,7 @@ module Development.IDE.Graph( Key(..), actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration - ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra), + ShakeOptions(shakeAllowRedefineRules, shakeExtra), getShakeExtra, getShakeExtraRules, newShakeExtra, -- * Explicit parallelism parallel, diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 99f187928..53406bc3d 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -4,7 +4,7 @@ module Development.IDE.Graph.Database( ShakeDatabase, ShakeValue, - shakeOpenDatabase, + shakeNewDatabase, shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, @@ -23,14 +23,10 @@ import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types -data ShakeDatabase = ShakeDatabase !Int [Action ()] Database -- Placeholder to be the 'extra' if the user doesn't set it data NonExportedType = NonExportedType -shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ()) -shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ()) - shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase shakeNewDatabase opts rules = do let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts @@ -38,7 +34,7 @@ shakeNewDatabase opts rules = do db <- newDatabase extra theRules pure $ ShakeDatabase (length actions) actions db -shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) +shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a] shakeRunDatabase = shakeRunDatabaseForKeys Nothing -- | Returns the set of dirty keys annotated with their age (in # of builds) @@ -62,11 +58,10 @@ shakeRunDatabaseForKeys -- ^ Set of keys changed since last run. 'Nothing' means everything has changed -> ShakeDatabase -> [Action a] - -> IO ([a], [IO ()]) + -> IO [a] shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do incDatabase db keysChanged - as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 - return (as, []) + fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 2f6b1e38c..b9e9a1b08 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -11,6 +11,7 @@ module Development.IDE.Graph.Internal.Action , alwaysRerun , apply1 , apply +, applyWithoutDependency , parallel , reschedule , runActions @@ -115,15 +116,24 @@ apply1 k = head <$> apply [k] apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] apply ks = do db <- Action $ asks actionDatabase - (is, vs) <- liftIO $ build db ks + stack <- Action $ asks actionStack + (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps liftIO $ modifyIORef ref (ResultDeps is <>) pure vs +-- | Evaluate a list of keys without recording any dependencies. +applyWithoutDependency :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] +applyWithoutDependency ks = do + db <- Action $ asks actionDatabase + stack <- Action $ asks actionStack + (_, vs) <- liftIO $ build db stack ks + pure vs + runActions :: Database -> [Action a] -> IO [a] runActions db xs = do deps <- newIORef mempty - runReaderT (fromAction $ parallel xs) $ SAction db deps + runReaderT (fromAction $ parallel xs) $ SAction db deps emptyStack -- | Returns the set of dirty keys annotated with their age (in # of builds) getDirtySet :: Action [(Key, Int)] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index e83690e1c..824abd14c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -77,10 +77,11 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> -- | Unwrap and build a list of keys in parallel build :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) - => Database -> [key] -> IO ([Key], [value]) -build db keys = do + => Database -> Stack -> [key] -> IO ([Key], [value]) +-- build _ st k | traceShow ("build", st, k) False = undefined +build db stack keys = do (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< - builder db (map Key keys) + builder db stack (map Key keys) pure (ids, map (asV . resultValue) vs) where asV :: Value -> value @@ -90,8 +91,9 @@ build db keys = do -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. builder - :: Database -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)])) -builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do + :: Database -> Stack -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)])) +-- builder _ st kk | traceShow ("builder", st,kk) False = undefined +builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do -- Things that I need to force before my results are ready toForce <- liftIO $ newTVarIO [] current <- liftIO $ readTVarIO databaseStep @@ -103,11 +105,13 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do status <- SMap.lookup id databaseValues val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of Clean r -> pure r - Running _ force val _ -> do + Running _ force val _ + | memberStack id stack -> throw $ StackException stack + | otherwise -> do modifyTVar' toForce (Wait force :) pure val Dirty s -> do - let act = run (refresh db id s) + let act = run (refresh db stack id s) (force, val) = splitIO (join act) SMap.focus (updateStatus $ Running current force val s) id databaseValues modifyTVar' toForce (Spawn force:) @@ -127,32 +131,33 @@ builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself -refresh :: Database -> Key -> Maybe Result -> AIO (IO Result) -refresh db key result@(Just me@Result{resultDeps = ResultDeps deps}) = do - res <- builder db deps - case res of - Left res -> - if isDirty res - then asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result - else pure $ compute db key RunDependenciesSame result - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores - let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame - compute db key mode result - where - isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) - -refresh db key result = - asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result - +refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) +-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined +refresh db stack key result = case (addStack key stack, result) of + (Left e, _) -> throw e + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> do + res <- builder db stack deps + let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) + case res of + Left res -> + if isDirty res + then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result + else pure $ compute db stack key RunDependenciesSame result + Right iores -> asyncWithCleanUp $ liftIO $ do + res <- iores + let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame + compute db stack key mode result + (Right stack, _) -> + asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result -- | Compute a key. -compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result -compute db@Database{..} key mode result = do +compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result +-- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined +compute db@Database{..} stack key mode result = do let act = runRule databaseRules key (fmap resultData result) mode deps <- newIORef UnknownDeps (execution, RunResult{..}) <- - duration $ runReaderT (fromAction act) $ SAction db deps + duration $ runReaderT (fromAction act) $ SAction db deps stack built <- readTVarIO databaseStep deps <- readIORef deps let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result @@ -165,7 +170,7 @@ compute db@Database{..} key mode result = do deps | not(null deps) && runChanged /= ChangedNothing -> do - void $ forkIO $ + void $ updateReverseDeps key db (getResultDepsDefault [] previousDeps) (HSet.fromList deps) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs index df6b8b171..db8bd4e16 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs @@ -5,16 +5,13 @@ import Data.Dynamic import Development.IDE.Graph.Internal.Types data ShakeOptions = ShakeOptions { - -- | Has no effect, kept only for api compatibility with Shake - shakeThreads :: Int, - shakeFiles :: FilePath, shakeExtra :: Maybe Dynamic, shakeAllowRedefineRules :: Bool, shakeTimings :: Bool } shakeOptions :: ShakeOptions -shakeOptions = ShakeOptions 0 ".shake" Nothing False False +shakeOptions = ShakeOptions Nothing False False getShakeExtra :: Typeable a => Action (Maybe a) getShakeExtra = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index a22f0c61e..7470c0e33 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -21,7 +21,6 @@ import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@. --- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. type family RuleResult key -- = value action :: Action a -> Rules () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 0a1278f5d..5a37ade6a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -26,7 +26,7 @@ import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Dynamic import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet) +import Data.HashSet (HashSet, member) import Data.IORef import Data.Maybe import Data.Typeable @@ -36,6 +36,8 @@ import qualified ListT import StmContainers.Map (Map) import qualified StmContainers.Map as SMap import System.Time.Extra (Seconds) +import qualified Data.HashSet as Set +import Data.List (intercalate) unwrapDynamic :: forall a . Typeable a => Dynamic -> a @@ -66,7 +68,8 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a} data SAction = SAction { actionDatabase :: !Database, - actionDeps :: !(IORef ResultDeps) + actionDeps :: !(IORef ResultDeps), + actionStack :: !Stack } getDatabase :: Action Database @@ -75,6 +78,8 @@ getDatabase = Action $ asks actionDatabase --------------------------------------------------------------------- -- DATABASE +data ShakeDatabase = ShakeDatabase !Int [Action ()] Database + newtype Step = Step Int deriving newtype (Eq,Ord,Hashable) @@ -144,6 +149,7 @@ data Result = Result { } data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key] + deriving (Eq, Show) getResultDepsDefault :: [Key] -> ResultDeps -> [Key] getResultDepsDefault _ (ResultDeps ids) = ids @@ -200,6 +206,54 @@ data RunResult value = RunResult instance NFData value => NFData (RunResult value) where rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 +--------------------------------------------------------------------- +-- EXCEPTIONS + +data GraphException = forall e. Exception e => GraphException { + target :: String, -- ^ The key that was being built + stack :: [String], -- ^ The stack of keys that led to this exception + inner :: e -- ^ The underlying exception +} + deriving (Typeable, Exception) + +instance Show GraphException where + show GraphException{..} = unlines $ + ["GraphException: " ++ target] ++ + stack ++ + ["Inner exception: " ++ show inner] + +fromGraphException :: Typeable b => SomeException -> Maybe b +fromGraphException x = do + GraphException _ _ e <- fromException x + cast e + +--------------------------------------------------------------------- +-- CALL STACK + +data Stack = Stack [Key] !(HashSet Key) + +instance Show Stack where + show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk) + +newtype StackException = StackException Stack + deriving (Typeable, Show) + +instance Exception StackException where + fromException = fromGraphException + toException this@(StackException (Stack stack _)) = toException $ + GraphException (show$ last stack) (map show stack) this + +addStack :: Key -> Stack -> Either StackException Stack +addStack k (Stack ks is) + | k `member` is = Left $ StackException stack2 + | otherwise = Right stack2 + where stack2 = Stack (k:ks) (Set.insert k is) + +memberStack :: Key -> Stack -> Bool +memberStack k (Stack _ ks) = k `member` ks + +emptyStack :: Stack +emptyStack = Stack [] mempty --------------------------------------------------------------------- -- INSTANCES diff --git a/hls-graph/src/Development/IDE/Graph/Rule.hs b/hls-graph/src/Development/IDE/Graph/Rule.hs index 679d81adf..34444b8fe 100644 --- a/hls-graph/src/Development/IDE/Graph/Rule.hs +++ b/hls-graph/src/Development/IDE/Graph/Rule.hs @@ -7,7 +7,7 @@ module Development.IDE.Graph.Rule( RunMode(..), RunChanged(..), RunResult(..), -- * Calling builtin rules -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule. - apply, apply1, + apply, apply1, applyWithoutDependency ) where import Development.IDE.Graph.Internal.Action diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs new file mode 100644 index 000000000..952b6df24 --- /dev/null +++ b/hls-graph/test/ActionSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ActionSpec where + +import Control.Concurrent.STM +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Rule +import Example +import qualified StmContainers.Map as STM +import Test.Hspec +import System.Time.Extra (timeout) + +spec :: Spec +spec = do + describe "apply1" $ do + it "computes a rule with no dependencies" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleUnit + res <- shakeRunDatabase db $ + pure $ do + apply1 (Rule @()) + res `shouldBe` [()] + it "computes a rule with one dependency" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + res <- shakeRunDatabase db $ pure $ apply1 Rule + res `shouldBe` [True] + it "tracks direct dependencies" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + apply1 theKey + res `shouldBe` [True] + Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` ResultDeps [Key (Rule @())] + it "tracks reverse dependencies" $ do + db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do + ruleUnit + ruleBool + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + apply1 theKey + res `shouldBe` [True] + Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues + keyReverseDeps `shouldBe` [Key theKey] + it "rethrows exceptions" $ do + db <- shakeNewDatabase shakeOptions $ do + addRule $ \(Rule :: Rule ()) old mode -> error "boom" + let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + res `shouldThrow` anyErrorCall + describe "applyWithoutDependency" $ do + it "does not track dependencies" $ do + db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do + ruleUnit + addRule $ \Rule old mode -> do + [()] <- applyWithoutDependency [Rule] + return $ RunResult ChangedRecomputeDiff "" True + + let theKey = Rule @Bool + res <- shakeRunDatabase db $ + pure $ do + applyWithoutDependency [theKey] + res `shouldBe` [[True]] + Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` UnknownDeps diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs new file mode 100644 index 000000000..7ab812e61 --- /dev/null +++ b/hls-graph/test/DatabaseSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +module DatabaseSpec where + +import Control.Concurrent.STM +import Development.IDE.Graph (shakeOptions) +import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase) +import Development.IDE.Graph.Internal.Action (apply1) +import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Rule +import Example +import qualified StmContainers.Map as STM +import Test.Hspec +import System.Time.Extra (timeout) + +spec :: Spec +spec = do + describe "Evaluation" $ do + it "detects cycles" $ do + db <- shakeNewDatabase shakeOptions $ do + ruleBool + addRule $ \Rule old mode -> do + True <- apply1 (Rule @Bool) + return $ RunResult ChangedRecomputeDiff "" () + let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) + timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs new file mode 100644 index 000000000..3903cbe32 --- /dev/null +++ b/hls-graph/test/Example.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Example where + +import Development.IDE.Graph +import Development.IDE.Graph.Rule +import Development.IDE.Graph.Classes +import GHC.Generics +import Type.Reflection (typeRep) + +data Rule a = Rule + deriving (Eq, Generic, Hashable, NFData) + +instance Typeable a => Show (Rule a) where + show Rule = show $ typeRep @a + +type instance RuleResult (Rule a) = a + +ruleUnit :: Rules () +ruleUnit = addRule $ \(Rule :: Rule ()) old mode -> do + return $ RunResult ChangedRecomputeDiff "" () + +-- | Depends on Rule @() +ruleBool :: Rules () +ruleBool = addRule $ \Rule old mode -> do + () <- apply1 Rule + return $ RunResult ChangedRecomputeDiff "" True diff --git a/hls-graph/test/Main.hs b/hls-graph/test/Main.hs new file mode 100644 index 000000000..452f6208a --- /dev/null +++ b/hls-graph/test/Main.hs @@ -0,0 +1,7 @@ +import qualified Spec +import Test.Tasty +import Test.Tasty.Hspec +import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun) + +main :: IO () +main = testSpecs Spec.spec >>= defaultMainWithRerun . testGroup "tactics" diff --git a/hls-graph/test/RulesSpec.hs b/hls-graph/test/RulesSpec.hs new file mode 100644 index 000000000..cdea145aa --- /dev/null +++ b/hls-graph/test/RulesSpec.hs @@ -0,0 +1,8 @@ +module RulesSpec where + +import Test.Hspec + +spec :: Spec +spec = do + describe "" $ do + pure () diff --git a/hls-graph/test/Spec.hs b/hls-graph/test/Spec.hs new file mode 100644 index 000000000..5416ef6a8 --- /dev/null +++ b/hls-graph/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 4017a4b2c..9a9c4bede 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -26,7 +26,6 @@ source-repository head library exposed-modules: - Ide.Logger Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Properties @@ -47,7 +46,6 @@ library , ghc , hashable , hls-graph ^>= 1.6 - , hslogger , lens , lens-aeson , lsp >=1.4.0.0 && < 1.6 diff --git a/hls-plugin-api/src/Ide/Logger.hs b/hls-plugin-api/src/Ide/Logger.hs deleted file mode 100644 index 1f960d868..000000000 --- a/hls-plugin-api/src/Ide/Logger.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- | Provides an implementation of the ghcide @Logger@ which uses - @System.Log.Logger@ under the hood. --} -module Ide.Logger - ( - logm - , debugm - , warningm - , errorm - ) where - -import Control.Monad.IO.Class -import System.Log.Logger - --- --------------------------------------------------------------------- - -logm :: MonadIO m => String -> m () -logm s = liftIO $ infoM "hls" s - -debugm :: MonadIO m => String -> m () -debugm s = liftIO $ debugM "hls" s - -warningm :: MonadIO m => String -> m () -warningm s = liftIO $ warningM "hls" s - -errorm :: MonadIO m => String -> m () -errorm s = liftIO $ errorM "hls" s - --- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 5df855f35..8dc33fbdb 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -27,6 +27,7 @@ module Ide.PluginUtils subRange, positionInRange, usePropertyLsp, + getNormalizedFilePath, response, handleMaybe, handleMaybeM, @@ -34,6 +35,7 @@ module Ide.PluginUtils where +import Control.Lens ((^.)) import Control.Monad.Extra (maybeM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) @@ -54,6 +56,7 @@ import Language.LSP.Types hiding SemanticTokensEdit (_start)) import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities +import Language.LSP.Types.Lens (uri) -- --------------------------------------------------------------------- @@ -243,6 +246,15 @@ allLspCmdIds pid commands = concatMap go commands -- --------------------------------------------------------------------- +getNormalizedFilePath :: Monad m => PluginId -> TextDocumentIdentifier -> ExceptT String m NormalizedFilePath +getNormalizedFilePath (PluginId plId) docId = handleMaybe errMsg + $ uriToNormalizedFilePath + $ toNormalizedUri uri' + where + errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri' <> " to NormalizedFilePath" + uri' = docId ^. uri + +-- --------------------------------------------------------------------- handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 5b0cc9073..227bec3e0 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -53,7 +53,6 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Main as IDEMain @@ -213,11 +212,10 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre ++ [Test.blockCommandDescriptor "block-command", Test.plugin] ++ plugins ideOptions = \config ghcSession -> - let defIdeOptions@IdeOptions{ optShakeOptions } = argsIdeOptions config ghcSession + let defIdeOptions = argsIdeOptions config ghcSession in defIdeOptions { optTesting = IdeTesting True , optCheckProject = pure False - , optShakeOptions = optShakeOptions{ shakeThreads = 2 } } server <- diff --git a/plugins/hls-alternate-number-format-plugin/README.md b/plugins/hls-alternate-number-format-plugin/README.md index 2bff086df..adad74ff6 100644 --- a/plugins/hls-alternate-number-format-plugin/README.md +++ b/plugins/hls-alternate-number-format-plugin/README.md @@ -44,3 +44,7 @@ To generate suggestions, the plugin leverages the `Numeric` package which provid ### 1.0.1.1 - Buildable with GHC 9.2 + +### 1.0.2.0 +- Test Suite upgraded for 9.2 semantics (GHC2021) +- Fix SYB parsing with GHC 9.2 diff --git a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal index ee07e3c3c..a9e87c021 100644 --- a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal +++ b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-alternate-number-format-plugin -version: 1.0.1.1 +version: 1.0.2.0 synopsis: Provide Alternate Number Formats plugin for Haskell Language Server description: Please see the README on GitHub at @@ -21,6 +21,7 @@ library exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion other-modules: Ide.Plugin.Literals hs-source-dirs: src + ghc-options: -Wall build-depends: aeson , base >=4.12 && < 5 diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e1c4d064d..8d55fe696 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -22,8 +22,7 @@ import Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.Conversion (FormatType, alternateFormat, toFormatTypes) -import Ide.Plugin.Literals (Literal (..), collectLiterals, - getSrcSpan, getSrcText) +import Ide.Plugin.Literals import Ide.PluginUtils (handleMaybe, handleMaybeM, response) import Ide.Types @@ -126,7 +125,6 @@ requestLiterals state = handleMaybeM "Error: Could not Collect Literals" . runAction "AlternateNumberFormat.CollectLiterals" state . use CollectLiterals - logIO :: (MonadIO m, Show a) => IdeState -> a -> m () logIO state = liftIO . Logger.logDebug (ideLogger state) . T.pack . show diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs index 2cc213fb0..d66d03f67 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Literals ( collectLiterals , Literal(..) @@ -13,7 +15,6 @@ import Data.Maybe (maybeToList) import Data.Text (Text) import qualified Data.Text as T import Development.IDE.GHC.Compat hiding (getSrcSpan) -import Development.IDE.GHC.Util (unsafePrintSDoc) import Development.IDE.Graph.Classes (NFData (rnf)) import qualified GHC.Generics as GHC import Generics.SYB (Data, Typeable, everything, @@ -48,25 +49,36 @@ getSrcSpan = \case collectLiterals :: (Data ast, Typeable ast) => ast -> [Literal] collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern)) + -- | Translate from HsLit and HsOverLit Types to our Literal Type -getLiteral :: GenLocated SrcSpan (HsExpr GhcPs) -> Maybe Literal -getLiteral (L (UnhelpfulSpan _) _) = Nothing -getLiteral (L (RealSrcSpan sSpan _ ) expr) = case expr of +getLiteral :: (LHsExpr GhcPs) -> Maybe Literal +getLiteral (L (locA -> (RealSrcSpan sSpan _)) expr) = case expr of HsLit _ lit -> fromLit lit sSpan HsOverLit _ overLit -> fromOverLit overLit sSpan _ -> Nothing +getLiteral _ = Nothing + + + +-- GHC 8.8 typedefs LPat = Pat +#if __GLASGOW_HASKELL__ == 808 +type LocPat a = GenLocated SrcSpan (Pat a) +#else +type LocPat a = LPat a +#endif -- | Destructure Patterns to unwrap any Literals -getPattern :: GenLocated SrcSpan (Pat GhcPs) -> Maybe Literal -getPattern (L (UnhelpfulSpan _) _) = Nothing -getPattern (L (RealSrcSpan patSpan _) pat) = case pat of +getPattern :: (LocPat GhcPs) -> Maybe Literal +getPattern (L (locA -> (RealSrcSpan patSpan _)) pat) = case pat of LitPat _ lit -> case lit of HsInt _ val -> fromIntegralLit patSpan val HsRat _ val _ -> fromFractionalLit patSpan val _ -> Nothing + -- a located HsOverLit is (GenLocated SrcSpan HsOverLit) NOT (GenLocated SrcSpanAnn' a HsOverLit) NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan _ -> Nothing +getPattern _ = Nothing fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal fromLit lit sSpan = case lit of @@ -91,30 +103,3 @@ fromSourceText :: SourceText -> Maybe Text fromSourceText = \case SourceText s -> Just $ T.pack s NoSourceText -> Nothing - --- mostly for debugging purposes -literalToString :: HsLit p -> String -literalToString = \case - HsChar _ c -> "Char: " <> show c - HsCharPrim _ c -> "CharPrim: " <> show c - HsString _ fs -> "String: " <> show fs - HsStringPrim _ bs -> "StringPrim: " <> show bs - HsInt _ il -> "Int: " <> show il - HsIntPrim _ n -> "IntPrim: " <> show n - HsWordPrim _ n -> "WordPrim: " <> show n - HsInt64Prim _ n -> "Int64Prim: " <> show n - HsWord64Prim _ n -> "Word64Prim: " <> show n - HsInteger _ n ty -> "Integer: " <> show n <> " Type: " <> tyToLiteral ty - HsRat _ fl ty -> "Rat: " <> show fl <> " Type: " <> tyToLiteral ty - HsFloatPrim _ fl -> "FloatPrim: " <> show fl - HsDoublePrim _ fl -> "DoublePrim: " <> show fl - _ -> "XHsLit" - where - tyToLiteral :: Type -> String - tyToLiteral = unsafePrintSDoc . ppr - -overLitToString :: OverLitVal -> String -overLitToString = \case - HsIntegral int -> case int of { IL{il_value} -> "IntegralOverLit: " <> show il_value} - HsFractional frac -> case frac of { fl -> "RationalOverLit: " <> show (rationalFromFractionalLit fl)} - HsIsString _ str -> "HIsString: " <> show str diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index f37ec9e4f..abcf5e146 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -23,7 +23,6 @@ main = defaultTestRunner test alternateNumberFormatPlugin :: PluginDescriptor IdeState alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty "alternateNumberFormat" - -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time. -- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something -- to do with how @@ -37,36 +36,18 @@ test = testGroup "alternateNumberFormat" [ , codeActionFloatHex "TFracDtoHF" 4 13 , codeActionDecimal "TIntHtoD" 3 13 , codeActionDecimal "TFracHFtoD" 4 13 - , codeActionProperties "TFindLiteralIntPattern" [(3, 25), (4,25)] $ \actions -> do + , codeActionProperties "TFindLiteralIntPattern" [(4, 25), (5,25)] $ \actions -> do liftIO $ length actions @?= 4 - , codeActionProperties "TFindLiteralIntCase" [(3, 29)] $ \actions -> do + , codeActionProperties "TFindLiteralIntCase" [(4, 29)] $ \actions -> do liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralIntCase2" [(4, 21)] $ \actions -> do + , codeActionProperties "TFindLiteralIntCase2" [(5, 21)] $ \actions -> do liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralDoReturn" [(5, 10)] $ \actions -> do + , codeActionProperties "TFindLiteralDoReturn" [(6, 10)] $ \actions -> do liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralDoLet" [(5, 13), (6, 13)] $ \actions -> do + , codeActionProperties "TFindLiteralDoLet" [(6, 13), (7, 13)] $ \actions -> do liftIO $ length actions @?= 4 - , codeActionProperties "TFindLiteralList" [(3, 28)] $ \actions -> do + , codeActionProperties "TFindLiteralList" [(4, 28)] $ \actions -> do liftIO $ length actions @?= 2 - , codeActionProperties "TExpectNoBinaryFormat" [(3, 12)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `doesNotContain` binaryRegex @? "Contains binary codeAction" - , codeActionProperties "TExpectBinaryFormat" [(4, 10)] $ \actions -> do - liftIO $ length actions @?= 3 - liftIO $ actions `contains` binaryRegex @? "Does not contain binary codeAction" - , codeActionProperties "TExpectNoHexFloatFormat" [(3, 14)] $ \actions -> do - liftIO $ length actions @?= 1 - liftIO $ actions `doesNotContain` hexFloatRegex @? "Contains hex float codeAction" - , codeActionProperties "TExpectHexFloatFormat" [(4, 12)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `contains` hexFloatRegex @? "Does not contain hex float codeAction" - , codeActionProperties "TExpectNoNumDecimalFormat" [(3, 16)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `doesNotContain` numDecimalRegex @? "Contains numDecimal codeAction" - , codeActionProperties "TExpectNumDecimalFormat" [(4, 14)] $ \actions -> do - liftIO $ length actions @?= 5 - liftIO $ actions `contains` numDecimalRegex @? "Contains numDecimal codeAction" , conversions ] diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectBinaryFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectBinaryFormat.hs deleted file mode 100644 index 8e8578088..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectBinaryFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -module TExpectBinaryFormat where - -binary = 459 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectHexFloatFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectHexFloatFormat.hs deleted file mode 100644 index ea008c51e..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectHexFloatFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE HexFloatLiterals #-} -module TExpectHexFloatFormat where - -hexFloat = 459.123 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoBinaryFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoBinaryFormat.hs deleted file mode 100644 index a590fd35a..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoBinaryFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoBinaryFormat where - -noBinary = 459 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoHexFloatFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoHexFloatFormat.hs deleted file mode 100644 index 2e3487b51..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoHexFloatFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoHexFloatFormat where - -noHexFloat = 459.123 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoNumDecimalFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoNumDecimalFormat.hs deleted file mode 100644 index b4d0d3580..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoNumDecimalFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoNumDecimalFormat where - -noNumDecimal = 499999 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNumDecimalFormat.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNumDecimalFormat.hs deleted file mode 100644 index e5cbb72ec..000000000 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNumDecimalFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE NumDecimals #-} -module TExpectNumDecimalFormat where - -numDecimal = 499999 diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs index bb2b4a296..074a06b96 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralDoLet where doLet :: IO () diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs index 81e2d4f74..1954a0934 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralDoReturn where doReturn :: IO Integer diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs index bc5e83459..8b8d82ce8 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntCase where caseExpression x = case x + 34 of diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs index 29af4c1cd..e267ab69d 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntCase where caseExpression x = case x of diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs index cc01a972e..46c0ea23b 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntPattern where patternMatchingFunction 1 = "one" diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs index e28b5bd0c..42d5f8be9 100644 --- a/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralList where listTest = [reverse $ show 57] diff --git a/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs b/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs new file mode 100644 index 000000000..b9624b641 --- /dev/null +++ b/plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NumDecimals #-} +module TIntDtoND where + +convertMe :: Integer +convertMe = 125.345e3 diff --git a/plugins/hls-change-type-signature-plugin/LICENSE b/plugins/hls-change-type-signature-plugin/LICENSE new file mode 100644 index 000000000..261eeb9e9 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-change-type-signature-plugin/README.md b/plugins/hls-change-type-signature-plugin/README.md new file mode 100644 index 000000000..f0766e7f8 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/README.md @@ -0,0 +1,21 @@ +# Change Type Signature Plugin + +The change type signature plugin provides a code action to change a user's current type signature to it's actual type signature. +The plugin does not work in all error scenarios. Currently, the plugin uses GHC diagnostic messages to recover the actual type of a function. +If the plugin receives enough information it can correctly change the signature. + +## Demo + +![Change Type Signature One](change1.gif) + +![Change Type Signature Two](change2.gif) + + +## Changelog +### 1.0.0.0 +- First Release + +### 1.0.1.0 +- Fix 9.2 Test failures (`waitForProgressDone`) +- Add extra test scenarios for error message diffs in 9.2 +- Remove regex parsing for simple `Text` manipulation diff --git a/plugins/hls-change-type-signature-plugin/change1.gif b/plugins/hls-change-type-signature-plugin/change1.gif new file mode 100644 index 000000000..de0605154 Binary files /dev/null and b/plugins/hls-change-type-signature-plugin/change1.gif differ diff --git a/plugins/hls-change-type-signature-plugin/change2.gif b/plugins/hls-change-type-signature-plugin/change2.gif new file mode 100644 index 000000000..b7d007524 Binary files /dev/null and b/plugins/hls-change-type-signature-plugin/change2.gif differ diff --git a/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal new file mode 100644 index 000000000..25214d8bd --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.4 +name: hls-change-type-signature-plugin +version: 1.0.1.0 +synopsis: Change a declarations type signature with a Code Action +description: + Please see the README on GitHub at + +license: Apache-2.0 +license-file: LICENSE +author: Nick Suchecki +maintainer: nicksuchecki@gmail.com +category: Development +build-type: Simple +extra-source-files: + LICENSE + README.md + test/testdata/*.hs + test/testdata/*.yaml + +library + exposed-modules: Ide.Plugin.ChangeTypeSignature + hs-source-dirs: src + build-depends: + , base >=4.12 && < 5 + , ghcide ^>=1.6 + , hls-plugin-api ^>=1.3 + , lsp-types + , regex-tdfa + , syb + , text + , transformers + , unordered-containers + + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: + ConstraintKinds + DataKinds + ExplicitNamespaces + FlexibleContexts + NamedFieldPuns + OverloadedStrings + RecordWildCards + TypeOperators + + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall + build-depends: + , base >=4.12 && < 5 + , filepath + , hls-change-type-signature-plugin + , hls-test-utils ^>=1.2 + , lsp + , QuickCheck + , regex-tdfa + , text + default-extensions: + NamedFieldPuns + OverloadedStrings + TypeOperators + ViewPatterns diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs new file mode 100644 index 000000000..7de639c13 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +-- | An HLS plugin to provide code actions to change type signatures +module Ide.Plugin.ChangeTypeSignature (descriptor + -- * For Unit Tests + , errorMessageRegexes + ) where + +import Control.Monad (guard) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Foldable (asum) +import qualified Data.HashMap.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE (realSrcSpanToRange) +import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) +import Development.IDE.Core.Service (IdeState, runAction) +import Development.IDE.Core.Shake (use) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util (prettyPrint) +import Generics.SYB (extQ, something) +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, response) +import Ide.Types (PluginDescriptor (..), + PluginId, PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Types +import Text.Regex.TDFA ((=~)) + +descriptor :: PluginId -> PluginDescriptor IdeState +descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler } + +codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionHandler ideState plId CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = response $ do + nfp <- getNormalizedFilePath plId (TextDocumentIdentifier uri) + decls <- getDecls ideState nfp + let actions = mapMaybe (generateAction uri decls) diags + pure $ List actions + +getDecls :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] +getDecls state = handleMaybeM "Error: Could not get Parsed Module" + . liftIO + . fmap (fmap (hsmodDecls . unLoc . pm_parsed_source)) + . runAction "changeSignature.GetParsedModule" state + . use GetParsedModule + +-- | Text representing a Declaration's Name +type DeclName = Text +-- | The signature provided by GHC Error Message (Expected type) +type ExpectedSig = Text +-- | The signature provided by GHC Error Message (Actual type) +type ActualSig = Text + +-- | DataType that encodes the necessary information for changing a type signature +data ChangeSignature = ChangeSignature { + -- | The expected type based on Signature + expectedType :: ExpectedSig + -- | the Actual Type based on definition + , actualType :: ActualSig + -- | the declaration name to be updated + , declName :: DeclName + -- | the location of the declaration signature + , declSrcSpan :: RealSrcSpan + -- | the diagnostic to solve + , diagnostic :: Diagnostic + } + +-- | Constraint needed to trackdown OccNames in signatures +type SigName = (HasOccName (IdP GhcPs)) + +-- | Create a CodeAction from a Diagnostic +generateAction :: SigName => Uri -> [LHsDecl GhcPs] -> Diagnostic -> Maybe (Command |? CodeAction) +generateAction uri decls diag = changeSigToCodeAction uri <$> diagnosticToChangeSig decls diag + +-- | Convert a diagnostic into a ChangeSignature and add the proper SrcSpan +diagnosticToChangeSig :: SigName => [LHsDecl GhcPs] -> Diagnostic -> Maybe ChangeSignature +diagnosticToChangeSig decls diagnostic = do + -- regex match on the GHC Error Message + (expectedType, actualType, declName) <- matchingDiagnostic diagnostic + -- Find the definition and it's location + declSrcSpan <- findSigLocOfStringDecl decls expectedType (T.unpack declName) + pure $ ChangeSignature{..} + + +-- | If a diagnostic has the proper message create a ChangeSignature from it +matchingDiagnostic :: Diagnostic -> Maybe (ExpectedSig, ActualSig, DeclName) +matchingDiagnostic Diagnostic{_message} = asum $ map (unwrapMatch . (=~) _message) errorMessageRegexes + where + unwrapMatch :: (Text, Text, Text, [Text]) -> Maybe (ExpectedSig, ActualSig, DeclName) + -- due to using (.|\n) in regex we have to drop the erroneous, but necessary ("." doesn't match newlines), match + unwrapMatch (_, _, _, [expect, actual, _, name]) = Just (expect, actual, name) + unwrapMatch _ = Nothing + +-- | List of regexes that match various Error Messages +errorMessageRegexes :: [Text] +errorMessageRegexes = [ -- be sure to add new Error Messages Regexes at the bottom to not fail any existing tests + "Expected type: (.+)\n +Actual type: (.+)\n(.|\n)+In an equation for ‘(.+)’" + , "Couldn't match expected type ‘(.+)’ with actual type ‘(.+)’\n(.|\n)+In an equation for ‘(.+)’" + -- GHC >9.2 version of the first error regex + , "Expected: (.+)\n +Actual: (.+)\n(.|\n)+In an equation for ‘(.+)’" + ] + +-- | Given a String with the name of a declaration, GHC's "Expected Type", find the declaration that matches +-- both the name given and the Expected Type, and return the type signature location +findSigLocOfStringDecl :: SigName => [LHsDecl GhcPs] -> ExpectedSig -> String -> Maybe RealSrcSpan +findSigLocOfStringDecl decls expectedType declName = something (const Nothing `extQ` findSig `extQ` findLocalSig) decls + where + -- search for Top Level Signatures + findSig :: LHsDecl GhcPs -> Maybe RealSrcSpan + findSig = \case + L (locA -> (RealSrcSpan rss _)) (SigD _ sig) -> case sig of + ts@(TypeSig _ idsSig _) -> isMatch ts idsSig >> pure rss + _ -> Nothing + _ -> Nothing + + -- search for Local Signatures + findLocalSig :: LSig GhcPs -> Maybe RealSrcSpan + findLocalSig = \case + (L (locA -> (RealSrcSpan rss _)) ts@(TypeSig _ idsSig _)) -> isMatch ts idsSig >> pure rss + _ -> Nothing + + -- Does the declName match? and does the expected signature match? + isMatch ts idsSig = do + ghcSig <- sigToText ts + guard (any compareId idsSig && expectedType == ghcSig) + + -- Given an IdP check to see if it matches the declName + compareId (L _ id') = declName == occNameString (occName id') + + +-- | Pretty Print the Type Signature (to validate GHC Error Message) +sigToText :: Sig GhcPs -> Maybe Text +sigToText = \case + ts@TypeSig {} -> Just $ stripSignature $ T.pack $ prettyPrint ts + _ -> Nothing + +stripSignature :: Text -> Text +-- for whatever reason incoming signatures MAY have new lines after "::" or "=>" +stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig + -- remove constraints + then T.strip $ snd $ T.breakOnEnd " => " sig + else T.strip $ snd $ T.breakOnEnd " :: " sig + +changeSigToCodeAction :: Uri -> ChangeSignature -> Command |? CodeAction +changeSigToCodeAction uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType + , _kind = Just (CodeActionUnknown "quickfix.changeSignature") + , _diagnostics = Just $ List [diagnostic] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType) + , _command = Nothing + , _xdata = Nothing + } + +mkChangeSigTitle :: Text -> Text -> Text +mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> "’ to: " <> actualType + +mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit +mkChangeSigEdit uri ss replacement = + let txtEdit = TextEdit (realSrcSpanToRange ss) replacement + changes = Just $ Map.singleton uri (List [txtEdit]) + in WorkspaceEdit changes Nothing Nothing + +mkNewSignature :: Text -> Text -> Text +mkNewSignature declName actualType = declName <> " :: " <> actualType diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs new file mode 100644 index 000000000..d3f3b72a5 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -0,0 +1,132 @@ +module Main where + +import Control.Monad (void) +import Data.Either (rights) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Ide.Plugin.ChangeTypeSignature (errorMessageRegexes) +import qualified Ide.Plugin.ChangeTypeSignature as ChangeTypeSignature +import System.FilePath ((<.>), ()) +import Test.Hls (CodeAction (..), Command, + GhcVersion (GHC92), IdeState, + PluginDescriptor, + Position (Position), + Range (Range), Session, + TestName, TestTree, + TextDocumentIdentifier, + assertFailure, + defaultTestRunner, + executeCodeAction, + getCodeActions, + goldenWithHaskellDoc, + knownBrokenForGhcVersions, + liftIO, openDoc, + runSessionWithServer, testCase, + testGroup, toEither, type (|?), + waitForAllProgressDone, + waitForDiagnostics, (@?=)) +import Text.Regex.TDFA ((=~)) + +main :: IO () +main = defaultTestRunner test + +changeTypeSignaturePlugin :: PluginDescriptor IdeState +changeTypeSignaturePlugin = ChangeTypeSignature.descriptor "changeTypeSignature" + +test :: TestTree +test = testGroup "changeTypeSignature" [ + testRegexes + , codeActionTest "TExpectedActual" 4 11 + , knownBrokenForGhcVersions [GHC92] "Error Message in 9.2 does not provide enough info" $ codeActionTest "TRigidType" 4 14 + , codeActionTest "TLocalBinding" 7 22 + , codeActionTest "TLocalBindingShadow1" 11 8 + , codeActionTest "TLocalBindingShadow2" 7 22 + , codeActionProperties "TErrorGivenPartialSignature" [(4, 13)] $ \actions -> liftIO $ length actions @?= 0 + ] + +testRegexes :: TestTree +testRegexes = testGroup "Regex Testing" [ + testRegexOne + , testRegexTwo + , testRegex921One + ] + +testRegexOne :: TestTree +testRegexOne = testGroup "Regex One" [ + regexTest "error1.txt" regex True + , regexTest "error2.txt" regex True + , regexTest "error3.txt" regex False + , regexTest "error4.txt" regex True + , regexTest "error5.txt" regex True + ] + where + regex = errorMessageRegexes !! 0 + +testRegexTwo :: TestTree +testRegexTwo = testGroup "Regex Two" [ + regexTest "error1.txt" regex False + , regexTest "error2.txt" regex False + , regexTest "error3.txt" regex True + , regexTest "error4.txt" regex False + , regexTest "error5.txt" regex False + ] + where + regex = errorMessageRegexes !! 1 + +-- test ghc-9.2.1 error message regex +testRegex921One :: TestTree +testRegex921One = testGroup "Regex One" [ + regexTest "ghc921-error1.txt" regex True + , regexTest "ghc921-error2.txt" regex True + , regexTest "ghc921-error3.txt" regex True + ] + where + regex = errorMessageRegexes !! 2 + +testDataDir :: FilePath +testDataDir = "test" "testdata" + +goldenChangeSignature :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenChangeSignature fp = goldenWithHaskellDoc changeTypeSignaturePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" + +codeActionTest :: FilePath -> Int -> Int -> TestTree +codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do + void $ waitForDiagnostics -- code actions are triggered from Diagnostics + void $ waitForAllProgressDone -- apparently some tests need this to get the CodeAction to show up + actions <- getCodeActions doc (pointRange line col) + foundActions <- findChangeTypeActions actions + liftIO $ length foundActions @?= 1 + executeCodeAction (head foundActions) + +codeActionProperties :: TestName -> [(Int, Int)] -> ([CodeAction] -> Session ()) -> TestTree +codeActionProperties fp locs assertions = testCase fp $ do + runSessionWithServer changeTypeSignaturePlugin testDataDir $ do + openDoc (fp <.> ".hs") "haskell" >>= codeActionsFromLocs >>= findChangeTypeActions >>= assertions + where + codeActionsFromLocs doc = concat <$> mapM (getCodeActions doc . uncurry pointRange) locs + +findChangeTypeActions :: [Command |? CodeAction] -> Session [CodeAction] +findChangeTypeActions = pure . filter isChangeTypeAction . rights . map toEither + where + isChangeTypeAction CodeAction{_kind} = case _kind of + Nothing -> False + Just kind -> case kind of + "quickfix.changeSignature" -> True + _ -> False + + +regexTest :: FilePath -> Text -> Bool -> TestTree +regexTest fp regex shouldPass = testCase fp $ do + msg <- TIO.readFile (testDataDir fp) + case (msg =~ regex :: (Text, Text, Text, [Text]), shouldPass) of + ((_, _, _, [_, _, _, _]), True) -> pure () + ((_, _, _, [_, _, _, _]), False) -> assertFailure $ "Unexpected match: " <> fp <> " with " <> T.unpack regex + (_, True) -> assertFailure $ "Failed to match: " <> fp <> " with " <> T.unpack regex + (_, False) -> pure () + +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs new file mode 100644 index 000000000..caa595242 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs @@ -0,0 +1,4 @@ +module ErrorGivenPartialSignature where + +partial :: Int -> Int +partial x = init x diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs new file mode 100644 index 000000000..1d331c00b --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: [Int] -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs new file mode 100644 index 000000000..2a7629c39 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs @@ -0,0 +1,6 @@ +module TExpectedActual where + +fullSig :: Int -> Int +fullSig = go + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs new file mode 100644 index 000000000..dcff692d2 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs @@ -0,0 +1,8 @@ +module TLocalBinding where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + test = forM + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs new file mode 100644 index 000000000..388cf26dd --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs @@ -0,0 +1,8 @@ +module TLocalBinding where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = forM + in x + 1 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs new file mode 100644 index 000000000..5e7a1ce2e --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow1 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: [Double] -> (Double -> m0 b0) -> m0 [b0] +test = forM diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs new file mode 100644 index 000000000..8d7511df4 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow1 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = (+2) + in test x + +test :: [Double] -> Double +test = forM diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs new file mode 100644 index 000000000..8dcb28794 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow2 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + test = forM + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs new file mode 100644 index 000000000..6db8dbbfd --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs @@ -0,0 +1,11 @@ +module TLocalBindingShadow2 where + +import Control.Monad (forM) + +local :: Int -> Int +local x = let test :: Int -> Int + test = forM + in test x + +test :: String -> String +test = reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs new file mode 100644 index 000000000..015811212 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: [[Int]] -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs new file mode 100644 index 000000000..d5d7fa4b1 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs @@ -0,0 +1,6 @@ +module TRigidType where + +test :: a -> Int +test = go . head . reverse + where + go = head . reverse diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt new file mode 100644 index 000000000..37f0aa4a8 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error1.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘Int’ + with ‘Data.HashSet.Internal.HashSet Int’ + Expected type: Int -> Int + Actual type: Data.HashSet.Internal.HashSet Int -> Int + • In the expression: head . toList + In an equation for ‘test’: test = head . toList diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt new file mode 100644 index 000000000..497f8350a --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error2.txt @@ -0,0 +1,6 @@ + • Couldn't match type ‘b0 -> t0 a0 -> b0’ with ‘Int’ + Expected type: Int -> Int + Actual type: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 + • Probable cause: ‘foldl’ is applied to too few arguments + In the expression: foldl + In an equation for ‘test’: test = foldl diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt new file mode 100644 index 000000000..0cbddad7c --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error3.txt @@ -0,0 +1,10 @@ + • Couldn't match expected type ‘Int’ with actual type ‘[Int]’ + • In the expression: map (+ x) [1, 2, 3] + In an equation for ‘test’: + test x + = map (+ x) [1, 2, 3] + where + go = head . reverse + | +152 | test x = map (+ x) [1,2,3] + | ^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt new file mode 100644 index 000000000..323cf7d4d --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error4.txt @@ -0,0 +1,19 @@ + • Couldn't match type ‘a’ with ‘[[Int]]’ + ‘a’ is a rigid type variable bound by + the type signature for: + test :: forall a. Ord a => a -> Int + at src/Ide/Plugin/ChangeTypeSignature.hs:154:1-25 + Expected type: a -> Int + Actual type: [[Int]] -> Int + • In the expression: go . head . reverse + In an equation for ‘test’: + test + = go . head . reverse + where + go = head . reverse + • Relevant bindings include + test :: a -> Int + (bound at src/Ide/Plugin/ChangeTypeSignature.hs:155:1) + | +155 | test = go . head . reverse + | ^^^^^^^^^^^^^^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt new file mode 100644 index 000000000..a7a5d9a20 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/error5.txt @@ -0,0 +1,15 @@ + • Couldn't match type ‘(a0 -> m0 b0) -> m0 (t0 b0)’ with ‘Int’ + Expected type: Int -> Int + Actual type: t0 a0 -> (a0 -> m0 b0) -> m0 (t0 b0) + • Probable cause: ‘forM’ is applied to too few arguments + In the expression: forM + In an equation for ‘test’: test = forM + In an equation for ‘implicit’: + implicit + = return OpTEmpty + where + test :: Int -> Int + test = forM + | +82 | test = forM + | ^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt new file mode 100644 index 000000000..3ade6af3d --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘Data.Set.Internal.Set Int’ with ‘Int’ + Expected: Int -> [Int] + Actual: Data.Set.Internal.Set Int -> [Int] + • In the second argument of ‘(.)’, namely ‘toList’ + In the expression: head . toList + In an equation for ‘test’: test = head . toList + | +83 | test = head . toList + | ^^^^^^ diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt new file mode 100644 index 000000000..f76fb5018 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘b0 -> a0 -> b0’ with ‘Int’ + Expected: Int -> Int + Actual: (b0 -> a0 -> b0) -> b0 -> t0 a0 -> b0 + • Probable cause: ‘foldl’ is applied to too few arguments + In the expression: foldl + In an equation for ‘test’: test = foldl + | +83 | test = foldl + | diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt new file mode 100644 index 000000000..5b5adc1e8 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt @@ -0,0 +1,9 @@ + • Couldn't match type ‘[Int]’ with ‘Int’ + Expected: Int -> [Int] + Actual: [Int] -> [Int] + • In the second argument of ‘(.)’, namely ‘reverse’ + In the expression: head . reverse + In an equation for ‘test’: test = head . reverse + | +84 | test = head . reverse + | diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml new file mode 100644 index 000000000..8af53b683 --- /dev/null +++ b/plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml @@ -0,0 +1,12 @@ +cradle: + direct: + arguments: + - -i + - -i. + - TExpectedActual + - TRigidType + - TErrorGivenPartialSignature + - TLocalBinding + - TLocalBindingShadow1 + - TLocalBindingShadow2 + - -Wall diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 215a15ff8..c545f6027 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -21,10 +21,11 @@ import Data.List import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T +import qualified Data.Set as Set import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping (fromCurrentRange, toCurrentRange) -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat hiding (locA) import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics @@ -38,6 +39,11 @@ import Language.LSP.Server import Language.LSP.Types import qualified Language.LSP.Types.Lens as J +#if MIN_VERSION_ghc(9,2,0) +import GHC.Hs (AnnsModule(AnnsModule)) +import GHC.Parser.Annotation +#endif + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands @@ -63,25 +69,78 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do medit <- liftIO $ runMaybeT $ do docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath - let - ps = pm_parsed_source pm - anns = relativiseApiAnns ps (pm_annotations pm) - old = T.pack $ exactPrint ps anns - (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let - (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) - new = T.pack $ exactPrint ps' anns' - + (old, new) <- makeEditText pm df pure (workspaceEdit caps old new) + forM_ medit $ \edit -> sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure (Right Null) where - indent = 2 + workspaceEdit caps old new + = diffText caps (uri, old) new IncludeDeletions + + toMethodName n + | Just (h, _) <- T.uncons n + , not (isAlpha h || h == '_') + = "(" <> n <> ")" + | otherwise + = n + +#if MIN_VERSION_ghc(9,2,0) + makeEditText pm df = do + List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = makeDeltaAst $ pm_parsed_source pm + old = T.pack $ exactPrint ps + (ps', _, _) = runTransform (addMethodDecls ps mDecls) + new = T.pack $ exactPrint ps' + pure (old, new) + + makeMethodDecl df mName = + either (const Nothing) Just . parseDecl df (T.unpack mName) . T.unpack + $ toMethodName mName <> " = _" + + addMethodDecls ps mDecls = do + allDecls <- hsDecls ps + let (before, ((L l inst): after)) = break (containRange range . getLoc) allDecls + replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine mDecls ++ after)) + where + -- Add `where` keyword for `instance X where` if `where` is missing. + -- + -- The `where` in ghc-9.2 is now stored in the instance declaration + -- directly. More precisely, giving an `HsDecl GhcPs`, we have: + -- InstD --> ClsInstD --> ClsInstDecl --> XCClsInstDecl --> (EpAnn [AddEpAnn], AnnSortKey), + -- here `AnnEpAnn` keeps the track of Anns. + -- + -- See the link for the original definition: + -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl + addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = + let ((EpAnn entry anns comments), key) = cid_ext + in InstD xInstD (ClsInstD ext decl { + cid_ext = (EpAnn + entry + (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) + comments + , key) + }) + addWhere decl = decl + + newLine (L l e) = + let dp = deltaPos 1 (indent + 1) -- Not sure why there need one more space + in L (noAnnSrcSpanDP (locA l) dp <> l) e + +#else + makeEditText pm df = do + List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + let ps = pm_parsed_source pm + anns = relativiseApiAnns ps (pm_annotations pm) + old = T.pack $ exactPrint ps anns + (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls) + new = T.pack $ exactPrint ps' anns' + pure (old, new) + makeMethodDecl df mName = case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of Right (ann, d) -> Just (setPrecedingLines d 1 indent ann, d) @@ -112,16 +171,7 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs) findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps - - workspaceEdit caps old new - = diffText caps (uri, old) new IncludeDeletions - - toMethodName n - | Just (h, _) <- T.uncons n - , not (isAlpha h || h == '_') - = "(" <> n <> ")" - | otherwise - = n +#endif -- | -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is @@ -169,15 +219,9 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr pure $ head . head $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) -#if !MIN_VERSION_ghc(9,0,0) - ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) + ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds) <=< nodeChildren ) -#else - ( (Map.keys . Map.filter isClassNodeIdentifier . sourcedNodeIdents . sourcedNodeInfo) - <=< nodeChildren - ) -#endif findClassFromIdentifier docPath (Right name) = do (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath @@ -197,7 +241,7 @@ containRange :: Range -> SrcSpan -> Bool containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x isClassNodeIdentifier :: IdentifierDetails a -> Bool -isClassNodeIdentifier = isNothing . identType +isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident) isClassMethodWarning :: T.Text -> Bool isClassMethodWarning = T.isPrefixOf "• No explicit implementation for" diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 9a6925503..ff2ca5a2c 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Main ( main ) where @@ -45,6 +46,8 @@ tests = testGroup executeCodeAction mmAction , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do executeCodeAction _fAction + , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do + executeCodeAction eqAction ] _CACodeAction :: Prism' (Command |? CodeAction) CodeAction diff --git a/plugins/hls-class-plugin/test/testdata/T5.expected.hs b/plugins/hls-class-plugin/test/testdata/T5.expected.hs new file mode 100644 index 000000000..6c26425f3 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.expected.hs @@ -0,0 +1,8 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ + +x = () diff --git a/plugins/hls-class-plugin/test/testdata/T5.hs b/plugins/hls-class-plugin/test/testdata/T5.hs new file mode 100644 index 000000000..e7dc1d4da --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T5.hs @@ -0,0 +1,7 @@ +module T1 where + +data X = X + +instance Eq X where + +x = () diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 8f7f496b3..efc1e9dc1 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -62,6 +62,7 @@ library , hslogger , lens , lsp + , refact , regex-tdfa , stm , temporary diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index a5ba0b9c2..2f1cd7dd6 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -12,11 +12,13 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +{-# OPTIONS_GHC -Wno-orphans #-} #ifdef HLINT_ON_GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) @@ -55,6 +57,7 @@ import Development.IDE.Core.Rules (defineNoFil usePropertyAction) import Development.IDE.Core.Shake (getDiagnostics) import qualified Refact.Apply as Refact +import qualified Refact.Types as Refact #ifdef HLINT_ON_GHC_LIB import Development.IDE.GHC.Compat (BufSpan, @@ -84,7 +87,7 @@ import System.IO (IOMode (Wri import System.IO.Temp #else import Development.IDE.GHC.Compat hiding - (setEnv) + (setEnv, (<+>)) import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) @@ -93,7 +96,6 @@ import Language.Haskell.GhclibParserEx.Fixity as GhclibPar import qualified Refact.Fixity as Refact #endif -import Ide.Logger import Ide.Plugin.Config hiding (Config) import Ide.Plugin.Properties @@ -125,13 +127,21 @@ import System.Environment (setEnv, import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -newtype Log +data Log = LogShake Shake.Log + | LogApplying NormalizedFilePath (Either String WorkspaceEdit) + | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] + | LogGetIdeas NormalizedFilePath + | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them deriving Show instance Pretty Log where pretty = \case LogShake log -> pretty log + LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res + LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas + LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts + LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib @@ -148,8 +158,8 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = - [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd - , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd + [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) + , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) ] , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider , pluginConfigDescriptor = defaultConfigDescriptor @@ -179,7 +189,7 @@ rules recorder plugin = do define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def let hlintOn = pluginEnabledConfig plcDiagnosticsOn plugin config - ideas <- if hlintOn then getIdeas file else return (Right []) + ideas <- if hlintOn then getIdeas recorder file else return (Right []) return (diagnostics file ideas, Just ()) defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do @@ -247,9 +257,9 @@ rules recorder plugin = do } srcSpanToRange (UnhelpfulSpan _) = noRange -getIdeas :: NormalizedFilePath -> Action (Either ParseError [Idea]) -getIdeas nfp = do - debugm $ "hlint:getIdeas:file:" ++ show nfp +getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas recorder nfp = do + logWith recorder Debug $ LogGetIdeas nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] @@ -295,7 +305,7 @@ getIdeas nfp = do setExtensions flags = do hlintExts <- getExtensions nfp - debugm $ "hlint:getIdeas:setExtensions:" ++ show hlintExts + logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts) return $ flags { enabledExtensions = hlintExts } -- Gets extensions from ModSummary dynflags for the file. @@ -469,15 +479,14 @@ mkSuppressHintTextEdits dynFlags fileContents hint = combinedTextEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -applyAllCmd :: CommandFunction IdeState Uri -applyAllCmd ide uri = do +applyAllCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri +applyAllCmd recorder ide uri = do let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) withIndefiniteProgress "Applying all hints" Cancellable $ do - logm $ "hlint:applyAllCmd:file=" ++ show file - res <- liftIO $ applyHint ide file Nothing - logm $ "hlint:applyAllCmd:res=" ++ show res + res <- liftIO $ applyHint recorder ide file Nothing + logWith recorder Debug $ LogApplying file res case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) Right fs -> do @@ -500,34 +509,33 @@ data OneHint = OneHint , oneHintTitle :: HintTitle } deriving (Eq, Show) -applyOneCmd :: CommandFunction IdeState ApplyOneParams -applyOneCmd ide (AOP uri pos title) = do +applyOneCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState ApplyOneParams +applyOneCmd recorder ide (AOP uri pos title) = do let oneHint = OneHint pos title let file = maybe (error $ show uri ++ " is not a file.") toNormalizedFilePath' (uriToFilePath' uri) let progTitle = "Applying hint: " <> title withIndefiniteProgress progTitle Cancellable $ do - logm $ "hlint:applyOneCmd:file=" ++ show file - res <- liftIO $ applyHint ide file (Just oneHint) - logm $ "hlint:applyOneCmd:res=" ++ show res + res <- liftIO $ applyHint recorder ide file (Just oneHint) + logWith recorder Debug $ LogApplying file res case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) Right fs -> do _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) pure $ Right Null -applyHint :: IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) -applyHint ide nfp mhint = +applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> IO (Either String WorkspaceEdit) +applyHint recorder ide nfp mhint = runExceptT $ do let runAction' :: Action a -> IO a runAction' = runAction "applyHint" ide let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] - ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas nfp + ideas <- bimapExceptT showParseError id $ ExceptT $ runAction' $ getIdeas recorder nfp let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map ideaRefactoring ideas' - liftIO $ logm $ "applyHint:apply=" ++ show commands + logWith recorder Debug $ LogGeneratedIdeas nfp commands let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent @@ -584,7 +592,6 @@ applyHint ide nfp mhint = Right appliedFile -> do let uri = fromNormalizedUri (filePathToUri' nfp) let wsEdit = diffText' True (uri, oldContent) (T.pack appliedFile) IncludeDeletions - liftIO $ logm $ "hlint:applyHint:diff=" ++ show wsEdit ExceptT $ return (Right wsEdit) Left err -> throwE err diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index b50d4f0ce..d8d1df432 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -20,16 +20,15 @@ import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Rules hiding (Log, logToPriority) import Development.IDE.Core.Tracing (withTelemetryLogger) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide +import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types import Ide.Arguments -import Ide.Logger import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, PluginId (PluginId), @@ -44,6 +43,7 @@ data Log | LogDirectory !FilePath | LogLspStart !GhcideArguments ![PluginId] | LogIDEMain IDEMain.Log + | LogOther T.Text deriving Show instance Pretty Log where @@ -57,6 +57,7 @@ instance Pretty Log where , viaShow ghcideArgs , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] LogIDEMain iDEMainLog -> pretty iDEMainLog + LogOther t -> pretty t defaultMain :: Recorder (WithPriority Log) -> Arguments -> IdePlugins IdeState -> IO () defaultMain recorder args idePlugins = do @@ -109,16 +110,6 @@ defaultMain recorder args idePlugins = do -- --------------------------------------------------------------------- -hlsLogger :: G.Logger -hlsLogger = G.Logger $ \pri txt -> - case pri of - G.Debug -> debugm (T.unpack txt) - G.Info -> logm (T.unpack txt) - G.Warning -> warningm (T.unpack txt) - G.Error -> errorm (T.unpack txt) - --- --------------------------------------------------------------------- - runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO () runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do let log = logWith recorder @@ -129,17 +120,18 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) - IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger) + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack $ LogOther m) + + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger) { IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = idePlugins - , IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger + , IDEMain.argsLogger = pure logger <> pure telemetryLogger , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads , IDEMain.argsIdeOptions = \_config sessionLoader -> let defOptions = Ghcide.defaultIdeOptions sessionLoader in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling , Ghcide.optTesting = Ghcide.IdeTesting argsTesting - , Ghcide.optShakeOptions = (Ghcide.optShakeOptions defOptions) - {shakeThreads = argsThreads} } } diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index c50a66619..c7b8c521d 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -31,6 +31,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock @@ -42,7 +43,7 @@ extra-deps: - extra-1.7.10 - floskell-0.10.5@sha256:77f0bc1569573d9666b10975a5357fef631d32266c071733739393ccae521dab,3803 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - - hie-bios-0.9.0 + - hie-bios-0.9.1 - hiedb-0.4.1.0 - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 4a20d069c..d38a3e874 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock @@ -43,7 +44,7 @@ extra-deps: - extra-1.7.10 - floskell-0.10.5@sha256:77f0bc1569573d9666b10975a5357fef631d32266c071733739393ccae521dab,3803 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - - hie-bios-0.9.0 + - hie-bios-0.9.1 - hiedb-0.4.1.0 - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 30c32d808..8e935e9d3 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock @@ -62,7 +63,7 @@ extra-deps: - haddock-library-1.10.0 - hashable-1.3.0.0 - heapsize-0.3.0 - - hie-bios-0.9.0 + - hie-bios-0.9.1 - hlint-3.2.8 - HsYAML-0.2.1.0@rev:1 - HsYAML-aeson-0.2.0.0@rev:2 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index e6ddbe765..0a30f9bf4 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock @@ -52,7 +53,7 @@ extra-deps: - ghc-trace-events-0.1.2.1 - haskell-src-exts-1.21.1 - heapsize-0.3.0 - - hie-bios-0.9.0 + - hie-bios-0.9.1 - hlint-3.2.8 - HsYAML-aeson-0.2.0.0@rev:2 - hoogle-5.0.17.11 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index fec732f0f..cb09da83c 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 @@ -45,7 +46,7 @@ extra-deps: - floskell-0.10.6 - heapsize-0.3.0.1 - hiedb-0.4.1.0 -- hie-bios-0.9.0 +- hie-bios-0.9.1 - implicit-hie-0.1.2.6 - implicit-hie-cradle-0.3.0.5 - monad-dijkstra-0.1.1.3 diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml index dfe06176e..7be98797c 100644 --- a/stack-9.0.2.yaml +++ b/stack-9.0.2.yaml @@ -29,6 +29,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 @@ -45,7 +46,7 @@ extra-deps: - floskell-0.10.6 - heapsize-0.3.0.1 - hiedb-0.4.1.0 -- hie-bios-0.9.0 +- hie-bios-0.9.1 - implicit-hie-0.1.2.6 - implicit-hie-cradle-0.3.0.5 - monad-dijkstra-0.1.1.3 diff --git a/stack-9.2.1.yaml b/stack-9.2.1.yaml index 49b917e73..0962522f7 100644 --- a/stack-9.2.1.yaml +++ b/stack-9.2.1.yaml @@ -10,7 +10,7 @@ packages: - ./hls-test-utils - ./shake-bench - ./plugins/hls-call-hierarchy-plugin -# - ./plugins/hls-class-plugin +- ./plugins/hls-class-plugin # - ./plugins/hls-haddock-comments-plugin # - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin @@ -28,8 +28,9 @@ packages: - ./plugins/hls-pragmas-plugin - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin -# - ./plugins/hls-alternate-number-format-plugin +- ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin +- ./plugins/hls-change-type-signature-plugin extra-deps: - aeson-2.0.3.0 @@ -50,7 +51,7 @@ extra-deps: - ghc-lib-parser-ex-9.2.0.1 - heapsize-0.3.0.1 - hiedb-0.4.1.0 -- hie-bios-0.9.0 +- hie-bios-0.9.1 - hspec-2.7.10 # for hls-test-utils - hspec-core-2.7.10 # for hls-test-utils - implicit-hie-0.1.2.6 @@ -115,7 +116,6 @@ flags: ignore-plugins-ghc-bounds: true alternateNumberFormat: false brittany: false - class: false eval: false haddockComments: false hlint: false diff --git a/stack.yaml b/stack.yaml index c5b2ecccd..5f4d0a972 100644 --- a/stack.yaml +++ b/stack.yaml @@ -32,6 +32,7 @@ packages: - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-selection-range-plugin + - ./plugins/hls-change-type-signature-plugin ghc-options: "$everything": -haddock @@ -44,7 +45,7 @@ extra-deps: - floskell-0.10.5@sha256:77f0bc1569573d9666b10975a5357fef631d32266c071733739393ccae521dab,3803 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - hiedb-0.4.1.0 - - hie-bios-0.9.0 + - hie-bios-0.9.1 - hlint-3.2.8 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index ff709441f..91cb322e2 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -43,7 +43,7 @@ renameTests = testGroup "rename suggestions" [ cars <- getAllCodeActions doc replaceButStrLn <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] executeCommand replaceButStrLn - _ <- anyRequest + _ <- skipManyTill loggingNotification anyRequest x:_ <- T.lines <$> documentContents doc liftIO $ x @?= "main = putStrLn \"hello\"" @@ -65,7 +65,7 @@ renameTests = testGroup "rename suggestions" [ _ -> error $ "Unexpected arguments: " ++ show mbArgs executeCommand cmd - _ <- anyRequest + _ <- skipManyTill loggingNotification anyRequest x1:x2:_ <- T.lines <$> documentContents doc liftIO $ @@ -207,7 +207,7 @@ redundantImportTests = testGroup "redundant import code actions" [ cas <- getAllCodeActions doc cmd <- liftIO $ inspectCommand cas ["redundant import"] executeCommand cmd - _ <- anyRequest + _ <- skipManyTill loggingNotification anyRequest contents <- documentContents doc liftIO $ T.lines contents @?= [ "{-# OPTIONS_GHC -Wunused-imports #-}"