haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-17 11:47:09 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into fourmolu-cli

Browse Source
This commit is contained in:
George Thomas 2022-03-10 23:33:30 +00:00 committed by GitHub
commit 129e584e6b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
110 changed files with 1688 additions and 556 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/bench.yml vendored
View File

@ -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

4
.github/workflows/build.yml vendored
View File

@ -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: |

2
.github/workflows/caching.yml vendored
View File

@ -95,7 +95,7 @@ jobs:
]
steps:
- uses: actions/checkout@v2
- uses: actions/checkout@v3
- uses: ./.github/actions/setup-build
with:

2
.github/workflows/flags.yml vendored
View File

@ -55,7 +55,7 @@ jobs:
]
steps:
- uses: actions/checkout@v2
- uses: actions/checkout@v3
- uses: ./.github/actions/setup-build
with:

2
.github/workflows/hackage.yml vendored
View File

@ -49,7 +49,7 @@ jobs:
steps:
- uses: actions/checkout@v2
- uses: actions/checkout@v3
- uses: ./.github/actions/setup-build
with:

2
.github/workflows/hlint.yml vendored
View File

@ -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

4
.github/workflows/nix.yml vendored
View File

@ -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:

14
.github/workflows/test.yml vendored
View File

@ -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

8
bindist/GNUmakefile.in
View File

@ -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:

3
cabal-ghc90.project
View File

@ -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

4
cabal-ghc921.project
View File

@ -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

3
cabal.project
View File

@ -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

22
docs/features.md
View File

@ -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 <https:
![Wingman Demo](https://user-images.githubusercontent.com/307223/92657198-3d4be400-f2a9-11ea-8ad3-f541c8eea891.gif)
### Change Type Signature
Provided by: `hls-change-type-signature-plugin`
Code action kind: `quickfix`
Change/Update a type signature to match implementation.
Status: Until GHC 9.4, the implementation is ad-hoc and relies on GHC error messages to create a new signature. Not all GHC error messages are supported.
Known Limitations:
- Not all GHC error messages are supported
- Top-level and Function-local bindings with the same names can cause issues, such as incorrect signature changes or no code actions available.
![Change Type Signature Demo](../plugins/hls-change-type-signature-plugin/change1.gif)
![Change Type Signature Demo](../plugins/hls-change-type-signature-plugin/change2.gif)
[Link to Docs](../plugins/hls-change-type-signature/README.md)
## Code lenses
### Add type signature

53
exe/Main.hs
View File

@ -4,19 +4,26 @@
{-# LANGUAGE OverloadedStrings #-}
module Main(main) where
import Control.Monad.IO.Class (liftIO)
import Data.Function ((&))
import Development.IDE.Types.Logger (Priority (Debug, Info),
import Data.Text (Text)
import qualified Development.IDE.Types.Logger as Logger
import Development.IDE.Types.Logger (Priority (Debug, Info, Error),
WithPriority (WithPriority, priority),
cfilter, cmapWithPrio,
makeDefaultStderrRecorder,
withDefaultRecorder)
withDefaultRecorder, renderStrict, layoutPretty, defaultLayoutOptions, Doc)
import Ide.Arguments (Arguments (..),
GhcideArguments (..),
getArguments)
import Ide.Main (defaultMain)
import qualified Ide.Main as IdeMain
import Ide.PluginUtils (pluginDescToIdePlugins)
import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler)
import Language.LSP.Server as LSP
import Language.LSP.Types as LSP
import qualified Plugins
import Prettyprinter (Pretty (pretty))
import Prettyprinter (Pretty (pretty), vsep)
data Log
= LogIdeMain IdeMain.Log
@ -34,6 +41,16 @@ main = do
pluginCliRecorder <- cmapWithPrio pretty <$> 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"

6
exe/Plugins.hs
View File

@ -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

2
exe/Wrapper.hs
View File

@ -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"

4
flake.nix
View File

@ -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;

32
ghcide/exe/Main.hs
View File

@ -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

2
ghcide/ghcide.cabal
View File

@ -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)

5
ghcide/session-loader/Development/IDE/Session.hs
View File

@ -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

14
ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -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

188
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -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

12
ghcide/src/Development/IDE/LSP/LanguageServer.hs
View File

@ -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) $

4
ghcide/src/Development/IDE/Main.hs
View File

@ -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

22
ghcide/src/Development/IDE/Plugin/CodeAction.hs
View File

@ -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

133
ghcide/src/Development/IDE/Types/Logger.hs
View File

@ -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

12
ghcide/src/Development/IDE/Types/Options.hs
View File

@ -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

3
ghcide/test/data/hover/GotoHover.hs
View File

@ -61,3 +61,6 @@ aa2 = $(id [| True |])
hole :: Int
hole = _
hole2 :: a -> Maybe a
hole2 = _

140
ghcide/test/exe/Main.hs
View File

@ -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)"

13
haskell-language-server.cabal
View File

@ -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

30
hls-graph/hls-graph.cabal
View File

@ -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

2
hls-graph/src/Development/IDE/Graph.hs
View File

@ -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,

13
hls-graph/src/Development/IDE/Graph/Database.hs
View File

@ -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 ()

14
hls-graph/src/Development/IDE/Graph/Internal/Action.hs
View File

@ -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)]

63
hls-graph/src/Development/IDE/Graph/Internal/Database.hs
View File

@ -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)

5
hls-graph/src/Development/IDE/Graph/Internal/Options.hs
View File

@ -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

1
hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
View File

@ -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 ()

58
hls-graph/src/Development/IDE/Graph/Internal/Types.hs
View File

@ -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

2
hls-graph/src/Development/IDE/Graph/Rule.hs
View File

@ -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

77
hls-graph/test/ActionSpec.hs Normal file
View File

@ -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

29
hls-graph/test/DatabaseSpec.hs Normal file
View File

@ -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

31
hls-graph/test/Example.hs Normal file
View File

@ -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

7
hls-graph/test/Main.hs Normal file
View File

@ -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"

8
hls-graph/test/RulesSpec.hs Normal file
View File

@ -0,0 +1,8 @@
module RulesSpec where
import Test.Hspec
spec :: Spec
spec = do
describe "" $ do
pure ()

1
hls-graph/test/Spec.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

2
hls-plugin-api/hls-plugin-api.cabal
View File

@ -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

29
hls-plugin-api/src/Ide/Logger.hs
View File

@ -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
-- ---------------------------------------------------------------------

12
hls-plugin-api/src/Ide/PluginUtils.hs
View File

@ -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

4
hls-test-utils/src/Test/Hls.hs
View File

@ -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 <-

4
plugins/hls-alternate-number-format-plugin/README.md
View File

@ -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

3
plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal
View File

@ -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 <https://github.com/haskell/haskell-language-server#readme>
@ -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

4
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs
View File

@ -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

53
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs
View File

@ -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

31
plugins/hls-alternate-number-format-plugin/test/Main.hs
View File

@ -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
]

4
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectBinaryFormat.hs vendored
View File

@ -1,4 +0,0 @@
{-# LANGUAGE BinaryLiterals #-}
module TExpectBinaryFormat where
binary = 459

4
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectHexFloatFormat.hs vendored
View File

@ -1,4 +0,0 @@
{-# LANGUAGE HexFloatLiterals #-}
module TExpectHexFloatFormat where
hexFloat = 459.123

3
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoBinaryFormat.hs vendored
View File

@ -1,3 +0,0 @@
module TExpectNoBinaryFormat where
noBinary = 459

3
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoHexFloatFormat.hs vendored
View File

@ -1,3 +0,0 @@
module TExpectNoHexFloatFormat where
noHexFloat = 459.123

3
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNoNumDecimalFormat.hs vendored
View File

@ -1,3 +0,0 @@
module TExpectNoNumDecimalFormat where
noNumDecimal = 499999

4
plugins/hls-alternate-number-format-plugin/test/testdata/TExpectNumDecimalFormat.hs vendored
View File

@ -1,4 +0,0 @@
{-# LANGUAGE NumDecimals #-}
module TExpectNumDecimalFormat where
numDecimal = 499999

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoLet.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralDoLet where
doLet :: IO ()

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralDoReturn.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralDoReturn where
doReturn :: IO Integer

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralIntCase where
caseExpression x = case x + 34 of

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntCase2.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralIntCase where
caseExpression x = case x of

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralIntPattern.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralIntPattern where
patternMatchingFunction 1 = "one"

1
plugins/hls-alternate-number-format-plugin/test/testdata/TFindLiteralList.hs vendored
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NoBinaryLiterals #-}
module TFindLiteralList where
listTest = [reverse $ show 57]

5
plugins/hls-alternate-number-format-plugin/test/testdata/test/testdata/TIntDtoND.expected.hs vendored Normal file
View File

@ -0,0 +1,5 @@
{-# LANGUAGE NumDecimals #-}
module TIntDtoND where
convertMe :: Integer
convertMe = 125.345e3

201
plugins/hls-change-type-signature-plugin/LICENSE Normal file
View File

@ -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.

21
plugins/hls-change-type-signature-plugin/README.md Normal file
View File

@ -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

BIN
plugins/hls-change-type-signature-plugin/change1.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 342 KiB

BIN
plugins/hls-change-type-signature-plugin/change2.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 171 KiB

66
plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal Normal file
View File

@ -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 <https://github.com/haskell/plugins/hls-change-type-signature-plugin/README.md>
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

168
plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs Normal file
View File

@ -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

132
plugins/hls-change-type-signature-plugin/test/Main.hs Normal file
View File

@ -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)

4
plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs vendored Normal file
View File

@ -0,0 +1,4 @@
module ErrorGivenPartialSignature where
partial :: Int -> Int
partial x = init x

6
plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.expected.hs vendored Normal file
View File

@ -0,0 +1,6 @@
module TExpectedActual where
fullSig :: [Int] -> Int
fullSig = go
where
go = head . reverse

6
plugins/hls-change-type-signature-plugin/test/testdata/TExpectedActual.hs vendored Normal file
View File

@ -0,0 +1,6 @@
module TExpectedActual where
fullSig :: Int -> Int
fullSig = go
where
go = head . reverse

8
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.expected.hs vendored Normal file
View File

@ -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

8
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBinding.hs vendored Normal file
View File

@ -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

11
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.expected.hs vendored Normal file
View File

@ -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

11
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow1.hs vendored Normal file
View File

@ -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

11
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.expected.hs vendored Normal file
View File

@ -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

11
plugins/hls-change-type-signature-plugin/test/testdata/TLocalBindingShadow2.hs vendored Normal file
View File

@ -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

6
plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.expected.hs vendored Normal file
View File

@ -0,0 +1,6 @@
module TRigidType where
test :: [[Int]] -> Int
test = go . head . reverse
where
go = head . reverse

6
plugins/hls-change-type-signature-plugin/test/testdata/TRigidType.hs vendored Normal file
View File

@ -0,0 +1,6 @@
module TRigidType where
test :: a -> Int
test = go . head . reverse
where
go = head . reverse

6
plugins/hls-change-type-signature-plugin/test/testdata/error1.txt vendored Normal file
View File

@ -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

6
plugins/hls-change-type-signature-plugin/test/testdata/error2.txt vendored Normal file
View File

@ -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

10
plugins/hls-change-type-signature-plugin/test/testdata/error3.txt vendored Normal file
View File

@ -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]
| ^^^^^^^^^^^^^^^^^

19
plugins/hls-change-type-signature-plugin/test/testdata/error4.txt vendored Normal file
View File

@ -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
| ^^^^^^^^^^^^^^^^^^^

15
plugins/hls-change-type-signature-plugin/test/testdata/error5.txt vendored Normal file
View File

@ -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
| ^^^^

9
plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error1.txt vendored Normal file
View File

@ -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
| ^^^^^^

9
plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error2.txt vendored Normal file
View File

@ -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
|

9
plugins/hls-change-type-signature-plugin/test/testdata/ghc921-error3.txt vendored Normal file
View File

@ -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
|

12
plugins/hls-change-type-signature-plugin/test/testdata/hie.yaml vendored Normal file
View File

@ -0,0 +1,12 @@
cradle:
direct:
arguments:
- -i
- -i.
- TExpectedActual
- TRigidType
- TErrorGivenPartialSignature
- TLocalBinding
- TLocalBindingShadow1
- TLocalBindingShadow2
- -Wall

104
plugins/hls-class-plugin/src/Ide/Plugin/Class.hs
View File

@ -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"

3
plugins/hls-class-plugin/test/Main.hs
View File

@ -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

8
plugins/hls-class-plugin/test/testdata/T5.expected.hs vendored Normal file
View File

@ -0,0 +1,8 @@
module T1 where
data X = X
instance Eq X where
(==) = _
x = ()

7
plugins/hls-class-plugin/test/testdata/T5.hs vendored Normal file
View File

@ -0,0 +1,7 @@
module T1 where
data X = X
instance Eq X where
x = ()

1
plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
View File

@ -62,6 +62,7 @@ library
, hslogger
, lens
, lsp
, refact
, regex-tdfa
, stm
, temporary

59
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View File

@ -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

Some files were not shown because too many files have changed in this diff Show More