mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-08-17 04:20:37 +03:00
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>
This commit is contained in:
Kobayashi
GitHub
parent
b747aa0bd2
commit
445192e21d
2
.github/workflows/hackage.yml
vendored
2
.github/workflows/hackage.yml
vendored
@ -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"
|
||||
|
||||
4
.github/workflows/test.yml
vendored
4
.github/workflows/test.yml
vendored
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
|
||||
|
||||
## Rename
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 :
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -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" $
|
||||
|
||||
@ -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
|
||||
136
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs
Normal file
136
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs
Normal file
@ -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
|
||||
}
|
||||
@ -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
|
||||
195
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
Normal file
195
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
Normal file
@ -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)
|
||||
@ -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'
|
||||
@ -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
|
||||
)
|
||||
)
|
||||
]
|
||||
]
|
||||
66
plugins/hls-code-range-plugin/test/Main.hs
Normal file
66
plugins/hls-code-range-plugin/test/Main.hs
Normal file
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user