From 445192e21daa4f4973e60a13e748ffa910819e79 Mon Sep 17 00:00:00 2001 From: Kobayashi Date: Mon, 11 Jul 2022 12:24:35 +0800 Subject: [PATCH] refactor selection range plugin (#3003) * update Gitpod config * update nix shellHook & docs * install pre-commit hook * add kokobd as code owner to .gitpod.* * add gen-hie to Gitpod * add tools for doc * remove .pre-commit-config.yaml from .gitignore * set vscode formatter to stylish-haskell in Gitpod * refactor selection range plugin * refine selection range * add CodeKind to CodeRange * rename hls-selection-range-plugin to hls-code-range-plugin * update docs about selection range * cleanup RuleTypes.hs * add the missing bang pattern * fix subRange * add some unit tests to CodeRange.Rules * add tests for removeInterleaving * add even more tests * fix extra sources Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com> --- .github/workflows/hackage.yml | 2 +- .github/workflows/test.yml | 4 +- CODEOWNERS | 2 +- cabal.project | 2 +- docs/features.md | 6 +- docs/supported-versions.md | 2 +- exe/Plugins.hs | 8 +- ghcide/src/Development/IDE/Core/RuleTypes.hs | 13 +- ghcide/src/Development/IDE/GHC/Compat.hs | 176 +++++++++------- haskell-language-server.cabal | 14 +- hls-plugin-api/src/Ide/PluginUtils.hs | 6 +- hls-plugin-api/test/Ide/PluginUtilsTest.hs | 2 + .../LICENSE | 0 .../hls-code-range-plugin.cabal} | 42 ++-- .../src/Ide/Plugin/CodeRange.hs | 136 ++++++++++++ .../Ide/Plugin/CodeRange}/ASTPreProcess.hs | 104 ++++++---- .../src/Ide/Plugin/CodeRange/Rules.hs | 195 ++++++++++++++++++ .../test/Ide/Plugin/CodeRange/RulesTest.hs | 80 +++++++ .../test/Ide/Plugin/CodeRangeTest.hs | 54 +++++ plugins/hls-code-range-plugin/test/Main.hs | 66 ++++++ .../selection-range}/Function.golden.txt | 0 .../testdata/selection-range}/Function.hs | 0 .../selection-range}/Import.golden.txt | 0 .../test/testdata/selection-range}/Import.hs | 0 .../test/testdata/selection-range}/hie.yaml | 0 .../src/Ide/Plugin/SelectionRange.hs | 145 ------------- .../hls-selection-range-plugin/test/Main.hs | 52 ----- stack-lts16.yaml | 2 +- stack-lts19.yaml | 2 +- stack.yaml | 2 +- 30 files changed, 764 insertions(+), 353 deletions(-) rename plugins/{hls-selection-range-plugin => hls-code-range-plugin}/LICENSE (100%) rename plugins/{hls-selection-range-plugin/hls-selection-range-plugin.cabal => hls-code-range-plugin/hls-code-range-plugin.cabal} (68%) create mode 100644 plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs rename plugins/{hls-selection-range-plugin/src/Ide/Plugin/SelectionRange => hls-code-range-plugin/src/Ide/Plugin/CodeRange}/ASTPreProcess.hs (61%) create mode 100644 plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs create mode 100644 plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs create mode 100644 plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs create mode 100644 plugins/hls-code-range-plugin/test/Main.hs rename plugins/{hls-selection-range-plugin/test/testdata => hls-code-range-plugin/test/testdata/selection-range}/Function.golden.txt (100%) rename plugins/{hls-selection-range-plugin/test/testdata => hls-code-range-plugin/test/testdata/selection-range}/Function.hs (100%) rename plugins/{hls-selection-range-plugin/test/testdata => hls-code-range-plugin/test/testdata/selection-range}/Import.golden.txt (100%) rename plugins/{hls-selection-range-plugin/test/testdata => hls-code-range-plugin/test/testdata/selection-range}/Import.hs (100%) rename plugins/{hls-selection-range-plugin/test/testdata => hls-code-range-plugin/test/testdata/selection-range}/hie.yaml (100%) delete mode 100644 plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs delete mode 100644 plugins/hls-selection-range-plugin/test/Main.hs diff --git a/.github/workflows/hackage.yml b/.github/workflows/hackage.yml index f90518f5d..09b1f57de 100644 --- a/.github/workflows/hackage.yml +++ b/.github/workflows/hackage.yml @@ -36,7 +36,7 @@ jobs: "hls-refine-imports-plugin", "hls-rename-plugin", "hls-retrie-plugin", "hls-splice-plugin", "hls-tactics-plugin", "hls-call-hierarchy-plugin", "hls-alternate-number-format-plugin", - "hls-qualify-imported-names-plugin", "hls-selection-range-plugin", + "hls-qualify-imported-names-plugin", "hls-code-range-plugin", "haskell-language-server"] ghc: [ "9.0.2" , "8.10.7" diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 951f7c7a1..c57c4de3c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -236,8 +236,8 @@ jobs: run: cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" || cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-qualify-imported-names-plugin --test-options="$TEST_OPTS" - if: matrix.test - 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" + name: Test hls-code-range-plugin test suite + run: cabal test hls-code-range-plugin --test-options="$TEST_OPTS" || cabal test hls-code-range-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-code-range-plugin --test-options="$TEST_OPTS" - if: matrix.test name: Test hls-change-type-signature test suite diff --git a/CODEOWNERS b/CODEOWNERS index b54ff268c..70dc00b93 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -25,7 +25,7 @@ /plugins/hls-refine-imports-plugin /plugins/hls-rename-plugin @OliverMadine /plugins/hls-retrie-plugin @pepeiborra -/plugins/hls-selection-range-plugin @kokobd +/plugins/hls-code-range-plugin @kokobd /plugins/hls-splice-plugin @konn /plugins/hls-stylish-haskell-plugin @Ailrun /plugins/hls-tactics-plugin @isovector diff --git a/cabal.project b/cabal.project index 19313edee..62dc214f2 100644 --- a/cabal.project +++ b/cabal.project @@ -26,7 +26,7 @@ packages: ./plugins/hls-call-hierarchy-plugin ./plugins/hls-alternate-number-format-plugin ./plugins/hls-qualify-imported-names-plugin - ./plugins/hls-selection-range-plugin + ./plugins/hls-code-range-plugin ./plugins/hls-change-type-signature-plugin ./plugins/hls-gadt-plugin diff --git a/docs/features.md b/docs/features.md index 0bf1d1648..58fa94529 100644 --- a/docs/features.md +++ b/docs/features.md @@ -317,13 +317,13 @@ Shows module name matching file path, and applies it with a click. ## Selection range -Provided by: `hls-selection-range-plugin` +Provided by: `hls-code-range-plugin` Provides haskell specific -[shrink/expand selection](https://code.visualstudio.com/docs/editor/codebasics#shrinkexpand-selection) +[shrink/expand selection](https://code.visualstudio.com/docs/editor/codebasics#_shrinkexpand-selection) support. -![Selection range demo](https://user-images.githubusercontent.com/16440269/150301502-4c002605-9f8d-43f5-86d3-28846942c4ff.mov) +![Selection range demo](https://user-images.githubusercontent.com/16440269/177240833-7dc8fe39-b446-477e-b5b1-7fc303608d4f.gif) ## Rename diff --git a/docs/supported-versions.md b/docs/supported-versions.md index 3948daeab..9e010373b 100644 --- a/docs/supported-versions.md +++ b/docs/supported-versions.md @@ -68,7 +68,7 @@ Sometimes a plugin will be supported in the pre-built binaries but not in a HLS | `hls-splice-plugin` | 9.2 | | `hls-stylish-haskell-plugin` | | | `hls-tactics-plugin` | 9.2 | -| `hls-selection-range-plugin` | | +| `hls-code-range-plugin` | | | `hls-gadt-plugin` | | ### Using deprecated GHC versions diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 07c15eb7f..6fbf6cd1d 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -76,8 +76,8 @@ import qualified Ide.Plugin.Splice as Splice import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat #endif -#if selectionRange -import Ide.Plugin.SelectionRange as SelectionRange +#if codeRange +import qualified Ide.Plugin.CodeRange as CodeRange #endif #if changeTypeSignature @@ -190,8 +190,8 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins #if alternateNumberFormat AlternateNumberFormat.descriptor pluginRecorder : #endif -#if selectionRange - SelectionRange.descriptor "selectionRange" : +#if codeRange + CodeRange.descriptor pluginRecorder "codeRange" : #endif #if changeTypeSignature ChangeTypeSignature.descriptor : diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 41ccfc481..2a10be92e 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -35,7 +35,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) -import qualified Data.Binary as B import Data.ByteString (ByteString) import Data.Text (Text) import Development.IDE.Import.FindImports (ArtifactsLocation) @@ -173,17 +172,17 @@ tmrModSummary :: TcModuleResult -> ModSummary tmrModSummary = pm_mod_summary . tmrParsed data HiFileResult = HiFileResult - { hirModSummary :: !ModSummary + { hirModSummary :: !ModSummary -- Bang patterns here are important to stop the result retaining -- a reference to a typechecked module - , hirModIface :: !ModIface - , hirModDetails :: ModDetails + , hirModIface :: !ModIface + , hirModDetails :: ModDetails -- ^ Populated lazily - , hirIfaceFp :: !ByteString + , hirIfaceFp :: !ByteString -- ^ Fingerprint for the ModIface , hirRuntimeModules :: !(ModuleEnv ByteString) -- ^ same as tmrRuntimeModules - , hirCoreFp :: !(Maybe (CoreFile, ByteString)) + , hirCoreFp :: !(Maybe (CoreFile, ByteString)) -- ^ If we wrote a core file for this module, then its contents (lazily deserialised) -- along with its hash } @@ -445,7 +444,7 @@ newtype GhcSessionDeps = GhcSessionDeps_ instance Show GhcSessionDeps where show (GhcSessionDeps_ False) = "GhcSessionDeps" - show (GhcSessionDeps_ True) = "GhcSessionDepsFull" + show (GhcSessionDeps_ True) = "GhcSessionDepsFull" pattern GhcSessionDeps :: GhcSessionDeps pattern GhcSessionDeps = GhcSessionDeps_ False diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 1c2876f73..8bb3c5fd1 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -32,10 +32,14 @@ module Development.IDE.GHC.Compat( myCoreToStgExpr, #endif + FastStringCompat, nodeInfo', getNodeIds, - nodeInfoFromSource, + sourceNodeInfo, + generatedNodeInfo, + simpleNodeInfoCompat, isAnnotationInNodeInfo, + nodeAnnotations, mkAstNode, combineRealSrcSpans, @@ -94,7 +98,6 @@ module Development.IDE.GHC.Compat( module UniqSet, module UniqDFM, getDependentMods, - diffBinds, flattenBinds, mkRnEnv2, emptyInScopeSet, @@ -113,6 +116,7 @@ module Development.IDE.GHC.Compat( #endif ) where +import Data.Bifunctor import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.ExactPrint @@ -125,58 +129,74 @@ import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Compat.Util import GHC hiding (HasSrcSpan, ModLocation, - RealSrcSpan, getLoc, - lookupName, exprType) + RealSrcSpan, exprType, + getLoc, lookupName) + +import Data.Coerce (coerce) +import Data.String (IsString (fromString)) + + #if MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Hooks (hscCompileCoreExprHook) -import GHC.Core (CoreExpr, CoreProgram, Unfolding(..), noUnfolding, flattenBinds) -import qualified GHC.Core.Opt.Pipeline as GHC -import GHC.Core.Tidy (tidyExpr) -import GHC.Types.Var.Env (emptyTidyEnv, mkRnEnv2, emptyInScopeSet) -import qualified GHC.CoreToStg.Prep as GHC -import GHC.CoreToStg.Prep (corePrepPgm) -import GHC.Core.Lint (lintInteractiveExpr) +import GHC.Core.Lint (lintInteractiveExpr) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.CoreToStg.Prep (corePrepPgm) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Driver.Hooks (hscCompileCoreExprHook) #if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable) -import GHC.Runtime.Context (icInteractiveModule) -import GHC.Unit.Module.Deps (Dependencies(dep_mods)) -import GHC.Linker.Types (isObjectLinkable) -import GHC.Linker.Loader (loadExpr) +import GHC.Linker.Loader (loadExpr) +import GHC.Linker.Types (isObjectLinkable) +import GHC.Runtime.Context (icInteractiveModule) +import GHC.Unit.Home.ModInfo (HomePackageTable, + lookupHpt) +import GHC.Unit.Module.Deps (Dependencies (dep_mods)) #else -import GHC.CoreToByteCode (coreExprToBCOs) -import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable) -import GHC.Runtime.Linker (linkExpr) +import GHC.CoreToByteCode (coreExprToBCOs) +import GHC.Driver.Types (Dependencies (dep_mods), + HomePackageTable, + icInteractiveModule, + lookupHpt) +import GHC.Runtime.Linker (linkExpr) #endif -import GHC.ByteCode.Asm (bcoFreeNames) -import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) -import GHC.Types.Unique.DSet as UniqDSet -import GHC.Types.Unique.Set as UniqSet -import GHC.Types.Unique.DFM as UniqDFM +import GHC.ByteCode.Asm (bcoFreeNames) +import GHC.Types.Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import GHC.Types.Unique.DFM as UniqDFM +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet #else -import Hooks (hscCompileCoreExprHook) -import CoreSyn (CoreExpr, flattenBinds, Unfolding(..), noUnfolding) -import qualified SimplCore as GHC -import CoreTidy (tidyExpr) -import VarEnv (emptyTidyEnv, mkRnEnv2, emptyInScopeSet) -import CorePrep (corePrepExpr, corePrepPgm) -import CoreLint (lintInteractiveExpr) -import ByteCodeGen (coreExprToBCOs) -import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods)) -import Linker (linkExpr) -import ByteCodeAsm (bcoFreeNames) -import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList) -import UniqDSet -import UniqSet -import UniqDFM +import Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import ByteCodeAsm (bcoFreeNames) +import ByteCodeGen (coreExprToBCOs) +import CoreLint (lintInteractiveExpr) +import CorePrep (corePrepExpr, + corePrepPgm) +import CoreSyn (CoreExpr, + Unfolding (..), + flattenBinds, + noUnfolding) +import CoreTidy (tidyExpr) +import Hooks (hscCompileCoreExprHook) +import Linker (linkExpr) +import qualified SimplCore as GHC +import UniqDFM +import UniqDSet +import UniqSet +import VarEnv (emptyInScopeSet, + emptyTidyEnv, mkRnEnv2) #endif #if MIN_VERSION_ghc(9,0,0) +import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var.Env import GHC.Utils.Error #if MIN_VERSION_ghc(9,2,0) -import Data.Bifunctor import GHC.Driver.Env as Env import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModSummary @@ -209,41 +229,32 @@ import System.IO import Compat.HieAst (enrichHie) import Compat.HieBin -import Compat.HieTypes +import Compat.HieTypes hiding (nodeAnnotations) +import qualified Compat.HieTypes as GHC (nodeAnnotations) import Compat.HieUtils import qualified Data.ByteString as BS import Data.IORef import Data.List (foldl') import qualified Data.Map as Map -import qualified Data.Set as Set - -#if MIN_VERSION_ghc(9,0,0) import qualified Data.Set as S -#endif #if !MIN_VERSION_ghc(8,10,0) import Bag (unitBag) #endif #if MIN_VERSION_ghc(9,2,0) -import GHC.Types.CostCentre -import GHC.Stg.Syntax -import GHC.Types.IPE -import GHC.Stg.Syntax -import GHC.Types.IPE -import GHC.Types.CostCentre -import GHC.Core -import GHC.Builtin.Uniques -import GHC.Runtime.Interpreter -import GHC.StgToByteCode -import GHC.Stg.Pipeline -import GHC.ByteCode.Types -import GHC.Linker.Loader (loadDecls) -import GHC.Data.Maybe -import GHC.CoreToStg -import GHC.Core.Utils -import GHC.Types.Var.Env +import GHC.Builtin.Uniques +import GHC.ByteCode.Types +import GHC.CoreToStg +import GHC.Data.Maybe +import GHC.Linker.Loader (loadDecls) +import GHC.Runtime.Interpreter +import GHC.Stg.Pipeline +import GHC.Stg.Syntax +import GHC.StgToByteCode +import GHC.Types.CostCentre +import GHC.Types.IPE #endif type ModIfaceAnnotation = Annotation @@ -506,11 +517,18 @@ nodeInfo' = nodeInfo -- unhelpfulSpanFS = id #endif -nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a) +sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a) #if MIN_VERSION_ghc(9,0,0) -nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo +sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo #else -nodeInfoFromSource = Just . nodeInfo +sourceNodeInfo = Just . nodeInfo +#endif + +generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a) +#if MIN_VERSION_ghc(9,0,0) +generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo +#else +generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the source #endif data GhcVersion @@ -553,11 +571,31 @@ runPp = const SysTools.runPp #endif -isAnnotationInNodeInfo :: (FastString, FastString) -> NodeInfo a -> Bool +simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a +simpleNodeInfoCompat ctor typ = simpleNodeInfo (coerce ctor) (coerce typ) + +isAnnotationInNodeInfo :: (FastStringCompat, FastStringCompat) -> NodeInfo a -> Bool +isAnnotationInNodeInfo p = S.member p . nodeAnnotations + +nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat) #if MIN_VERSION_ghc(9,2,0) -isAnnotationInNodeInfo (ctor, typ) = Set.member (NodeAnnotation ctor typ) . nodeAnnotations +nodeAnnotations = S.map (\(NodeAnnotation ctor typ) -> (coerce ctor, coerce typ)) . GHC.nodeAnnotations #else -isAnnotationInNodeInfo p = Set.member p . nodeAnnotations +nodeAnnotations = S.map (bimap coerce coerce) . GHC.nodeAnnotations +#endif + +#if MIN_VERSION_ghc(9,2,0) +newtype FastStringCompat = FastStringCompat LexicalFastString +#else +newtype FastStringCompat = FastStringCompat FastString +#endif + deriving (Show, Eq, Ord) + +instance IsString FastStringCompat where +#if MIN_VERSION_ghc(9,2,0) + fromString = FastStringCompat . LexicalFastString . fromString +#else + fromString = FastStringCompat . fromString #endif mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 77d935f8d..d63b82495 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -176,8 +176,8 @@ flag qualifyImportedNames default: True manual: True -flag selectionRange - description: Enable selectionRange plugin +flag codeRange + description: Enable Code Range plugin default: True manual: True @@ -304,10 +304,10 @@ common qualifyImportedNames build-depends: hls-qualify-imported-names-plugin ^>=1.0 cpp-options: -DqualifyImportedNames -common selectionRange - if flag(selectionRange) - build-depends: hls-selection-range-plugin ^>= 1.0 - cpp-options: -DselectionRange +common codeRange + if flag(codeRange) + build-depends: hls-code-range-plugin ^>= 1.0 + cpp-options: -DcodeRange common changeTypeSignature if flag(changeTypeSignature) @@ -369,7 +369,7 @@ executable haskell-language-server , splice , alternateNumberFormat , qualifyImportedNames - , selectionRange + , codeRange , gadt , floskell , fourmolu diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index c5bb881b5..1f10b1cc7 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -218,12 +218,10 @@ fullRange s = Range startPos endPos lastLine = fromIntegral $ length $ T.lines s subRange :: Range -> Range -> Bool -subRange smallRange range = - positionInRange (_start smallRange) range - && positionInRange (_end smallRange) range +subRange smallRange range = _start smallRange >= _start range && _end smallRange <= _end range positionInRange :: Position -> Range -> Bool -positionInRange p (Range sp ep) = sp <= p && p <= ep +positionInRange p (Range sp ep) = sp <= p && p < ep -- Range's end position is exclusive, see https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#range -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index 19a832f16..c6bedfdf2 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -20,6 +20,8 @@ positionInRangeTest = testGroup "positionInRange" positionInRange (Position 1 0) (Range (Position 1 1) (Position 1 6)) @?= False , testCase "single line, in range" $ positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 6)) @?= True + , testCase "single line, at the end" $ + positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 5)) @?= False , testCase "multiline, in range" $ positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) @?= True , testCase "multiline, out of range" $ diff --git a/plugins/hls-selection-range-plugin/LICENSE b/plugins/hls-code-range-plugin/LICENSE similarity index 100% rename from plugins/hls-selection-range-plugin/LICENSE rename to plugins/hls-code-range-plugin/LICENSE diff --git a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal similarity index 68% rename from plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal rename to plugins/hls-code-range-plugin/hls-code-range-plugin.cabal index 1038b6760..e51ad5526 100644 --- a/plugins/hls-selection-range-plugin/hls-selection-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -1,5 +1,5 @@ cabal-version: 2.4 -name: hls-selection-range-plugin +name: hls-code-range-plugin version: 1.0.0.0 synopsis: HLS Plugin to support smart selection range @@ -16,15 +16,16 @@ category: Development build-type: Simple extra-source-files: LICENSE - test/testdata/*.hs - test/testdata/*.yaml - test/testdata/*.txt + test/testdata/selection-range/*.hs + test/testdata/selection-range/*.yaml + test/testdata/selection-range/*.txt library exposed-modules: - Ide.Plugin.SelectionRange + Ide.Plugin.CodeRange + Ide.Plugin.CodeRange.Rules other-modules: - Ide.Plugin.SelectionRange.ASTPreProcess + Ide.Plugin.CodeRange.ASTPreProcess ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 @@ -32,29 +33,40 @@ library , aeson , base >=4.12 && <5 , containers - , ghcide ^>=1.6 || ^>=1.7 - , hls-plugin-api ^>=1.3 || ^>=1.4 - , lsp - , transformers - , mtl - , text + , deepseq , extra + , ghcide ^>=1.6 || ^>=1.7 + , hashable + , hls-plugin-api ^>=1.3 || ^>=1.4 + , lens + , lsp + , mtl , semigroupoids + , text + , transformers + , vector test-suite tests type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs + other-modules: + Ide.Plugin.CodeRangeTest + Ide.Plugin.CodeRange.RulesTest ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base + , bytestring , containers , filepath - , hls-selection-range-plugin + , ghcide ^>=1.6 || ^>=1.7 + , hls-code-range-plugin , hls-test-utils ^>=1.2 || ^>=1.3 + , lens , lsp , lsp-test + , tasty-hunit , text - , bytestring - , lens + , transformers + , vector diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs new file mode 100644 index 000000000..0a48a3467 --- /dev/null +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.CodeRange ( + descriptor + , Log + + -- * Internal + , findPosition + ) where + +import Control.Monad.Except (ExceptT (ExceptT), + runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + maybeToExceptT) +import Data.Either.Extra (maybeToEither) +import Data.Maybe (fromMaybe) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Development.IDE (IdeAction, + IdeState (shakeExtras), + Range (Range), Recorder, + WithPriority, + cmapWithPrio, + runIdeAction, + toNormalizedFilePath', + uriToFilePath') +import Development.IDE.Core.Actions (useE) +import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentPosition, + toCurrentRange) +import Development.IDE.Types.Logger (Pretty (..)) +import Ide.Plugin.CodeRange.Rules (CodeRange (..), + GetCodeRange (..), + codeRangeRule) +import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) +import Ide.PluginUtils (pluginResponse, + positionInRange) +import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Server (LspM) +import Language.LSP.Types (List (List), + NormalizedFilePath, + Position (..), + Range (_start), + ResponseError, + SMethod (STextDocumentSelectionRange), + SelectionRange (..), + SelectionRangeParams (..), + TextDocumentIdentifier (TextDocumentIdentifier), + Uri) +import Prelude hiding (log, span) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + -- TODO @sloorush add folding range + -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) + } + +data Log = LogRules Rules.Log + +instance Pretty Log where + pretty log = case log of + LogRules codeRangeLog -> pretty codeRangeLog + +selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) +selectionRangeHandler ide _ SelectionRangeParams{..} = do + pluginResponse $ do + filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $ + getSelectionRanges filePath positions + pure . List $ selectionRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + + positions :: [Position] + List positions = _positions + +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] +getSelectionRanges file positions = do + (codeRange, positionMapping) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + -- 'positionMapping' should be appied to the input before using them + positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $ + traverse (fromCurrentPosition positionMapping) positions + + let selectionRanges = flip fmap positions' $ \pos -> + -- We need a default selection range if the lookup fails, so that other positions can still have valid results. + let defaultSelectionRange = SelectionRange (Range pos pos) Nothing + in fromMaybe defaultSelectionRange . findPosition pos $ codeRange + + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + traverse (toCurrentSelectionRange positionMapping) selectionRanges + +-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. +findPosition :: Position -> CodeRange -> Maybe SelectionRange +findPosition pos root = go Nothing root + where + -- Helper function for recursion. The range list is built top-down + go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange + go acc node = + if positionInRange pos range + then maybe acc' (go acc') (binarySearchPos children) + -- If all children doesn't contain pos, acc' will be returned. + -- acc' will be Nothing only if we are in the root level. + else Nothing + where + range = _codeRange_range node + children = _codeRange_children node + acc' = Just $ maybe (SelectionRange range Nothing) (SelectionRange range . Just) acc + + binarySearchPos :: Vector CodeRange -> Maybe CodeRange + binarySearchPos v + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + let (left, right) = V.splitAt (V.length v `div` 2) v + startOfRight <- _start . _codeRange_range <$> V.headM right + if pos < startOfRight then binarySearchPos left else binarySearchPos right + +-- | Likes 'toCurrentPosition', but works on 'SelectionRange' +toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange +toCurrentSelectionRange positionMapping SelectionRange{..} = do + newRange <- toCurrentRange positionMapping _range + pure $ SelectionRange { + _range = newRange, + _parent = _parent >>= toCurrentSelectionRange positionMapping + } diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs similarity index 61% rename from plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs rename to plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs index 9fd6ab24c..d44ed3deb 100644 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange/ASTPreProcess.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -1,37 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin.SelectionRange.ASTPreProcess +module Ide.Plugin.CodeRange.ASTPreProcess ( preProcessAST , PreProcessEnv(..) + , isCustomNode + , CustomNodeType(..) ) where -import Control.Monad.Reader (Reader, asks) -import Data.Foldable (find, foldl') -import Data.Functor.Identity (Identity (Identity, runIdentity)) -import Data.List (groupBy) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import Data.Semigroup.Foldable (foldlM1) -import qualified Data.Set as Set -import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl, ValBind), - HieAST (..), Identifier, - IdentifierDetails (identInfo), - NodeInfo (NodeInfo, nodeIdentifiers), - RealSrcSpan, RefMap, Span, - combineRealSrcSpans, - flattenAst, - isAnnotationInNodeInfo, - mkAstNode, nodeInfoFromSource, - realSrcSpanEnd, - realSrcSpanStart) -import Development.IDE.GHC.Compat.Util (FastString) -import Prelude hiding (span) +import Control.Monad.Reader (Reader, asks) +import Data.Foldable +import Data.Functor.Identity (Identity (Identity, runIdentity)) +import Data.List (groupBy) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Semigroup (First (First, getFirst)) +import Data.Semigroup.Foldable (foldlM1) +import qualified Data.Set as Set +import Development.IDE.GHC.Compat hiding (nodeInfo) +import Prelude hiding (span) {-| -Extra arguments for 'preaProcessAST', meant to be used in a 'Reader' context. We use 'Reader' to combine +Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context -} newtype PreProcessEnv a = PreProcessEnv { preProcessEnvRefMap :: RefMap a @@ -52,6 +45,47 @@ If it goes more complex, it may be more appropriate to split different manipulat preProcessAST :: HieAST a -> Reader (PreProcessEnv a) (HieAST a) preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition +{-| +Create a custom node in 'HieAST'. By "custom", we mean this node doesn't actually exist in the original 'HieAST' +provided by GHC, but created to suite the needs of hls-code-range-plugin. +-} +createCustomNode :: CustomNodeType -> NonEmpty (HieAST a) -> HieAST a +createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEmpty.toList children) + where + span' :: RealSrcSpan + span' = runIdentity . foldlM1 (\x y -> Identity (combineRealSrcSpans x y)) . fmap nodeSpan $ children + + customNodeInfo = simpleNodeInfoCompat "HlsCustom" (customNodeTypeToFastString customNodeType) + +isCustomNode :: HieAST a -> Maybe CustomNodeType +isCustomNode node = do + nodeInfo <- generatedNodeInfo node + getFirst <$> foldMap go (nodeAnnotations nodeInfo) + where + go :: (FastStringCompat, FastStringCompat) -> Maybe (First CustomNodeType) + go (k, v) + | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') + | otherwise = Nothing + +data CustomNodeType = + -- | a group of imports + CustomNodeImportsGroup + -- | adjacent type signature and value definition are paired under a custom parent node + | CustomNodeAdjacentSignatureDefinition + deriving (Show, Eq, Ord) + +customNodeTypeMapping :: Map CustomNodeType FastStringCompat +customNodeTypeMapping = Map.fromList + [ (CustomNodeImportsGroup, "Imports") + , (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") + ] + +revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType +revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList $ customNodeTypeMapping + +customNodeTypeToFastString :: CustomNodeType -> FastStringCompat +customNodeTypeToFastString k = fromMaybe "" (customNodeTypeMapping Map.!? k) + {-| Combines adjacent import declarations under a new parent node, so that the user will have an extra step selecting the whole import area while expanding/shrinking the selection range. @@ -67,17 +101,11 @@ mergeImports node = pure $ node { nodeChildren = children } merge :: [HieAST a] -> Maybe (HieAST a) merge [] = Nothing merge [x] = Just x - merge (x:xs) = Just $ createVirtualNode (x NonEmpty.:| xs) + merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) nodeIsImport :: HieAST a -> Bool nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl") -createVirtualNode :: NonEmpty (HieAST a) -> HieAST a -createVirtualNode children = mkAstNode (NodeInfo mempty mempty mempty) span' (NonEmpty.toList children) - where - span' :: RealSrcSpan - span' = runIdentity . foldlM1 (\x y -> Identity (combineRealSrcSpans x y)) . fmap nodeSpan $ children - {-| Combine type signature with variable definition under a new parent node, if the signature is placed right before the definition. This allows the user to have a step selecting both type signature and its accompanying definition. @@ -110,7 +138,7 @@ mergeAdjacentSigDef refMap (n1, n2) = do -- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes. refs <- Map.lookup typeSigId refMap if any (isIdentADef (nodeSpan n2)) refs - then pure . createVirtualNode $ n1 NonEmpty.:| [n2] + then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2] else Nothing where checkAnnotation :: Maybe () @@ -136,7 +164,7 @@ identifierForTypeSig node = nodes = flattenAst node extractIdentifier :: HieAST a -> Maybe Identifier - extractIdentifier node' = nodeInfoFromSource node' >>= + extractIdentifier node' = sourceNodeInfo node' >>= (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail) . Map.toList . nodeIdentifiers) @@ -147,13 +175,13 @@ isIdentADef outerSpan (span, detail) = && isDef where isDef :: Bool - isDef = any isContextInfoDef . Set.toList . identInfo $ detail + isDef = any isContextInfoDef . toList . identInfo $ detail - -- Does the 'ContextInfo' represents a variable/function definition? + -- Determines if the 'ContextInfo' represents a variable/function definition isContextInfoDef :: ContextInfo -> Bool isContextInfoDef ValBind{} = True isContextInfoDef MatchBind = True isContextInfoDef _ = False -isAnnotationInAstNode :: (FastString, FastString) -> HieAST a -> Bool -isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . nodeInfoFromSource +isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool +isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs new file mode 100644 index 000000000..8a573d9eb --- /dev/null +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.CodeRange.Rules + ( CodeRange (..) + , codeRange_range + , codeRange_children + , codeRange_kind + , CodeRangeKind(..) + , GetCodeRange(..) + , codeRangeRule + , Log(..) + + -- * Internal + , removeInterleaving + , simplify + ) where + +import Control.DeepSeq (NFData) +import qualified Control.Lens as Lens +import Control.Monad (foldM) +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.Reader (runReader) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + maybeToExceptT) +import Control.Monad.Trans.Writer.CPS +import Data.Coerce (coerce) +import Data.Data (Typeable) +import Data.Foldable (traverse_) +import Data.Function (on, (&)) +import Data.Hashable +import Data.List (sort) +import qualified Data.Map.Strict as Map +import Data.Vector (Vector) +import qualified Data.Vector as V +import Development.IDE +import Development.IDE.Core.Rules (toIdeResult) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (Annotated, HieAST (..), + HieASTs (getAsts), + ParsedSource, RefMap) +import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) +import GHC.Generics (Generic) +import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), + PreProcessEnv (..), + isCustomNode, + preProcessAST) +import Language.LSP.Types.Lens (HasEnd (end), + HasStart (start)) +import Prelude hiding (log) + +data Log = LogShake Shake.Log + | LogNoAST + | LogFoundInterleaving CodeRange CodeRange + deriving Show + +instance Pretty Log where + pretty log = case log of + LogShake shakeLog -> pretty shakeLog + LogNoAST -> "no HieAst exist for file" + LogFoundInterleaving r1 r2 -> + let prettyRange = pretty . show . _codeRange_range + in "CodeRange interleave: " <> prettyRange r1 <> " & " <> prettyRange r2 + +-- | A tree representing code ranges in a file. This can be useful for features like selection range and folding range +data CodeRange = CodeRange { + -- | Range for current level + _codeRange_range :: !Range, + -- | A vector of children, sorted by their ranges in ascending order. + -- Children are guaranteed not to interleave, but some gaps may exist among them. + _codeRange_children :: !(Vector CodeRange), + -- The kind of current code range + _codeRange_kind :: !CodeRangeKind + } + deriving (Show, Generic, NFData) + +-- | 'CodeKind' represents the kind of a code range +data CodeRangeKind = + -- | ordinary code + CodeKindRegion + -- | the group of imports + | CodeKindImports + -- | a comment + | CodeKindComment + deriving (Show, Generic, NFData) + +Lens.makeLenses ''CodeRange + +instance Eq CodeRange where + (==) = (==) `on` _codeRange_range + +instance Ord CodeRange where + compare :: CodeRange -> CodeRange -> Ordering + compare = compare `on` _codeRange_range + +-- | Construct a 'CodeRange'. A valid CodeRange will be returned in any case. If anything go wrong, +-- a list of warnings will be returned as 'Log' +buildCodeRange :: HieAST a -> RefMap a -> Annotated ParsedSource -> Writer [Log] CodeRange +buildCodeRange ast refMap _ = do + -- We work on 'HieAST', then convert it to 'CodeRange', so that applications such as selection range and folding + -- range don't need to care about 'HieAST' + -- TODO @sloorush actually use 'Annotated ParsedSource' to handle structures not in 'HieAST' properly (for example comments) + let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) + codeRange <- astToCodeRange ast' + pure $ simplify codeRange + +astToCodeRange :: HieAST a -> Writer [Log] CodeRange +astToCodeRange (Node _ sp []) = pure $ CodeRange (realSrcSpanToRange sp) mempty CodeKindRegion +astToCodeRange node@(Node _ sp children) = do + children' <- removeInterleaving . sort =<< traverse astToCodeRange children + let codeKind = if Just CustomNodeImportsGroup == isCustomNode node then CodeKindImports else CodeKindRegion + pure $ CodeRange (realSrcSpanToRange sp) (V.fromList children') codeKind + +-- | Remove interleaving of the list of 'CodeRange's. +removeInterleaving :: [CodeRange] -> Writer [Log] [CodeRange] +removeInterleaving = fmap reverse . foldM go [] + where + -- we want to traverse from left to right (to make the logs easier to read) + go :: [CodeRange] -> CodeRange -> Writer [Log] [CodeRange] + go [] x = pure [x] + go (x1:acc) x2 = do + -- Given that the CodeRange is already sorted on it's Range, and the Ord instance of Range + -- compares it's start position first, the start position must be already in an ascending order. + -- Then, if the end position of a node is larger than it's next neighbour's start position, an interleaving + -- must exist. + -- (Note: LSP Range's end position is exclusive) + x1' <- if x1 Lens.^. codeRange_range . end > x2 Lens.^. codeRange_range . start + then do + -- set x1.end to x2.start + let x1' :: CodeRange = x1 & codeRange_range . end Lens..~ (x2 Lens.^. codeRange_range . start) + tell [LogFoundInterleaving x1 x2] + pure x1' + else pure x1 + pure $ x2:x1':acc + +-- | Remove redundant nodes in 'CodeRange' tree +simplify :: CodeRange -> CodeRange +simplify r = + case onlyChild of + -- If a node has the exact same range as it's parent, and it has no sibling, then it can be removed. + Just onlyChild' -> + if _codeRange_range onlyChild' == curRange + then simplify (r { _codeRange_children = _codeRange_children onlyChild' }) + else withChildrenSimplified + Nothing -> withChildrenSimplified + where + curRange = _codeRange_range r + + onlyChild :: Maybe CodeRange = + let children = _codeRange_children r + in if V.length children == 1 then V.headM children else Nothing + + withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r } + +data GetCodeRange = GetCodeRange + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetCodeRange +instance NFData GetCodeRange + +type instance RuleResult GetCodeRange = CodeRange + +codeRangeRule :: Recorder (WithPriority Log) -> Rules () +codeRangeRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do + -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). + -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations + HAR{hieAst, refMap} <- lift $ use_ GetHieAst file + ast <- maybeToExceptT LogNoAST . MaybeT . pure $ + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + annPS <- lift $ use_ GetAnnotatedParsedSource file + + let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) + traverse_ (logWith recorder Warning) warnings + + pure codeRange + +-- | Handle error in 'Action'. Returns an 'IdeResult' with no value and no diagnostics on error. (but writes log) +handleError :: Recorder (WithPriority msg) -> ExceptT msg Action a -> Action (IdeResult a) +handleError recorder action' = do + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Error msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs new file mode 100644 index 000000000..473d5b7f7 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRange/RulesTest.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRange.RulesTest (testTree) where + +import Control.Monad.Trans.Writer.CPS +import Data.Bifunctor (Bifunctor (first, second)) +import qualified Data.Vector as V +import Ide.Plugin.CodeRange.Rules +import Test.Hls +import Test.Tasty.HUnit + +testTree :: TestTree +testTree = + testGroup "CodeRange.Rules" [ + testGroup "removeInterleaving" $ + let check :: [CodeRange] -> ([CodeRange], [Log]) -> Assertion + check input want = + second (fmap LogEq) (runWriter (removeInterleaving input)) @?= second (fmap LogEq) want + mkNode :: UInt -> UInt -> CodeRange + mkNode startCol endCol = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) [] CodeKindRegion + in [ + testCase "empty list" $ check [] ([], []), + testCase "one" $ check [mkNode 1 5] ([mkNode 1 5], []), + testCase "two, without intersection" $ check [mkNode 1 5, mkNode 5 6] ([mkNode 1 5, mkNode 5 6], []), + testCase "two, with intersection" $ let (x, y) = (mkNode 1 5, mkNode 2 4) + in check [x, y] ([mkNode 1 2, mkNode 2 4], [LogFoundInterleaving x y]), + testCase "three, with intersection" $ let (x, y, z) = (mkNode 1 10, mkNode 2 6, mkNode 4 12) + in check [x, y, z] ([mkNode 1 2, mkNode 2 4, mkNode 4 12], + [LogFoundInterleaving x y, LogFoundInterleaving y z]) + ], + testGroup "simplify" $ + let mkNode :: UInt -> UInt -> V.Vector CodeRange -> CodeRange + mkNode startCol endCol children = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) children CodeKindRegion + in [ + testCase "one level should not change" $ + let codeRange = mkNode 1 5 [] + in codeRange @=? simplify codeRange, + testCase "dedup 3 nested layers" $ + let input = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + ] + ] + want = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + in want @=? simplify input, + testCase "should not dedup node that has multiple children" $ + let input = + mkNode 1 10 [ + mkNode 1 10 [], + mkNode 2 10 [] + ] + in simplify input @?= input, + testCase "dedup simple two layers" $ + let input = mkNode 1 10 [ mkNode 1 10 []] + in simplify input @?= mkNode 1 10 [] + ] + ] + +newtype LogEq = LogEq Log + deriving Show + +instance Eq LogEq where + LogEq (LogShake _) == LogEq (LogShake _) = True + LogEq LogNoAST == LogEq LogNoAST = True + LogEq (LogFoundInterleaving left right) == LogEq (LogFoundInterleaving left' right') = + left == left' && right == right' diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs new file mode 100644 index 000000000..73bebf3a2 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRangeTest (testTree) where + +import qualified Data.Vector as V +import Ide.Plugin.CodeRange +import Ide.Plugin.CodeRange.Rules +import Test.Hls +import Test.Tasty.HUnit + +testTree :: TestTree +testTree = + testGroup "CodeRange" [ + testGroup "findPosition" $ + let check :: Position -> CodeRange -> Maybe SelectionRange -> Assertion + check position codeRange = (findPosition position codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange + mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion + in [ + testCase "not in range" $ check + (Position 10 1) + (mkCodeRange (Position 1 1) (Position 5 10) []) + Nothing, + testCase "in top level range" $ check + (Position 3 8) + (mkCodeRange (Position 1 1) (Position 5 10) []) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in the gap between children, in parent" $ check + (Position 3 6) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 1) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "before all children, in parent" $ check + (Position 1 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in children, in parent" $ check + (Position 2 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 2) (Position 3 6)) $ Just + ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing + ) + ) + ] + ] diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs new file mode 100644 index 000000000..bffc3f716 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Lens hiding (List, (<.>)) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBSChar8 +import Data.String (fromString) +import Development.IDE.Types.Logger (Priority (Debug), + Recorder (Recorder), + WithPriority (WithPriority), + makeDefaultStderrRecorder, + pretty) +import Ide.Plugin.CodeRange (Log, descriptor) +import qualified Ide.Plugin.CodeRange.RulesTest +import qualified Ide.Plugin.CodeRangeTest +import Language.LSP.Types.Lens +import System.FilePath ((<.>), ()) +import Test.Hls + +plugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState +plugin recorder = descriptor recorder "codeRange" + +main :: IO () +main = do + recorder <- contramap (fmap pretty) <$> makeDefaultStderrRecorder Nothing Debug + defaultTestRunner $ + testGroup "Code Range" [ + testGroup "Integration Tests" [ + makeSelectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], + makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] + ], + testGroup "Unit Tests" [ + Ide.Plugin.CodeRangeTest.testTree, + Ide.Plugin.CodeRange.RulesTest.testTree + ] + ] + +makeSelectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree +makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer (plugin recorder) testDataDir $ do + doc <- openDoc (testName <.> "hs") "haskell" + resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) + let res = resp ^. result + pure $ fmap showSelectionRangesForTest res + case res of + Left err -> assertFailure (show err) + Right golden -> pure golden + where + testDataDir :: FilePath + testDataDir = "test" "testdata" "selection-range" + + showSelectionRangesForTest :: List SelectionRange -> ByteString + showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges + + showSelectionRangeForTest :: SelectionRange -> ByteString + showSelectionRangeForTest selectionRange = go True (Just selectionRange) + where + go :: Bool -> Maybe SelectionRange -> ByteString + go _ Nothing = "" + go isFirst (Just (SelectionRange (Range sp ep) parent)) = + (if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent + showPosition :: Position -> ByteString + showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" + showLBS = fromString . show diff --git a/plugins/hls-selection-range-plugin/test/testdata/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt similarity index 100% rename from plugins/hls-selection-range-plugin/test/testdata/Function.golden.txt rename to plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt diff --git a/plugins/hls-selection-range-plugin/test/testdata/Function.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs similarity index 100% rename from plugins/hls-selection-range-plugin/test/testdata/Function.hs rename to plugins/hls-code-range-plugin/test/testdata/selection-range/Function.hs diff --git a/plugins/hls-selection-range-plugin/test/testdata/Import.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt similarity index 100% rename from plugins/hls-selection-range-plugin/test/testdata/Import.golden.txt rename to plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt diff --git a/plugins/hls-selection-range-plugin/test/testdata/Import.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs similarity index 100% rename from plugins/hls-selection-range-plugin/test/testdata/Import.hs rename to plugins/hls-code-range-plugin/test/testdata/selection-range/Import.hs diff --git a/plugins/hls-selection-range-plugin/test/testdata/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml similarity index 100% rename from plugins/hls-selection-range-plugin/test/testdata/hie.yaml rename to plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml diff --git a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs b/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs deleted file mode 100644 index 35e6009be..000000000 --- a/plugins/hls-selection-range-plugin/src/Ide/Plugin/SelectionRange.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Ide.Plugin.SelectionRange (descriptor) where - -import Control.Monad.Except (ExceptT (ExceptT), - runExceptT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (runReader) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), - maybeToExceptT) -import Data.Coerce (coerce) -import Data.Containers.ListUtils (nubOrd) -import Data.Either.Extra (maybeToEither) -import Data.Foldable (find) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Text as T -import Development.IDE (GetHieAst (GetHieAst), - HieAstResult (HAR, hieAst, refMap), - IdeAction, - IdeState (shakeExtras), - Range (Range), - fromNormalizedFilePath, - ideLogger, logDebug, - realSrcSpanToRange, - runIdeAction, - toNormalizedFilePath', - uriToFilePath') -import Development.IDE.Core.Actions (useE) -import Development.IDE.Core.PositionMapping (PositionMapping, - fromCurrentPosition, - toCurrentRange) -import Development.IDE.GHC.Compat (HieAST (Node), Span, - getAsts) -import Development.IDE.GHC.Compat.Util -import Ide.Plugin.SelectionRange.ASTPreProcess (PreProcessEnv (PreProcessEnv), - preProcessAST) -import Ide.PluginUtils (pluginResponse) -import Ide.Types (PluginDescriptor (pluginHandlers), - PluginId, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), - NormalizedFilePath, - Position, - ResponseError, - SMethod (STextDocumentSelectionRange), - SelectionRange (..), - SelectionRangeParams (..), - TextDocumentIdentifier (TextDocumentIdentifier), - Uri) -import Prelude hiding (span) - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - } - -selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler ide _ SelectionRangeParams{..} = do - liftIO $ logDebug logger $ "requesting selection range for file: " <> T.pack (show uri) - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $ - getSelectionRanges filePath positions - pure . List $ selectionRanges - where - uri :: Uri - TextDocumentIdentifier uri = _textDocument - - positions :: [Position] - List positions = _positions - - logger = ideLogger ide - -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] -getSelectionRanges file positions = do - (HAR{hieAst, refMap}, positionMapping) <- maybeToExceptT "fail to get hie ast" $ useE GetHieAst file - -- 'positionMapping' should be applied to the input positions before using them - positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $ - traverse (fromCurrentPosition positionMapping) positions - - ast <- maybeToExceptT "fail to get ast for current file" . MaybeT . pure $ - -- in GHC 9, the 'FastString' in 'HieASTs' is replaced by a newtype wrapper around 'LexicalFastString' - -- so we use 'coerce' to make it work in both GHC 8 and 9 - getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file - - let ast' = runReader (preProcessAST ast) (PreProcessEnv refMap) - let selectionRanges = findSelectionRangesByPositions (astPathsLeafToRoot ast') positions' - - -- 'positionMapping' should be applied to the output ranges before returning them - maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ - traverse (toCurrentSelectionRange positionMapping) selectionRanges - --- | Likes 'toCurrentPosition', but works on 'SelectionRange' -toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange -toCurrentSelectionRange positionMapping SelectionRange{..} = do - newRange <- toCurrentRange positionMapping _range - pure $ SelectionRange { - _range = newRange, - _parent = _parent >>= toCurrentSelectionRange positionMapping - } - --- | Build all paths from ast leaf to root -astPathsLeafToRoot :: HieAST a -> [SelectionRange] -astPathsLeafToRoot = mapMaybe (spansToSelectionRange . nubOrd) . go [[]] - where - go :: [[Span]] -> HieAST a -> [[Span]] - go acc (Node _ span []) = fmap (span:) acc - go acc (Node _ span children) = concatMap (go (fmap (span:) acc)) children - -spansToSelectionRange :: [Span] -> Maybe SelectionRange -spansToSelectionRange [] = Nothing -spansToSelectionRange (span:spans) = Just $ - SelectionRange {_range = realSrcSpanToRange span, _parent = spansToSelectionRange spans} - -{-| -For each position, find the selection range that contains it, without taking each selection range's -parent into account. These selection ranges are un-divisible, representing the leaf nodes in original AST, so they -won't overlap. --} -findSelectionRangesByPositions :: [SelectionRange] -- ^ all possible selection ranges - -> [Position] -- ^ requested positions - -> [SelectionRange] -findSelectionRangesByPositions selectionRanges = fmap findByPosition - {- - Performance Tips: - Doing a linear search from the first selection range for each position is not optimal. - If it becomes too slow for a large file and many positions, you may optimize the implementation. - Assume the number of selection range is n, then the following techniques may be applied: - 1. For each position, we may treat HieAST as a position indexed tree to search it in O(log(n)). - 2. For all positions, a searched position will narrow the search range for other positions. - -} - where - findByPosition :: Position -> SelectionRange - findByPosition p = fromMaybe SelectionRange{_range = Range p p, _parent = Nothing} $ - find (isPositionInSelectionRange p) selectionRanges - - isPositionInSelectionRange :: Position -> SelectionRange -> Bool - isPositionInSelectionRange p SelectionRange{_range} = - let Range sp ep = _range in sp <= p && p <= ep diff --git a/plugins/hls-selection-range-plugin/test/Main.hs b/plugins/hls-selection-range-plugin/test/Main.hs deleted file mode 100644 index ac0335a0f..000000000 --- a/plugins/hls-selection-range-plugin/test/Main.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main (main) where - -import Control.Lens hiding (List, (<.>)) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBSChar8 -import Data.String (fromString) -import Ide.Plugin.SelectionRange (descriptor) -import Language.LSP.Types.Lens -import System.FilePath ((<.>), ()) -import Test.Hls - -plugin :: PluginDescriptor IdeState -plugin = descriptor "selectionRange" - -main :: IO () -main = defaultTestRunner $ - testGroup "Selection Range" - [ goldenTest "Import" [(4, 36), (1, 8)] - , goldenTest "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] - ] - --- | build a golden test for -goldenTest :: TestName -> [(UInt, UInt)] -> TestTree -goldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do - res <- runSessionWithServer plugin testDataDir $ do - doc <- openDoc (testName <.> "hs") "haskell" - resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc - (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) - let res = resp ^. result - pure $ fmap showSelectionRangesForTest res - case res of - Left err -> assertFailure (show err) - Right golden -> pure golden - -testDataDir :: FilePath -testDataDir = "test" "testdata" - -showSelectionRangesForTest :: List SelectionRange -> ByteString -showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges - -showSelectionRangeForTest :: SelectionRange -> ByteString -showSelectionRangeForTest selectionRange = go True (Just selectionRange) - where - go :: Bool -> Maybe SelectionRange -> ByteString - go _ Nothing = "" - go isFirst (Just (SelectionRange (Range sp ep) parent)) = - (if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent - showPosition :: Position -> ByteString - showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" - showLBS = fromString . show diff --git a/stack-lts16.yaml b/stack-lts16.yaml index 69a4f5827..6a057acf0 100644 --- a/stack-lts16.yaml +++ b/stack-lts16.yaml @@ -28,7 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - - ./plugins/hls-selection-range-plugin + - ./plugins/hls-code-range-plugin - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 91a56f4e9..48f834ddc 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -28,7 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin - - ./plugins/hls-selection-range-plugin + - ./plugins/hls-code-range-plugin - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin diff --git a/stack.yaml b/stack.yaml index 78398e688..438328b03 100644 --- a/stack.yaml +++ b/stack.yaml @@ -28,7 +28,7 @@ packages: - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - ./plugins/hls-alternate-number-format-plugin -- ./plugins/hls-selection-range-plugin +- ./plugins/hls-code-range-plugin - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-gadt-plugin