From 2b691b65cbc0c592471ae68597e32478d49b87f2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 29 Jan 2023 16:31:24 +0100 Subject: [PATCH] Add Inline code action to Retrie plugin (#3444) --- .github/workflows/test.yml | 4 + ghcide/src/Development/IDE/Core/Actions.hs | 1 + ghcide/src/Development/IDE/Core/Shake.hs | 7 +- ghcide/src/Development/IDE/GHC/Compat/Core.hs | 2 + ghcide/src/Development/IDE/Spans/AtPoint.hs | 2 + hls-test-utils/src/Test/Hls.hs | 18 +- .../hls-call-hierarchy-plugin/test/Main.hs | 2 +- plugins/hls-eval-plugin/test/Main.hs | 1 + plugins/hls-refactor-plugin/test/Main.hs | 4 +- .../src/Ide/Plugin/RefineImports.hs | 14 +- plugins/hls-rename-plugin/test/Main.hs | 1 + .../hls-retrie-plugin/hls-retrie-plugin.cabal | 19 + .../src/Ide/Plugin/Retrie.hs | 523 +++++++++++++----- plugins/hls-retrie-plugin/test/Main.hs | 97 ++++ .../hls-retrie-plugin/test/testdata/Class.hs | 7 + .../test/testdata/Identity.expected.hs | 5 + .../test/testdata/Identity.hs | 5 + .../test/testdata/Imported.expected.hs | 5 + .../test/testdata/Imported.hs | 5 + .../test/testdata/Nested.expected.hs | 7 + .../test/testdata/NestedLet.expected.hs | 7 + .../test/testdata/NestedLet.hs | 7 + .../test/testdata/NestedNested.hs | 10 + .../test/testdata/NestedWhere.expected.hs | 7 + .../test/testdata/NestedWhere.hs | 7 + .../test/testdata/Operator.expected.hs | 5 + .../test/testdata/Operator.hs | 5 + .../hls-retrie-plugin/test/testdata/hie.yaml | 11 + plugins/hls-tactics-plugin/new/test/Utils.hs | 2 +- plugins/hls-tactics-plugin/old/test/Utils.hs | 3 +- src/Ide/Main.hs | 1 + src/Ide/Version.hs | 1 + test/functional/Config.hs | 5 +- 33 files changed, 645 insertions(+), 155 deletions(-) create mode 100644 plugins/hls-retrie-plugin/test/Main.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Class.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Identity.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Imported.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/NestedLet.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/NestedNested.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/Operator.hs create mode 100644 plugins/hls-retrie-plugin/test/testdata/hie.yaml diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 614e1ff760..112b548c15 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -259,6 +259,10 @@ jobs: name: Test hls-cabal-plugin test suite run: cabal test hls-cabal-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-cabal-plugin --test-options="$TEST_OPTS" + - if: matrix.test + name: Test hls-retrie-plugin test suite + run: cabal test hls-retrie-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-retrie-plugin --test-options="$TEST_OPTS" + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 304dfd393e..1f3db651fb 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -10,6 +10,7 @@ module Development.IDE.Core.Actions , useNoFileE , usesE , workspaceSymbols +, lookupMod ) where import Control.Monad.Reader diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7b0ab79d0d..18152a5421 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -315,7 +315,7 @@ getShakeExtrasRules :: Rules ShakeExtras getShakeExtrasRules = do mExtras <- getShakeExtraRules @ShakeExtras case mExtras of - Just x -> return x + Just x -> return x -- This will actually crash HLS Nothing -> liftIO $ fail "missing ShakeExtras" @@ -982,7 +982,10 @@ usesWithStale_ key files = do -- -- Run via 'runIdeAction'. newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup) + +-- https://hub.darcs.net/ross/transformers/issue/86 +deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a) runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 7a5448361e..4dc0e22115 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -447,6 +447,7 @@ module Development.IDE.GHC.Compat.Core ( -- * Syntax re-exports #if MIN_VERSION_ghc(9,0,0) module GHC.Hs, + module GHC.Hs.Binds, module GHC.Parser, module GHC.Parser.Header, module GHC.Parser.Lexer, @@ -786,6 +787,7 @@ import qualified Finder as GHC -- (until the CPP extension is actually needed). import GHC.LanguageExtensions.Type hiding (Cpp) +import GHC.Hs.Binds mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index a1ed871633..cd55fbb979 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -20,6 +20,8 @@ module Development.IDE.Spans.AtPoint ( , getNamesAtPoint , toCurrentLocation , rowToLoc + , nameToLocation + , LookupModule ) where import Development.IDE.GHC.Error diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0332b079e9..dc39b765c3 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -176,7 +176,7 @@ goldenWithDoc fileType plugin title testDataDir path desc ext act = -- ------------------------------------------------------------ -- | Plugin under test where a fitting recorder is injected. -type PluginTestDescriptor b = Recorder (WithPriority b) -> PluginDescriptor IdeState +type PluginTestDescriptor b = Recorder (WithPriority b) -> IdePlugins IdeState -- | Wrap a plugin you want to test, and inject a fitting recorder as required. -- @@ -197,7 +197,7 @@ mkPluginTestDescriptor :: (Recorder (WithPriority b) -> PluginId -> PluginDescriptor IdeState) -> PluginId -> PluginTestDescriptor b -mkPluginTestDescriptor pluginDesc plId recorder = pluginDesc recorder plId +mkPluginTestDescriptor pluginDesc plId recorder = IdePlugins [pluginDesc recorder plId] -- | Wrap a plugin you want to test. -- @@ -207,7 +207,7 @@ mkPluginTestDescriptor' :: (PluginId -> PluginDescriptor IdeState) -> PluginId -> PluginTestDescriptor b -mkPluginTestDescriptor' pluginDesc plId _recorder = pluginDesc plId +mkPluginTestDescriptor' pluginDesc plId _recorder = IdePlugins [pluginDesc plId] -- | Initialise a recorder that can be instructed to write to stderr by -- setting the environment variable "HLS_TEST_PLUGIN_LOG_STDERR=1" before @@ -260,18 +260,18 @@ initialiseTestRecorder envVars = do runSessionWithServer :: Pretty b => PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer plugin fp act = do recorder <- pluginTestRecorder - runSessionWithServer' [plugin recorder] def def fullCaps fp act + runSessionWithServer' (plugin recorder) def def fullCaps fp act runSessionWithServerAndCaps :: Pretty b => PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a runSessionWithServerAndCaps plugin caps fp act = do recorder <- pluginTestRecorder - runSessionWithServer' [plugin recorder] def def caps fp act + runSessionWithServer' (plugin recorder) def def caps fp act runSessionWithServerFormatter :: Pretty b => PluginTestDescriptor b -> String -> PluginConfig -> FilePath -> Session a -> IO a runSessionWithServerFormatter plugin formatter conf fp act = do recorder <- pluginTestRecorder runSessionWithServer' - [plugin recorder] + (plugin recorder) def { formattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf @@ -329,7 +329,7 @@ runSessionWithCabalServerFormatter :: Pretty b => PluginTestDescriptor b -> Stri runSessionWithCabalServerFormatter plugin formatter conf fp act = do recorder <- pluginTestRecorder runSessionWithServer' - [plugin recorder] + (plugin recorder) def { cabalFormattingProvider = T.pack formatter , plugins = M.singleton (PluginId $ T.pack formatter) conf @@ -354,7 +354,7 @@ runSessionWithServer' :: -- -- For improved logging, make sure these plugins have been initalised with -- the recorder produced by @pluginTestRecorder@. - [PluginDescriptor IdeState] -> + IdePlugins IdeState -> -- | lsp config for the server Config -> -- | config for the test session @@ -380,7 +380,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre -- exists until old logging style is phased out logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - hlsPlugins = IdePlugins $ Test.blockCommandDescriptor "block-command" : plugins + hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins arguments@Arguments{ argsIdeOptions, argsLogger } = testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 08d4b88dbf..d1b455c741 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -12,10 +12,10 @@ import Data.Functor ((<&>)) import Data.List (sort, tails) import qualified Data.Map as M import qualified Data.Text as T +import Development.IDE.Test import Ide.Plugin.CallHierarchy import qualified Language.LSP.Test as Test import qualified Language.LSP.Types.Lens as L -import Development.IDE.Test import System.Directory.Extra import System.FilePath import qualified System.IO.Extra diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index df9c83b4ac..03df1913fc 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -22,6 +22,7 @@ import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) +import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Types.Lens (arguments, command, range, title) import System.FilePath (()) import Test.Hls diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index d84b01c35c..499e529500 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -64,11 +64,11 @@ import qualified Test.AddArgument main :: IO () main = defaultTestRunner tests -refactorPlugin :: IO [PluginDescriptor IdeState] +refactorPlugin :: IO (IdePlugins IdeState) refactorPlugin = do exactprintLog <- pluginTestRecorder ghcideLog <- pluginTestRecorder - pure $ + pure $ IdePlugins $ [ Refactor.iePluginDescriptor exactprintLog "ghcide-code-actions-imports-exports" , Refactor.typeSigsPluginDescriptor exactprintLog "ghcide-code-actions-type-signatures" , Refactor.bindingsPluginDescriptor exactprintLog "ghcide-code-actions-bindings" diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index d4a8076484..fdffb73ff2 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -47,7 +47,19 @@ import Ide.Plugin.ExplicitImports (extractMinimalImports, import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server -import Language.LSP.Types +import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeAction (CodeAction, _command, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title, _xdata), + CodeActionKind (CodeActionUnknown), + CodeActionParams (CodeActionParams), + CodeLens (..), + CodeLensParams (CodeLensParams, _textDocument), + Method (TextDocumentCodeAction, TextDocumentCodeLens), + SMethod (STextDocumentCodeAction, STextDocumentCodeLens, SWorkspaceApplyEdit), + TextDocumentIdentifier (TextDocumentIdentifier, _uri), + TextEdit (..), + WorkspaceEdit (..), + type (|?) (InR), + uriToNormalizedFilePath) newtype Log = LogShake Shake.Log deriving Show diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index 0896d9d5bb..6acafd9cec 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -6,6 +6,7 @@ import Data.Aeson import qualified Data.Map as M import Ide.Plugin.Config import qualified Ide.Plugin.Rename as Rename +import Ide.Types (IdePlugins (IdePlugins)) import System.FilePath import Test.Hls diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 8606ea7c1c..74dc45611c 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -31,6 +31,7 @@ library , ghcide ^>=1.9 , hashable , hls-plugin-api ^>=1.6 + , hls-refactor-plugin , lsp , lsp-types , retrie >=0.1.1.0 @@ -46,3 +47,21 @@ library TypeOperators ghc-options: -Wno-unticked-promoted-constructors + +test-suite tests + buildable: True + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson + , base + , containers + , filepath + , hls-plugin-api + , hls-refactor-plugin + , hls-retrie-plugin + , hls-test-utils ^>=1.5 + , text diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index f006163124..b45049e377 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -1,87 +1,117 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wno-orphans #-} +{-# LANGUAGE TupleSections #-} module Ide.Plugin.Retrie (descriptor) where import Control.Concurrent.STM (readTVarIO) import Control.Exception.Safe (Exception (..), - SomeException, catch, - throwIO, try) -import Control.Monad (forM, unless) + SomeException, assert, + catch, throwIO, try) +import Control.Monad (forM, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (ExceptT), - runExceptT) + runExceptT, throwE) import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Writer.Strict import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null)) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Coerce +import Data.Data import Data.Either (partitionEithers) -import Data.Hashable (unhashed) +import Data.Hashable (Hashable (hash), + unhashed) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as Set import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (find, nubOrdOn) +import Data.Maybe (catMaybes, fromJust, + listToMaybe) import Data.String (IsString) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) +import Debug.Trace import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping -import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar), - toKnownFiles) -import Development.IDE.GHC.Compat (GenLocated (L), GhcPs, +import Development.IDE.Core.Shake (ShakeExtras (ShakeExtras, knownTargetsVar), + clientCapabilities, + getShakeExtras, + hiedbWriter, + toKnownFiles, withHieDb) +import Development.IDE.GHC.Compat (GRHSs (GRHSs), + GenLocated (L), GhcPs, GhcRn, GhcTc, HsBindLR (FunBind), + HsExpr (HsApp, OpApp), HsGroup (..), HsValBindsLR (..), - HscEnv, IdP, LRuleDecls, + HscEnv, IdP, + ImportDecl (..), LHsExpr, + LRuleDecls, Match, + ModIface, ModSummary (ModSummary, ms_hspp_buf, ms_mod), - Outputable, + Name, Outputable, ParsedModule (..), + RealSrcLoc, RuleDecl (HsRule), RuleDecls (HsRules), SourceText (..), TyClDecl (SynDecl), TyClGroup (..), fun_id, hm_iface, isQual, - isQual_maybe, locA, - mi_fixities, + isQual_maybe, isVarOcc, + locA, mi_fixities, + moduleName, moduleNameString, ms_hspp_opts, nameModule_maybe, - nameRdrName, noLocA, - occNameFS, occNameString, + nameOccName, nameRdrName, + noLocA, occNameFS, + occNameString, pattern IsBoot, pattern NotBoot, pattern RealSrcSpan, pm_parsed_source, + printWithoutUniques, rdrNameOcc, rds_rules, srcSpanFile, topDir, - unLocA) + unLoc, unLocA) +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util hiding (catch, try) -import qualified GHC (Module, - ParsedModule (..), +import Development.IDE.GHC.Dump (showAstDataHtml) +import Development.IDE.GHC.ExactPrint (ExceptStringT (ExceptStringT), + GetAnnotatedParsedSource (GetAnnotatedParsedSource), + TransformT, + graftExprWithM, + graftSmallestDeclsWithM, + hoistGraft, transformM) +import qualified GHC (Module, ParsedSource, moduleName, parseModule) +import qualified GHC as GHCGHC import GHC.Generics (Generic) +import GHC.Hs.Dump import Ide.PluginUtils import Ide.Types import Language.LSP.Server (LspM, @@ -93,48 +123,80 @@ import Language.LSP.Types as J hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), SemanticTokensEdit (_start)) +import Retrie (Annotated (astA), + AnnotatedModule, + Fixity (Fixity), + FixityDirection (InfixL), + Options, Options_ (..), + RewriteSpec, + Verbosity (Loud), + addImports, apply, + applyWithUpdate) +import Retrie.Context import Retrie.CPP (CPP (NoCPP), parseCPP) import Retrie.ExactPrint (Annotated, fix, transformA, unsafeMkA) +import Retrie.Expr (mkLocatedHsVar) +import Retrie.Fixity (FixityEnv, lookupOp, + mkFixityEnv) +import Retrie.Monad (getGroundTerms, + runRetrie) +import Retrie.Options (defaultOptions, + getTargetFiles) +import Retrie.Replace (Change (..), + Replacement (..)) +import Retrie.Rewrites +import Retrie.Rewrites.Function (matchToRewrites) +import Retrie.SYB (everything, extQ, + listify, mkQ) +import Retrie.Types +import Retrie.Universe (Universe) +import System.Directory (makeAbsolute) #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.PkgQual +import GHC.Types.PkgQual #endif #if MIN_VERSION_ghc(9,2,0) +import Control.Exception (evaluate) +import Data.Monoid (First (First)) import Retrie.ExactPrint (makeDeltaAst) +import Retrie.GHC (ann) #else +import Data.Monoid (First (..)) +import qualified GHC.Exts as Ext +import Retrie.AlphaEnv (extendAlphaEnv) import Retrie.ExactPrint (relativiseApiAnns) #endif -import Retrie.Fixity (mkFixityEnv) -import qualified Retrie.GHC as GHC -import Retrie.Monad (addImports, apply, - getGroundTerms, - runRetrie) -import qualified Retrie.Options as Retrie -import Retrie.Options (defaultOptions, - getTargetFiles) -import Retrie.Replace (Change (..), - Replacement (..)) -import Retrie.Rewrites -import Retrie.SYB (listify) -import Retrie.Util (Verbosity (Loud)) -import System.Directory (makeAbsolute) +import Control.Arrow ((&&&)) +import Development.IDE.Core.Actions (lookupMod) +import Development.IDE.Spans.AtPoint (LookupModule, + getNamesAtPoint, + nameToLocation) +import Development.IDE.Types.Shake (WithHieDb) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider, - pluginCommands = [retrieCommand] + pluginCommands = [retrieCommand, retrieInlineThisCommand] } retrieCommandName :: T.Text retrieCommandName = "retrieCommand" +retrieInlineThisCommandName :: T.Text +retrieInlineThisCommandName = "retrieInlineThisCommand" + retrieCommand :: PluginCommand IdeState retrieCommand = PluginCommand (coerce retrieCommandName) "run the refactoring" runRetrieCmd +retrieInlineThisCommand :: PluginCommand IdeState +retrieInlineThisCommand = + PluginCommand (coerce retrieInlineThisCommandName) "inline function call" + runRetrieInlineThisCmd + -- | Parameters for the runRetrie PluginCommand. data RunRetrieParams = RunRetrieParams { description :: T.Text, @@ -155,7 +217,8 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = runAction "Retrie.GhcSessionDeps" state $ useWithStale GhcSessionDeps nfp - (ms, binds, _, _, _) <- MaybeT $ liftIO $ runAction "Retrie.getBinds" state $ getBinds nfp + (ms, binds, _, _, _) <- MaybeT $ liftIO $ + runAction "Retrie.getBinds" state $ getBinds nfp let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie @@ -174,6 +237,83 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = return () return $ Right Null +data RunRetrieInlineThisParams = RunRetrieInlineThisParams + { inlineIntoThisLocation :: !Location, + inlineFromThisLocation :: !Location, + inlineThisDefinition :: !T.Text + } + deriving (Eq, Show, Generic, FromJSON, ToJSON) + +runRetrieInlineThisCmd :: IdeState + -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value) +runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do + nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation + nfpSource <- handleMaybe "sourceUri" $ + uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineFromThisLocation + -- What we do here: + -- Find the identifier in the given position + -- Construct an inline rewrite for it + -- Run retrie to get a list of changes + -- Select the change that inlines the identifier in the given position + -- Apply the edit + ast <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $ + use GetAnnotatedParsedSource nfp + astSrc <- handleMaybeM "ast" $ liftIO $ runAction "retrie" state $ + use GetAnnotatedParsedSource nfpSource + msr <- handleMaybeM "modSummary" $ liftIO $ runAction "retrie" state $ + use GetModSummaryWithoutTimestamps nfp + hiFileRes <- handleMaybeM "modIface" $ liftIO $ runAction "retrie" state $ + use GetModIface nfpSource + let fixityEnv = fixityEnvFromModIface (hirModIface hiFileRes) + fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation + intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation + inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange + when (null inlineRewrite) $ throwE "Empty rewrite" + let ShakeExtras{..}= shakeExtras state + (session, _) <- handleMaybeM "GHCSession" $ liftIO $ runAction "retrie" state $ + useWithStale GhcSessionDeps nfp + (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp + result <- liftIO $ try @_ @SomeException $ + runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp + case result of + Left err -> throwE $ "Retrie - crashed with: " <> show err + Right (_,_,NoChange) -> throwE "Retrie - inline produced no changes" + Right (_,_,Change replacements imports) -> do + let edits = asEditMap $ asTextEdits $ Change ourReplacement imports + wedit = WorkspaceEdit (Just edits) Nothing Nothing + ourReplacement = [ r + | r@Replacement{..} <- replacements + , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] + lift $ sendRequest SWorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return Null + +-- Override to skip adding binders to the context, which prevents inlining +-- nested defined functions +myContextUpdater :: ContextUpdater +myContextUpdater c i = + updateContext c i + `extQ` (return . updExp) + `extQ` (skipUpdate @(GRHSs GhcPs (LHsExpr GhcPs))) + `extQ` (skipUpdate @(Match GhcPs (LHsExpr GhcPs))) + where + skipUpdate :: forall a m . Monad m => a -> TransformT m Context + skipUpdate _ = pure c + + -- override to skip the HsLet case + updExp :: HsExpr GhcPs -> Context + updExp HsApp{} = + c { ctxtParentPrec = HasPrec $ Retrie.Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL } + -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right) + -- In left child, prec is 10, so HsApp child will NOT get paren'd + -- In right child, prec is 11, so every child gets paren'd (unless atomic) + updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) } + updExp _ = c { ctxtParentPrec = NeverParen } + -- Deal with Trees-That-Grow adding extension points + -- as the first child everywhere. + firstChild :: Int + firstChild = 1 + extractImports :: ModSummary -> [HsBindLR GhcRn GhcRn] -> RewriteSpec -> [ImportSpec] extractImports ModSummary{ms_mod} topLevelBinds (Unfold thing) | Just FunBind {fun_matches} @@ -204,9 +344,13 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri (ModSummary{ms_mod}, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) - <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ getBinds nfp + <- handleMaybeM "typecheck" $ liftIO $ runAction "retrie" state $ + getBinds nfp + + extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras - pos <- handleMaybe "pos" $ _start <$> fromCurrentRange posMapping range + range <- handleMaybe "range" $ fromCurrentRange posMapping range + let pos = _start range let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds @@ -215,15 +359,26 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) L (locA -> l) g <- group_tyclds, pos `isInsideSrcSpan` l, r <- suggestTypeRewrites uri ms_mod g - ] - commands <- lift $ + retrieCommands <- lift $ forM rewrites $ \(title, kind, params) -> liftIO $ do let c = mkLspCommand plId (coerce retrieCommandName) title (Just [toJSON params]) return $ CodeAction title (Just kind) Nothing Nothing Nothing Nothing (Just c) Nothing - return $ J.List [InR c | c <- commands] + inlineSuggestions <- liftIO $ runIdeAction "" extras $ + suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter) + let inlineCommands = + [ Just $ + CodeAction _title (Just CodeActionRefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing + | c@Command{..} <- inlineSuggestions + ] + return $ J.List [InR c | c <- retrieCommands ++ catMaybes inlineCommands] + +getLocationUri :: Location -> Uri +getLocationUri Location{_uri} = _uri + +getLocationRange Location{_range} = _range getBinds :: NormalizedFilePath -> Action (Maybe (ModSummary, [HsBindLR GhcRn GhcRn], PositionMapping, [LRuleDecls GhcRn], [TyClGroup GhcRn])) getBinds nfp = runMaybeT $ do @@ -247,7 +402,7 @@ getBinds nfp = runMaybeT $ do topLevelBinds = [ decl | (_, bagBinds) <- binds, - L _ decl <- GHC.bagToList bagBinds + L _ decl <- bagToList bagBinds ] return (tmrModSummary tm, topLevelBinds, posMapping, hs_ruleds, hs_tyclds) @@ -272,6 +427,43 @@ suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestBindRewrites _ _ _ _ = [] + -- find all the identifiers in the AST for which have source definitions +suggestBindInlines :: PluginId -> Uri -> [HsBindLR GhcRn GhcRn] -> Range -> WithHieDb -> _ -> IdeAction [Command] +suggestBindInlines plId uri binds range hie lookupMod = do + identifiers <- definedIdentifiers + return $ map (\(name, siteLoc, srcLoc) -> + let + title = "Inline " <> printedName + printedName = printOutputable name + params = RunRetrieInlineThisParams + { inlineIntoThisLocation = siteLoc + , inlineFromThisLocation = srcLoc + , inlineThisDefinition= printedName + } + in mkLspCommand plId (coerce retrieInlineThisCommandName) title (Just [toJSON params]) + ) + (Set.toList identifiers) + where + definedIdentifiers = + -- we search for candidates to inline in RHSs only, skipping LHSs + everything (<>) (pure mempty `mkQ` getGRHSIdentifierDetails hie lookupMod) binds + + getGRHSIdentifierDetails :: WithHieDb -> _ -> GRHSs GhcRn (LHsExpr GhcRn) -> IdeAction (Set.HashSet (GHC.OccName, Location, Location)) + getGRHSIdentifierDetails a b it@GRHSs{} = + -- we only select candidates for which we have source code + everything (<>) (pure mempty `mkQ` getDefinedIdentifierDetailsViaHieDb a b) it + + getDefinedIdentifierDetailsViaHieDb :: WithHieDb -> LookupModule IdeAction -> GHC.LIdP GhcRn -> IdeAction (Set.HashSet (GHC.OccName, Location, Location)) + getDefinedIdentifierDetailsViaHieDb withHieDb lookupModule lname | name <- unLoc lname = + case srcSpanToLocation (GHC.getLocA lname) of + Just siteLoc + | siteRange <- getLocationRange siteLoc + , range `isSubrangeOf` siteRange -> do + mbSrcLocation <- nameToLocation withHieDb lookupModule name + return $ maybe mempty (Set.fromList . map (nameOccName name, siteLoc,)) mbSrcLocation + _ -> pure mempty + + describeRestriction :: IsString p => Bool -> p describeRestriction restrictToOriginatingFile = if restrictToOriginatingFile then " in current file" else "" @@ -332,9 +524,8 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = CodeActionRefactor, RunRetrieParams {..} ) -suggestRuleRewrites _ _ _ _ = [] -qualify :: GHC.Module -> String -> String +qualify :: Outputable mod => mod -> String -> String qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x ------------------------------------------------------------------------------- @@ -364,50 +555,7 @@ callRetrie :: IO ([CallRetrieError], WorkspaceEdit) callRetrie state session rewrites origin restrictToOriginatingFile = do knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state) -#if MIN_VERSION_ghc(9,2,0) - -- retrie needs the libdir for `parseRewriteSpecs` - libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin -#endif - let reuseParsedModule f = do - pm <- useOrFail "Retrie.GetParsedModule" NoParse GetParsedModule f - (fixities, pm') <- fixFixities f (fixAnns pm) - return (fixities, pm') - getCPPmodule t = do - nt <- toNormalizedFilePath' <$> makeAbsolute t - let getParsedModule f contents = do - modSummary <- msrModSummary <$> - useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt - let ms' = - modSummary - { ms_hspp_buf = - Just (stringToStringBuffer contents) - } - logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t - parsed <- evalGhcEnv session (GHC.parseModule ms') - `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) - (fixities, parsed) <- fixFixities f (fixAnns parsed) - return (fixities, parsed) - - contents <- do - (_, mbContentsVFS) <- - runAction "Retrie.GetFileContents" state $ getFileContents nt - case mbContentsVFS of - Just contents -> return contents - Nothing -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt) - if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents) - then do - fixitiesRef <- newIORef mempty - let parseModule x = do - (fix, res) <- getParsedModule nt x - atomicModifyIORef'_ fixitiesRef (fix <>) - return res - res <- parseCPP parseModule contents - fixities <- readIORef fixitiesRef - return (fixities, res) - else do - (fixities, pm) <- reuseParsedModule nt - return (fixities, NoCPP pm) - + let -- TODO cover all workspaceFolders target = "." @@ -429,21 +577,15 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0 #endif - (originFixities, originParsedModule) <- reuseParsedModule origin + (originFixities, originParsedModule) <- reuseParsedModule state origin retrie <- (\specs -> apply specs >> addImports annotatedImports) - <$> parseRewriteSpecs -#if MIN_VERSION_ghc(9,2,0) - libdir -#endif - (\_f -> return $ NoCPP originParsedModule) - originFixities - theRewrites + <$> parseSpecs state origin originParsedModule originFixities theRewrites targets <- getTargetFiles retrieOptions (getGroundTerms retrie) results <- forM targets $ \t -> runExceptT $ do - (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule t + (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t -- TODO add the imports to the resulting edits (_user, ast, change@(Change _replacements _imports)) <- lift $ runRetrie fixityEnv retrie cpp @@ -452,41 +594,113 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do let (errors :: [CallRetrieError], replacements) = partitionEithers results editParams :: WorkspaceEdit editParams = - WorkspaceEdit (Just $ asEditMap replacements) Nothing Nothing + WorkspaceEdit (Just $ asEditMap $ concat replacements) Nothing Nothing return (errors, editParams) - where - useOrFail :: - IdeRule r v => - String -> - (NormalizedFilePath -> CallRetrieError) -> - r -> - NormalizedFilePath -> - IO (RuleResult r) - useOrFail lbl mkException rule f = - useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return - fixityEnvFromModIface modIface = - mkFixityEnv - [ (fs, (fs, fixity)) - | (n, fixity) <- mi_fixities modIface, - let fs = occNameFS n - ] - fixFixities f pm = do + +useOrFail :: + IdeRule r v => + IdeState -> + String -> + (NormalizedFilePath -> CallRetrieError) -> + r -> + NormalizedFilePath -> + IO (RuleResult r) +useOrFail state lbl mkException rule f = + useRule lbl state rule f >>= maybe (liftIO $ throwIO $ mkException f) return + +fixityEnvFromModIface :: ModIface -> FixityEnv +fixityEnvFromModIface modIface = + mkFixityEnv + [ (fs, (fs, fixity)) + | (n, fixity) <- mi_fixities modIface, + let fs = occNameFS n + ] + +fixFixities :: Data ast => + IdeState + -> NormalizedFilePath + -> Annotated ast + -> IO (FixityEnv, Annotated ast) +fixFixities state f pm = do HiFileResult {hirModIface} <- - useOrFail "GetModIface" NoTypeCheck GetModIface f + useOrFail state "GetModIface" NoTypeCheck GetModIface f let fixities = fixityEnvFromModIface hirModIface res <- transformA pm (fix fixities) return (fixities, res) + +fixAnns :: ParsedModule -> Annotated GHC.ParsedSource #if MIN_VERSION_ghc(9,2,0) - fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0 +fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0 #else - fixAnns GHC.ParsedModule {..} = +fixAnns GHC.ParsedModule {..} = let ranns = relativiseApiAnns pm_parsed_source pm_annotations in unsafeMkA pm_parsed_source ranns 0 #endif -asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap -asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure)) +parseSpecs + :: IdeState + -> NormalizedFilePath + -> AnnotatedModule + -> FixityEnv + -> [RewriteSpec] + -> IO [Rewrite Universe] +parseSpecs state origin originParsedModule originFixities specs = do +#if MIN_VERSION_ghc(9,2,0) + -- retrie needs the libdir for `parseRewriteSpecs` + libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin +#endif + parseRewriteSpecs +#if MIN_VERSION_ghc(9,2,0) + libdir +#endif + (\_f -> return $ NoCPP originParsedModule) + originFixities + specs + +constructfromFunMatches imps fun_id fun_matches = do + let fName = occNameFS (GHC.occName (unLoc fun_id)) + fe <- mkLocatedHsVar fun_id + rewrites <- concat <$> + forM (unLoc $ GHC.mg_alts fun_matches) (matchToRewrites fe imps LeftToRight) + let urewrites = toURewrite <$> rewrites + -- traceShowM $ map showQuery urewrites + assert (not $ null urewrites) $ + return urewrites + +showQuery = ppRewrite +-- showQuery :: Rewrite (LHsExpr GhcPs) -> String +-- showQuery q = unlines +-- [ "template: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . tTemplate . fst . qResult $ q)) +-- , "quantifiers: " <> show (hash (T.pack (show(Ext.toList $ qQuantifiers q)))) +-- , "matcher: " <> show (hash (printOutputable . showAstData NoBlankSrcSpan . astA . qPattern $ q)) +-- ] + +s :: Data a => a -> String +s = T.unpack . printOutputable . showAstData NoBlankSrcSpan +#if MIN_VERSION_ghc(9,2,0) + NoBlankEpAnnotations +#endif +constructInlineFromIdentifer originParsedModule originSpan = do + -- traceM $ s $ astA originParsedModule + fmap astA $ transformA originParsedModule $ \(L _ m) -> do + let ast = everything (<>) (First Nothing `mkQ` matcher) m + matcher :: HsBindLR GhcPs GhcPs -> First _ + matcher FunBind{fun_id, fun_matches} + -- | trace (show (GHC.getLocA fun_id) <> ": " <> s fun_id) False = undefined + | RealSrcSpan sp _ <- GHC.getLocA fun_id + , sp == originSpan = + First $ Just (fun_id, fun_matches) + matcher _ = First Nothing + case ast of + First (Just (fun_id, fun_matches)) + -> + let imports = mempty in + constructfromFunMatches imports fun_id fun_matches + _ -> return $ error "cound not find source code to inline" + +asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap +asEditMap = coerce . HM.fromListWith (++) . map (second pure) asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = [] @@ -531,9 +745,6 @@ deriving instance FromJSON RewriteSpec deriving instance ToJSON RewriteSpec -data QualName = QualName {qual, name :: String} - deriving (Eq, Show, Generic, FromJSON, ToJSON) - newtype IE name = IEVar name deriving (Eq, Show, Generic, FromJSON, ToJSON) @@ -563,9 +774,49 @@ toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} ideclHiding = Nothing ideclSourceSrc = NoSourceText #if MIN_VERSION_ghc(9,2,0) - ideclExt = GHC.EpAnnNotUsed + ideclExt = GHCGHC.EpAnnNotUsed #else ideclExt = GHC.noExtField #endif ideclAs = toMod <$> ideclAsString ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified + +reuseParsedModule state f = do + pm <- useOrFail state "Retrie.GetParsedModule" NoParse GetParsedModule f + (fixities, pm') <- fixFixities state f (fixAnns pm) + return (fixities, pm') +getCPPmodule state session t = do + nt <- toNormalizedFilePath' <$> makeAbsolute t + let getParsedModule f contents = do + modSummary <- msrModSummary <$> + useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt + let ms' = + modSummary + { ms_hspp_buf = + Just (stringToStringBuffer contents) + } + logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t + parsed <- evalGhcEnv session (GHCGHC.parseModule ms') + `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) + (fixities, parsed) <- fixFixities state f (fixAnns parsed) + return (fixities, parsed) + + contents <- do + (_, mbContentsVFS) <- + runAction "Retrie.GetFileContents" state $ getFileContents nt + case mbContentsVFS of + Just contents -> return contents + Nothing -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt) + if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents) + then do + fixitiesRef <- newIORef mempty + let parseModule x = do + (fix, res) <- getParsedModule nt x + atomicModifyIORef'_ fixitiesRef (fix <>) + return res + res <- parseCPP parseModule contents + fixities <- readIORef fixitiesRef + return (fixities, res) + else do + (fixities, pm) <- reuseParsedModule state nt + return (fixities, NoCPP pm) diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs new file mode 100644 index 0000000000..ef17fceb58 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Monad (void) +import Data.Aeson +import qualified Data.Map as M +import Data.Text (Text) +import qualified Development.IDE.GHC.ExactPrint +import qualified Development.IDE.Plugin.CodeAction as Refactor +import Ide.Plugin.Config +import qualified Ide.Plugin.Retrie as Retrie +import Ide.Types (IdePlugins (IdePlugins)) +import System.FilePath +import Test.Hls +import Test.Hls (PluginTestDescriptor) + +main :: IO () +main = defaultTestRunner tests + +retriePlugin :: PluginTestDescriptor a +retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie" + +refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor" + +tests :: TestTree +tests = testGroup "Retrie" + [ inlineThisTests + ] + +inlineThisTests :: TestTree +inlineThisTests = testGroup "Inline this" + [ + testGroup "provider" [ + testProvider "lhs" "Identity" 4 1 ["Unfold function", "Unfold function in current file", "Fold function", "Fold function in current file"], + testProvider "identifier" "Identity" 4 16 ["Inline identity"], + testProvider "imported identifier" "Imported" 4 12 ["Inline identity"], + testProvider "nested where" "NestedWhere" 4 16 ["Inline identity"], + testProvider "nested let" "NestedLet" 6 12 ["Inline identity"], + testProvider "class member" "Class" 5 16 [], + testProvider "operator" "Operator" 4 16 ["Inline */"] + ], + testGroup "command" [ + testCommand "top level function" "Identity" 4 16, + testCommand "top level function in another file" "Imported" 4 12, + testCommand "nested where function" "NestedWhere" 4 16, + testCommand "nested let function" "NestedLet" 6 12, + testCommand "operator" "Operator" 4 16 + ] + ] + + +testProvider title file line row expected = testCase title $ runWithRetrie $ do + adoc <- openDoc (file <.> "hs") "haskell" + waitForTypecheck adoc + let position = Position line row + codeActions <- getCodeActions adoc $ Range position position + liftIO $ map codeActionTitle codeActions @?= map Just expected + +testCommand :: TestName -> FilePath -> UInt -> UInt -> TestTree +testCommand title file row col = goldenWithRetrie title file $ \adoc -> do + waitForTypecheck adoc + let p = Position row col + codeActions <- getCodeActions adoc $ Range p p + case codeActions of + [InR ca] -> do + executeCodeAction ca + void $ skipManyTill anyMessage $ getDocumentEdit adoc + [] -> error "No code actions found" + +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle (InR CodeAction {_title}) = Just _title +codeActionTitle _ = Nothing + +goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithRetrie title path act = + goldenWithHaskellDoc testPlugins title testDataDir path "expected" "hs" $ \doc -> do + sendConfigurationChanged $ toJSON $ + def { plugins = M.fromList [("retrie", def)] } + act doc + +runWithRetrie :: Session a -> IO a +runWithRetrie = runSessionWithServer testPlugins testDataDir + +testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +testPlugins = + retriePlugin <> + refactorPlugin -- needed for the GetAnnotatedParsedSource rule + +testDataDir :: FilePath +testDataDir = "test" "testdata" diff --git a/plugins/hls-retrie-plugin/test/testdata/Class.hs b/plugins/hls-retrie-plugin/test/testdata/Class.hs new file mode 100644 index 0000000000..644a647b5e --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Class.hs @@ -0,0 +1,7 @@ +module Class where + +class Identity x where + identity :: x -> x + identity x = x + +function x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs new file mode 100644 index 0000000000..8fbd1b5cea --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Identity.expected.hs @@ -0,0 +1,5 @@ +module Identity where + +identity x = x + +function x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Identity.hs b/plugins/hls-retrie-plugin/test/testdata/Identity.hs new file mode 100644 index 0000000000..3e81c40efa --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Identity.hs @@ -0,0 +1,5 @@ +module Identity where + +identity x = x + +function x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs new file mode 100644 index 0000000000..7670647d4d --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Imported.expected.hs @@ -0,0 +1,5 @@ +module Imported where + +import Identity + +f x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Imported.hs b/plugins/hls-retrie-plugin/test/testdata/Imported.hs new file mode 100644 index 0000000000..3773e396fc --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Imported.hs @@ -0,0 +1,5 @@ +module Imported where + +import Identity + +f x = identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs new file mode 100644 index 0000000000..8df3fbd2de --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Nested.expected.hs @@ -0,0 +1,7 @@ +module Nested where + + + +function x = x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs b/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs new file mode 100644 index 0000000000..0cd81093e9 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedLet.expected.hs @@ -0,0 +1,7 @@ +module NestedLet where + + + +function x = + let identity x = x + in x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs b/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs new file mode 100644 index 0000000000..ce7db202bd --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedLet.hs @@ -0,0 +1,7 @@ +module NestedLet where + + + +function x = + let identity x = x + in identity x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs b/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs new file mode 100644 index 0000000000..e2935c4464 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedNested.hs @@ -0,0 +1,10 @@ + +module NestedNested where + + + +function x = meme x + where + meme x = identity x + identity x = x + diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs new file mode 100644 index 0000000000..948779a429 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.expected.hs @@ -0,0 +1,7 @@ +module NestedWhere where + + + +function x = x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs new file mode 100644 index 0000000000..edde87bb26 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/NestedWhere.hs @@ -0,0 +1,7 @@ +module NestedWhere where + + + +function x = identity x + where + identity x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs b/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs new file mode 100644 index 0000000000..4e351e4864 --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Operator.expected.hs @@ -0,0 +1,5 @@ +module Operator where + +x */ y = x + +function x = x diff --git a/plugins/hls-retrie-plugin/test/testdata/Operator.hs b/plugins/hls-retrie-plugin/test/testdata/Operator.hs new file mode 100644 index 0000000000..6c6b63522a --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/Operator.hs @@ -0,0 +1,5 @@ +module Operator where + +x */ y = x + +function x = x */ () diff --git a/plugins/hls-retrie-plugin/test/testdata/hie.yaml b/plugins/hls-retrie-plugin/test/testdata/hie.yaml new file mode 100644 index 0000000000..bf059478ed --- /dev/null +++ b/plugins/hls-retrie-plugin/test/testdata/hie.yaml @@ -0,0 +1,11 @@ +cradle: + direct: + arguments: + - Class.hs + - Identity.hs + - Imported.hs + - Nested.hs + - NestedLet.hs + - NestedNested.hs + - NestedWhere.hs + - Operator.hs diff --git a/plugins/hls-tactics-plugin/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs index db31d910cf..85a15bb436 100644 --- a/plugins/hls-tactics-plugin/new/test/Utils.hs +++ b/plugins/hls-tactics-plugin/new/test/Utils.hs @@ -63,7 +63,7 @@ resetGlobalHoleRef = writeIORef globalHoleRef 0 runSessionForTactics :: Session a -> IO a runSessionForTactics = runSessionWithServer' - [plugin] + (IdePlugins [plugin]) def (def { messageTimeout = 20 } ) fullCaps diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs index becc2ad3be..2bde87c191 100644 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ b/plugins/hls-tactics-plugin/old/test/Utils.hs @@ -22,6 +22,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Tactic as Tactic +import Ide.Types (IdePlugins(..)) import Language.LSP.Types import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) import qualified Language.LSP.Types.Lens as J @@ -64,7 +65,7 @@ runSessionForTactics :: Session a -> IO a runSessionForTactics act = do recorder <- pluginTestRecorder runSessionWithServer' - [plugin recorder] + (plugin recorder) def (def { messageTimeout = 20 } ) fullCaps diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 167933ae4f..bf4e79af98 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -137,3 +137,4 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog let defOptions = IDEMain.argsIdeOptions args config sessionLoader in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling } } + diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs index 1c67c0da46..d0af158587 100644 --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -7,6 +7,7 @@ -- and the current project's version module Ide.Version where + import Data.Maybe (listToMaybe) import Data.Version import GitHash (giCommitCount, tGitInfoCwdTry) diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 401e44b10d..5f13e7449b 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -96,11 +96,12 @@ genericConfigTests = testGroup "generic plugin config" testPluginDiagnostics = [("Foo.hs", [(DsError, (0,0), "testplugin")])] runConfigSession subdir = - failIfSessionTimeout . runSessionWithServer @() (const plugin) ("test/testdata" subdir) + failIfSessionTimeout . runSessionWithServer @() plugin ("test/testdata" subdir) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics - plugin = (defaultPluginDescriptor testPluginId) + plugin = mkPluginTestDescriptor' pd testPluginId + pd plId = (defaultPluginDescriptor plId) { pluginConfigDescriptor = configDisabled , pluginRules = do