mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 16:56:14 +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-refine-imports-plugin", "hls-rename-plugin", "hls-retrie-plugin",
|
||||||
"hls-splice-plugin", "hls-tactics-plugin",
|
"hls-splice-plugin", "hls-tactics-plugin",
|
||||||
"hls-call-hierarchy-plugin", "hls-alternate-number-format-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"]
|
"haskell-language-server"]
|
||||||
ghc: [ "9.0.2"
|
ghc: [ "9.0.2"
|
||||||
, "8.10.7"
|
, "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"
|
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
|
- if: matrix.test
|
||||||
name: Test hls-selection-range-plugin test suite
|
name: Test hls-code-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"
|
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
|
- if: matrix.test
|
||||||
name: Test hls-change-type-signature test suite
|
name: Test hls-change-type-signature test suite
|
||||||
|
|||||||
@ -25,7 +25,7 @@
|
|||||||
/plugins/hls-refine-imports-plugin
|
/plugins/hls-refine-imports-plugin
|
||||||
/plugins/hls-rename-plugin @OliverMadine
|
/plugins/hls-rename-plugin @OliverMadine
|
||||||
/plugins/hls-retrie-plugin @pepeiborra
|
/plugins/hls-retrie-plugin @pepeiborra
|
||||||
/plugins/hls-selection-range-plugin @kokobd
|
/plugins/hls-code-range-plugin @kokobd
|
||||||
/plugins/hls-splice-plugin @konn
|
/plugins/hls-splice-plugin @konn
|
||||||
/plugins/hls-stylish-haskell-plugin @Ailrun
|
/plugins/hls-stylish-haskell-plugin @Ailrun
|
||||||
/plugins/hls-tactics-plugin @isovector
|
/plugins/hls-tactics-plugin @isovector
|
||||||
|
|||||||
@ -26,7 +26,7 @@ packages:
|
|||||||
./plugins/hls-call-hierarchy-plugin
|
./plugins/hls-call-hierarchy-plugin
|
||||||
./plugins/hls-alternate-number-format-plugin
|
./plugins/hls-alternate-number-format-plugin
|
||||||
./plugins/hls-qualify-imported-names-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-change-type-signature-plugin
|
||||||
./plugins/hls-gadt-plugin
|
./plugins/hls-gadt-plugin
|
||||||
|
|
||||||
|
|||||||
@ -317,13 +317,13 @@ Shows module name matching file path, and applies it with a click.
|
|||||||
|
|
||||||
## Selection range
|
## Selection range
|
||||||
|
|
||||||
Provided by: `hls-selection-range-plugin`
|
Provided by: `hls-code-range-plugin`
|
||||||
|
|
||||||
Provides haskell specific
|
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.
|
support.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
## Rename
|
## 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-splice-plugin` | 9.2 |
|
||||||
| `hls-stylish-haskell-plugin` | |
|
| `hls-stylish-haskell-plugin` | |
|
||||||
| `hls-tactics-plugin` | 9.2 |
|
| `hls-tactics-plugin` | 9.2 |
|
||||||
| `hls-selection-range-plugin` | |
|
| `hls-code-range-plugin` | |
|
||||||
| `hls-gadt-plugin` | |
|
| `hls-gadt-plugin` | |
|
||||||
|
|
||||||
### Using deprecated GHC versions
|
### Using deprecated GHC versions
|
||||||
|
|||||||
@ -76,8 +76,8 @@ import qualified Ide.Plugin.Splice as Splice
|
|||||||
import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat
|
import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if selectionRange
|
#if codeRange
|
||||||
import Ide.Plugin.SelectionRange as SelectionRange
|
import qualified Ide.Plugin.CodeRange as CodeRange
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if changeTypeSignature
|
#if changeTypeSignature
|
||||||
@ -190,8 +190,8 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
|
|||||||
#if alternateNumberFormat
|
#if alternateNumberFormat
|
||||||
AlternateNumberFormat.descriptor pluginRecorder :
|
AlternateNumberFormat.descriptor pluginRecorder :
|
||||||
#endif
|
#endif
|
||||||
#if selectionRange
|
#if codeRange
|
||||||
SelectionRange.descriptor "selectionRange" :
|
CodeRange.descriptor pluginRecorder "codeRange" :
|
||||||
#endif
|
#endif
|
||||||
#if changeTypeSignature
|
#if changeTypeSignature
|
||||||
ChangeTypeSignature.descriptor :
|
ChangeTypeSignature.descriptor :
|
||||||
|
|||||||
@ -35,7 +35,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq)
|
|||||||
import Development.IDE.Types.KnownTargets
|
import Development.IDE.Types.KnownTargets
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
import qualified Data.Binary as B
|
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Development.IDE.Import.FindImports (ArtifactsLocation)
|
import Development.IDE.Import.FindImports (ArtifactsLocation)
|
||||||
@ -173,17 +172,17 @@ tmrModSummary :: TcModuleResult -> ModSummary
|
|||||||
tmrModSummary = pm_mod_summary . tmrParsed
|
tmrModSummary = pm_mod_summary . tmrParsed
|
||||||
|
|
||||||
data HiFileResult = HiFileResult
|
data HiFileResult = HiFileResult
|
||||||
{ hirModSummary :: !ModSummary
|
{ hirModSummary :: !ModSummary
|
||||||
-- Bang patterns here are important to stop the result retaining
|
-- Bang patterns here are important to stop the result retaining
|
||||||
-- a reference to a typechecked module
|
-- a reference to a typechecked module
|
||||||
, hirModIface :: !ModIface
|
, hirModIface :: !ModIface
|
||||||
, hirModDetails :: ModDetails
|
, hirModDetails :: ModDetails
|
||||||
-- ^ Populated lazily
|
-- ^ Populated lazily
|
||||||
, hirIfaceFp :: !ByteString
|
, hirIfaceFp :: !ByteString
|
||||||
-- ^ Fingerprint for the ModIface
|
-- ^ Fingerprint for the ModIface
|
||||||
, hirRuntimeModules :: !(ModuleEnv ByteString)
|
, hirRuntimeModules :: !(ModuleEnv ByteString)
|
||||||
-- ^ same as tmrRuntimeModules
|
-- ^ 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)
|
-- ^ If we wrote a core file for this module, then its contents (lazily deserialised)
|
||||||
-- along with its hash
|
-- along with its hash
|
||||||
}
|
}
|
||||||
@ -445,7 +444,7 @@ newtype GhcSessionDeps = GhcSessionDeps_
|
|||||||
|
|
||||||
instance Show GhcSessionDeps where
|
instance Show GhcSessionDeps where
|
||||||
show (GhcSessionDeps_ False) = "GhcSessionDeps"
|
show (GhcSessionDeps_ False) = "GhcSessionDeps"
|
||||||
show (GhcSessionDeps_ True) = "GhcSessionDepsFull"
|
show (GhcSessionDeps_ True) = "GhcSessionDepsFull"
|
||||||
|
|
||||||
pattern GhcSessionDeps :: GhcSessionDeps
|
pattern GhcSessionDeps :: GhcSessionDeps
|
||||||
pattern GhcSessionDeps = GhcSessionDeps_ False
|
pattern GhcSessionDeps = GhcSessionDeps_ False
|
||||||
|
|||||||
@ -32,10 +32,14 @@ module Development.IDE.GHC.Compat(
|
|||||||
myCoreToStgExpr,
|
myCoreToStgExpr,
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
FastStringCompat,
|
||||||
nodeInfo',
|
nodeInfo',
|
||||||
getNodeIds,
|
getNodeIds,
|
||||||
nodeInfoFromSource,
|
sourceNodeInfo,
|
||||||
|
generatedNodeInfo,
|
||||||
|
simpleNodeInfoCompat,
|
||||||
isAnnotationInNodeInfo,
|
isAnnotationInNodeInfo,
|
||||||
|
nodeAnnotations,
|
||||||
mkAstNode,
|
mkAstNode,
|
||||||
combineRealSrcSpans,
|
combineRealSrcSpans,
|
||||||
|
|
||||||
@ -94,7 +98,6 @@ module Development.IDE.GHC.Compat(
|
|||||||
module UniqSet,
|
module UniqSet,
|
||||||
module UniqDFM,
|
module UniqDFM,
|
||||||
getDependentMods,
|
getDependentMods,
|
||||||
diffBinds,
|
|
||||||
flattenBinds,
|
flattenBinds,
|
||||||
mkRnEnv2,
|
mkRnEnv2,
|
||||||
emptyInScopeSet,
|
emptyInScopeSet,
|
||||||
@ -113,6 +116,7 @@ module Development.IDE.GHC.Compat(
|
|||||||
#endif
|
#endif
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.Bifunctor
|
||||||
import Development.IDE.GHC.Compat.Core
|
import Development.IDE.GHC.Compat.Core
|
||||||
import Development.IDE.GHC.Compat.Env
|
import Development.IDE.GHC.Compat.Env
|
||||||
import Development.IDE.GHC.Compat.ExactPrint
|
import Development.IDE.GHC.Compat.ExactPrint
|
||||||
@ -125,58 +129,74 @@ import Development.IDE.GHC.Compat.Units
|
|||||||
import Development.IDE.GHC.Compat.Util
|
import Development.IDE.GHC.Compat.Util
|
||||||
import GHC hiding (HasSrcSpan,
|
import GHC hiding (HasSrcSpan,
|
||||||
ModLocation,
|
ModLocation,
|
||||||
RealSrcSpan, getLoc,
|
RealSrcSpan, exprType,
|
||||||
lookupName, exprType)
|
getLoc, lookupName)
|
||||||
|
|
||||||
|
import Data.Coerce (coerce)
|
||||||
|
import Data.String (IsString (fromString))
|
||||||
|
|
||||||
|
|
||||||
#if MIN_VERSION_ghc(9,0,0)
|
#if MIN_VERSION_ghc(9,0,0)
|
||||||
import GHC.Driver.Hooks (hscCompileCoreExprHook)
|
import GHC.Core.Lint (lintInteractiveExpr)
|
||||||
import GHC.Core (CoreExpr, CoreProgram, Unfolding(..), noUnfolding, flattenBinds)
|
import qualified GHC.Core.Opt.Pipeline as GHC
|
||||||
import qualified GHC.Core.Opt.Pipeline as GHC
|
import GHC.Core.Tidy (tidyExpr)
|
||||||
import GHC.Core.Tidy (tidyExpr)
|
import GHC.CoreToStg.Prep (corePrepPgm)
|
||||||
import GHC.Types.Var.Env (emptyTidyEnv, mkRnEnv2, emptyInScopeSet)
|
import qualified GHC.CoreToStg.Prep as GHC
|
||||||
import qualified GHC.CoreToStg.Prep as GHC
|
import GHC.Driver.Hooks (hscCompileCoreExprHook)
|
||||||
import GHC.CoreToStg.Prep (corePrepPgm)
|
|
||||||
import GHC.Core.Lint (lintInteractiveExpr)
|
|
||||||
#if MIN_VERSION_ghc(9,2,0)
|
#if MIN_VERSION_ghc(9,2,0)
|
||||||
import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable)
|
import GHC.Linker.Loader (loadExpr)
|
||||||
import GHC.Runtime.Context (icInteractiveModule)
|
import GHC.Linker.Types (isObjectLinkable)
|
||||||
import GHC.Unit.Module.Deps (Dependencies(dep_mods))
|
import GHC.Runtime.Context (icInteractiveModule)
|
||||||
import GHC.Linker.Types (isObjectLinkable)
|
import GHC.Unit.Home.ModInfo (HomePackageTable,
|
||||||
import GHC.Linker.Loader (loadExpr)
|
lookupHpt)
|
||||||
|
import GHC.Unit.Module.Deps (Dependencies (dep_mods))
|
||||||
#else
|
#else
|
||||||
import GHC.CoreToByteCode (coreExprToBCOs)
|
import GHC.CoreToByteCode (coreExprToBCOs)
|
||||||
import GHC.Driver.Types (Dependencies(dep_mods), icInteractiveModule, lookupHpt, HomePackageTable)
|
import GHC.Driver.Types (Dependencies (dep_mods),
|
||||||
import GHC.Runtime.Linker (linkExpr)
|
HomePackageTable,
|
||||||
|
icInteractiveModule,
|
||||||
|
lookupHpt)
|
||||||
|
import GHC.Runtime.Linker (linkExpr)
|
||||||
#endif
|
#endif
|
||||||
import GHC.ByteCode.Asm (bcoFreeNames)
|
import GHC.ByteCode.Asm (bcoFreeNames)
|
||||||
import GHC.Types.Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)
|
import GHC.Types.Annotations (AnnTarget (ModuleTarget),
|
||||||
import GHC.Types.Unique.DSet as UniqDSet
|
Annotation (..),
|
||||||
import GHC.Types.Unique.Set as UniqSet
|
extendAnnEnvList)
|
||||||
import GHC.Types.Unique.DFM as UniqDFM
|
import GHC.Types.Unique.DFM as UniqDFM
|
||||||
|
import GHC.Types.Unique.DSet as UniqDSet
|
||||||
|
import GHC.Types.Unique.Set as UniqSet
|
||||||
#else
|
#else
|
||||||
import Hooks (hscCompileCoreExprHook)
|
import Annotations (AnnTarget (ModuleTarget),
|
||||||
import CoreSyn (CoreExpr, flattenBinds, Unfolding(..), noUnfolding)
|
Annotation (..),
|
||||||
import qualified SimplCore as GHC
|
extendAnnEnvList)
|
||||||
import CoreTidy (tidyExpr)
|
import ByteCodeAsm (bcoFreeNames)
|
||||||
import VarEnv (emptyTidyEnv, mkRnEnv2, emptyInScopeSet)
|
import ByteCodeGen (coreExprToBCOs)
|
||||||
import CorePrep (corePrepExpr, corePrepPgm)
|
import CoreLint (lintInteractiveExpr)
|
||||||
import CoreLint (lintInteractiveExpr)
|
import CorePrep (corePrepExpr,
|
||||||
import ByteCodeGen (coreExprToBCOs)
|
corePrepPgm)
|
||||||
import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods))
|
import CoreSyn (CoreExpr,
|
||||||
import Linker (linkExpr)
|
Unfolding (..),
|
||||||
import ByteCodeAsm (bcoFreeNames)
|
flattenBinds,
|
||||||
import Annotations (Annotation(..), AnnTarget(ModuleTarget), extendAnnEnvList)
|
noUnfolding)
|
||||||
import UniqDSet
|
import CoreTidy (tidyExpr)
|
||||||
import UniqSet
|
import Hooks (hscCompileCoreExprHook)
|
||||||
import UniqDFM
|
import Linker (linkExpr)
|
||||||
|
import qualified SimplCore as GHC
|
||||||
|
import UniqDFM
|
||||||
|
import UniqDSet
|
||||||
|
import UniqSet
|
||||||
|
import VarEnv (emptyInScopeSet,
|
||||||
|
emptyTidyEnv, mkRnEnv2)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if MIN_VERSION_ghc(9,0,0)
|
#if MIN_VERSION_ghc(9,0,0)
|
||||||
|
import GHC.Core
|
||||||
import GHC.Data.StringBuffer
|
import GHC.Data.StringBuffer
|
||||||
import GHC.Driver.Session hiding (ExposePackage)
|
import GHC.Driver.Session hiding (ExposePackage)
|
||||||
import qualified GHC.Types.SrcLoc as SrcLoc
|
import qualified GHC.Types.SrcLoc as SrcLoc
|
||||||
|
import GHC.Types.Var.Env
|
||||||
import GHC.Utils.Error
|
import GHC.Utils.Error
|
||||||
#if MIN_VERSION_ghc(9,2,0)
|
#if MIN_VERSION_ghc(9,2,0)
|
||||||
import Data.Bifunctor
|
|
||||||
import GHC.Driver.Env as Env
|
import GHC.Driver.Env as Env
|
||||||
import GHC.Unit.Module.ModIface
|
import GHC.Unit.Module.ModIface
|
||||||
import GHC.Unit.Module.ModSummary
|
import GHC.Unit.Module.ModSummary
|
||||||
@ -209,41 +229,32 @@ import System.IO
|
|||||||
|
|
||||||
import Compat.HieAst (enrichHie)
|
import Compat.HieAst (enrichHie)
|
||||||
import Compat.HieBin
|
import Compat.HieBin
|
||||||
import Compat.HieTypes
|
import Compat.HieTypes hiding (nodeAnnotations)
|
||||||
|
import qualified Compat.HieTypes as GHC (nodeAnnotations)
|
||||||
import Compat.HieUtils
|
import Compat.HieUtils
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import qualified Data.Map as Map
|
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
|
import qualified Data.Set as S
|
||||||
#endif
|
|
||||||
|
|
||||||
#if !MIN_VERSION_ghc(8,10,0)
|
#if !MIN_VERSION_ghc(8,10,0)
|
||||||
import Bag (unitBag)
|
import Bag (unitBag)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#if MIN_VERSION_ghc(9,2,0)
|
#if MIN_VERSION_ghc(9,2,0)
|
||||||
import GHC.Types.CostCentre
|
import GHC.Builtin.Uniques
|
||||||
import GHC.Stg.Syntax
|
import GHC.ByteCode.Types
|
||||||
import GHC.Types.IPE
|
import GHC.CoreToStg
|
||||||
import GHC.Stg.Syntax
|
import GHC.Data.Maybe
|
||||||
import GHC.Types.IPE
|
import GHC.Linker.Loader (loadDecls)
|
||||||
import GHC.Types.CostCentre
|
import GHC.Runtime.Interpreter
|
||||||
import GHC.Core
|
import GHC.Stg.Pipeline
|
||||||
import GHC.Builtin.Uniques
|
import GHC.Stg.Syntax
|
||||||
import GHC.Runtime.Interpreter
|
import GHC.StgToByteCode
|
||||||
import GHC.StgToByteCode
|
import GHC.Types.CostCentre
|
||||||
import GHC.Stg.Pipeline
|
import GHC.Types.IPE
|
||||||
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
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
type ModIfaceAnnotation = Annotation
|
type ModIfaceAnnotation = Annotation
|
||||||
@ -506,11 +517,18 @@ nodeInfo' = nodeInfo
|
|||||||
-- unhelpfulSpanFS = id
|
-- unhelpfulSpanFS = id
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
nodeInfoFromSource :: HieAST a -> Maybe (NodeInfo a)
|
sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a)
|
||||||
#if MIN_VERSION_ghc(9,0,0)
|
#if MIN_VERSION_ghc(9,0,0)
|
||||||
nodeInfoFromSource = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo
|
sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo
|
||||||
#else
|
#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
|
#endif
|
||||||
|
|
||||||
data GhcVersion
|
data GhcVersion
|
||||||
@ -553,11 +571,31 @@ runPp =
|
|||||||
const SysTools.runPp
|
const SysTools.runPp
|
||||||
#endif
|
#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)
|
#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
|
#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
|
#endif
|
||||||
|
|
||||||
mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a
|
mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a
|
||||||
|
|||||||
@ -176,8 +176,8 @@ flag qualifyImportedNames
|
|||||||
default: True
|
default: True
|
||||||
manual: True
|
manual: True
|
||||||
|
|
||||||
flag selectionRange
|
flag codeRange
|
||||||
description: Enable selectionRange plugin
|
description: Enable Code Range plugin
|
||||||
default: True
|
default: True
|
||||||
manual: True
|
manual: True
|
||||||
|
|
||||||
@ -304,10 +304,10 @@ common qualifyImportedNames
|
|||||||
build-depends: hls-qualify-imported-names-plugin ^>=1.0
|
build-depends: hls-qualify-imported-names-plugin ^>=1.0
|
||||||
cpp-options: -DqualifyImportedNames
|
cpp-options: -DqualifyImportedNames
|
||||||
|
|
||||||
common selectionRange
|
common codeRange
|
||||||
if flag(selectionRange)
|
if flag(codeRange)
|
||||||
build-depends: hls-selection-range-plugin ^>= 1.0
|
build-depends: hls-code-range-plugin ^>= 1.0
|
||||||
cpp-options: -DselectionRange
|
cpp-options: -DcodeRange
|
||||||
|
|
||||||
common changeTypeSignature
|
common changeTypeSignature
|
||||||
if flag(changeTypeSignature)
|
if flag(changeTypeSignature)
|
||||||
@ -369,7 +369,7 @@ executable haskell-language-server
|
|||||||
, splice
|
, splice
|
||||||
, alternateNumberFormat
|
, alternateNumberFormat
|
||||||
, qualifyImportedNames
|
, qualifyImportedNames
|
||||||
, selectionRange
|
, codeRange
|
||||||
, gadt
|
, gadt
|
||||||
, floskell
|
, floskell
|
||||||
, fourmolu
|
, fourmolu
|
||||||
|
|||||||
@ -218,12 +218,10 @@ fullRange s = Range startPos endPos
|
|||||||
lastLine = fromIntegral $ length $ T.lines s
|
lastLine = fromIntegral $ length $ T.lines s
|
||||||
|
|
||||||
subRange :: Range -> Range -> Bool
|
subRange :: Range -> Range -> Bool
|
||||||
subRange smallRange range =
|
subRange smallRange range = _start smallRange >= _start range && _end smallRange <= _end range
|
||||||
positionInRange (_start smallRange) range
|
|
||||||
&& positionInRange (_end smallRange) range
|
|
||||||
|
|
||||||
positionInRange :: Position -> Range -> Bool
|
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
|
positionInRange (Position 1 0) (Range (Position 1 1) (Position 1 6)) @?= False
|
||||||
, testCase "single line, in range" $
|
, testCase "single line, in range" $
|
||||||
positionInRange (Position 1 5) (Range (Position 1 1) (Position 1 6)) @?= True
|
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" $
|
, testCase "multiline, in range" $
|
||||||
positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) @?= True
|
positionInRange (Position 3 5) (Range (Position 1 1) (Position 5 6)) @?= True
|
||||||
, testCase "multiline, out of range" $
|
, testCase "multiline, out of range" $
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
cabal-version: 2.4
|
cabal-version: 2.4
|
||||||
name: hls-selection-range-plugin
|
name: hls-code-range-plugin
|
||||||
version: 1.0.0.0
|
version: 1.0.0.0
|
||||||
synopsis:
|
synopsis:
|
||||||
HLS Plugin to support smart selection range
|
HLS Plugin to support smart selection range
|
||||||
@ -16,15 +16,16 @@ category: Development
|
|||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
LICENSE
|
LICENSE
|
||||||
test/testdata/*.hs
|
test/testdata/selection-range/*.hs
|
||||||
test/testdata/*.yaml
|
test/testdata/selection-range/*.yaml
|
||||||
test/testdata/*.txt
|
test/testdata/selection-range/*.txt
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Ide.Plugin.SelectionRange
|
Ide.Plugin.CodeRange
|
||||||
|
Ide.Plugin.CodeRange.Rules
|
||||||
other-modules:
|
other-modules:
|
||||||
Ide.Plugin.SelectionRange.ASTPreProcess
|
Ide.Plugin.CodeRange.ASTPreProcess
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
@ -32,29 +33,40 @@ library
|
|||||||
, aeson
|
, aeson
|
||||||
, base >=4.12 && <5
|
, base >=4.12 && <5
|
||||||
, containers
|
, containers
|
||||||
, ghcide ^>=1.6 || ^>=1.7
|
, deepseq
|
||||||
, hls-plugin-api ^>=1.3 || ^>=1.4
|
|
||||||
, lsp
|
|
||||||
, transformers
|
|
||||||
, mtl
|
|
||||||
, text
|
|
||||||
, extra
|
, extra
|
||||||
|
, ghcide ^>=1.6 || ^>=1.7
|
||||||
|
, hashable
|
||||||
|
, hls-plugin-api ^>=1.3 || ^>=1.4
|
||||||
|
, lens
|
||||||
|
, lsp
|
||||||
|
, mtl
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, vector
|
||||||
|
|
||||||
test-suite tests
|
test-suite tests
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
Ide.Plugin.CodeRangeTest
|
||||||
|
Ide.Plugin.CodeRange.RulesTest
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
, base
|
, base
|
||||||
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
, filepath
|
, filepath
|
||||||
, hls-selection-range-plugin
|
, ghcide ^>=1.6 || ^>=1.7
|
||||||
|
, hls-code-range-plugin
|
||||||
, hls-test-utils ^>=1.2 || ^>=1.3
|
, hls-test-utils ^>=1.2 || ^>=1.3
|
||||||
|
, lens
|
||||||
, lsp
|
, lsp
|
||||||
, lsp-test
|
, lsp-test
|
||||||
|
, tasty-hunit
|
||||||
, text
|
, text
|
||||||
, bytestring
|
, transformers
|
||||||
, lens
|
, 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 OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Ide.Plugin.SelectionRange.ASTPreProcess
|
module Ide.Plugin.CodeRange.ASTPreProcess
|
||||||
( preProcessAST
|
( preProcessAST
|
||||||
, PreProcessEnv(..)
|
, PreProcessEnv(..)
|
||||||
|
, isCustomNode
|
||||||
|
, CustomNodeType(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Reader (Reader, asks)
|
import Control.Monad.Reader (Reader, asks)
|
||||||
import Data.Foldable (find, foldl')
|
import Data.Foldable
|
||||||
import Data.Functor.Identity (Identity (Identity, runIdentity))
|
import Data.Functor.Identity (Identity (Identity, runIdentity))
|
||||||
import Data.List (groupBy)
|
import Data.List (groupBy)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import qualified Data.List.NonEmpty as NonEmpty
|
import qualified Data.List.NonEmpty as NonEmpty
|
||||||
import qualified Data.Map.Strict as Map
|
import Data.Map.Strict (Map)
|
||||||
import Data.Maybe (mapMaybe)
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Semigroup.Foldable (foldlM1)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import qualified Data.Set as Set
|
import Data.Semigroup (First (First, getFirst))
|
||||||
import Development.IDE.GHC.Compat (ContextInfo (MatchBind, TyDecl, ValBind),
|
import Data.Semigroup.Foldable (foldlM1)
|
||||||
HieAST (..), Identifier,
|
import qualified Data.Set as Set
|
||||||
IdentifierDetails (identInfo),
|
import Development.IDE.GHC.Compat hiding (nodeInfo)
|
||||||
NodeInfo (NodeInfo, nodeIdentifiers),
|
import Prelude hiding (span)
|
||||||
RealSrcSpan, RefMap, Span,
|
|
||||||
combineRealSrcSpans,
|
|
||||||
flattenAst,
|
|
||||||
isAnnotationInNodeInfo,
|
|
||||||
mkAstNode, nodeInfoFromSource,
|
|
||||||
realSrcSpanEnd,
|
|
||||||
realSrcSpanStart)
|
|
||||||
import Development.IDE.GHC.Compat.Util (FastString)
|
|
||||||
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
|
newtype PreProcessEnv a = PreProcessEnv
|
||||||
{ preProcessEnvRefMap :: RefMap a
|
{ 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 :: HieAST a -> Reader (PreProcessEnv a) (HieAST a)
|
||||||
preProcessAST node = mergeImports node >>= mergeSignatureWithDefinition
|
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
|
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.
|
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 :: [HieAST a] -> Maybe (HieAST a)
|
||||||
merge [] = Nothing
|
merge [] = Nothing
|
||||||
merge [x] = Just x
|
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 :: HieAST a -> Bool
|
||||||
nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl")
|
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
|
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.
|
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.
|
-- Does that identifier appear in the second AST node as a definition? If so, we combines the two nodes.
|
||||||
refs <- Map.lookup typeSigId refMap
|
refs <- Map.lookup typeSigId refMap
|
||||||
if any (isIdentADef (nodeSpan n2)) refs
|
if any (isIdentADef (nodeSpan n2)) refs
|
||||||
then pure . createVirtualNode $ n1 NonEmpty.:| [n2]
|
then pure . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2]
|
||||||
else Nothing
|
else Nothing
|
||||||
where
|
where
|
||||||
checkAnnotation :: Maybe ()
|
checkAnnotation :: Maybe ()
|
||||||
@ -136,7 +164,7 @@ identifierForTypeSig node =
|
|||||||
nodes = flattenAst node
|
nodes = flattenAst node
|
||||||
|
|
||||||
extractIdentifier :: HieAST a -> Maybe Identifier
|
extractIdentifier :: HieAST a -> Maybe Identifier
|
||||||
extractIdentifier node' = nodeInfoFromSource node' >>=
|
extractIdentifier node' = sourceNodeInfo node' >>=
|
||||||
(fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail)
|
(fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail)
|
||||||
. Map.toList . nodeIdentifiers)
|
. Map.toList . nodeIdentifiers)
|
||||||
|
|
||||||
@ -147,13 +175,13 @@ isIdentADef outerSpan (span, detail) =
|
|||||||
&& isDef
|
&& isDef
|
||||||
where
|
where
|
||||||
isDef :: Bool
|
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 :: ContextInfo -> Bool
|
||||||
isContextInfoDef ValBind{} = True
|
isContextInfoDef ValBind{} = True
|
||||||
isContextInfoDef MatchBind = True
|
isContextInfoDef MatchBind = True
|
||||||
isContextInfoDef _ = False
|
isContextInfoDef _ = False
|
||||||
|
|
||||||
isAnnotationInAstNode :: (FastString, FastString) -> HieAST a -> Bool
|
isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool
|
||||||
isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . nodeInfoFromSource
|
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-module-name-plugin
|
||||||
- ./plugins/hls-ormolu-plugin
|
- ./plugins/hls-ormolu-plugin
|
||||||
- ./plugins/hls-alternate-number-format-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-change-type-signature-plugin
|
||||||
- ./plugins/hls-gadt-plugin
|
- ./plugins/hls-gadt-plugin
|
||||||
|
|
||||||
|
|||||||
@ -28,7 +28,7 @@ packages:
|
|||||||
- ./plugins/hls-module-name-plugin
|
- ./plugins/hls-module-name-plugin
|
||||||
- ./plugins/hls-ormolu-plugin
|
- ./plugins/hls-ormolu-plugin
|
||||||
- ./plugins/hls-alternate-number-format-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-change-type-signature-plugin
|
||||||
- ./plugins/hls-gadt-plugin
|
- ./plugins/hls-gadt-plugin
|
||||||
|
|
||||||
|
|||||||
@ -28,7 +28,7 @@ packages:
|
|||||||
- ./plugins/hls-module-name-plugin
|
- ./plugins/hls-module-name-plugin
|
||||||
- ./plugins/hls-ormolu-plugin
|
- ./plugins/hls-ormolu-plugin
|
||||||
- ./plugins/hls-alternate-number-format-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-change-type-signature-plugin
|
||||||
- ./plugins/hls-gadt-plugin
|
- ./plugins/hls-gadt-plugin
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user