hls-code-range-plugin (empty) → 1.0.0.0
raw patch · 13 files changed
+1017/−0 lines, 13 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, deepseq, extra, filepath, ghcide, hashable, hls-code-range-plugin, hls-plugin-api, hls-test-utils, lens, lsp, lsp-test, mtl, semigroupoids, tasty-hunit, text, transformers, vector
Files
- LICENSE +201/−0
- hls-code-range-plugin.cabal +72/−0
- src/Ide/Plugin/CodeRange.hs +136/−0
- src/Ide/Plugin/CodeRange/ASTPreProcess.hs +187/−0
- src/Ide/Plugin/CodeRange/Rules.hs +192/−0
- test/Ide/Plugin/CodeRange/RulesTest.hs +80/−0
- test/Ide/Plugin/CodeRangeTest.hs +54/−0
- test/Main.hs +66/−0
- test/testdata/selection-range/Function.golden.txt +4/−0
- test/testdata/selection-range/Function.hs +14/−0
- test/testdata/selection-range/Import.golden.txt +2/−0
- test/testdata/selection-range/Import.hs +4/−0
- test/testdata/selection-range/hie.yaml +5/−0
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ hls-code-range-plugin.cabal view
@@ -0,0 +1,72 @@+cabal-version: 2.4+name: hls-code-range-plugin+version: 1.0.0.0+synopsis:+ HLS Plugin to support smart selection range++description:+ Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>++license: Apache-2.0+license-file: LICENSE+author: kokobd+maintainer: kokobd++category: Development+build-type: Simple+extra-source-files:+ LICENSE+ test/testdata/selection-range/*.hs+ test/testdata/selection-range/*.yaml+ test/testdata/selection-range/*.txt++library+ exposed-modules:+ Ide.Plugin.CodeRange+ Ide.Plugin.CodeRange.Rules+ other-modules:+ Ide.Plugin.CodeRange.ASTPreProcess+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010+ build-depends:+ , aeson+ , base >=4.12 && <5+ , containers+ , deepseq+ , extra+ , ghcide ^>=1.8+ , hashable+ , hls-plugin-api ^>=1.5+ , 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+ , ghcide ^>=1.8+ , hls-code-range-plugin+ , hls-test-utils ^>=1.4+ , lens+ , lsp+ , lsp-test+ , tasty-hunit+ , text+ , transformers+ , vector
+ src/Ide/Plugin/CodeRange.hs view
@@ -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+ }
+ src/Ide/Plugin/CodeRange/ASTPreProcess.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Ide.Plugin.CodeRange.ASTPreProcess+ ( preProcessAST+ , PreProcessEnv(..)+ , isCustomNode+ , CustomNodeType(..)+ ) where++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 'preProcessAST'. It's expected to be used in a 'Reader' context+-}+newtype PreProcessEnv a = PreProcessEnv+ { preProcessEnvRefMap :: RefMap a+ }++{-|+Before converting the HieAST to selection range, we need to run some passes on it. Each pass potentially modifies+the AST to handle some special cases.++'preProcessAST' combines the passes. Refer to 'mergeImports' or 'mergeSignatureWithDefinition' as+a concrete example example.++Adding another manipulation to the AST is simple, just implement a function of type+`HieAST a -> Reader (PreProcessEnv a) (HieAST a)`, and append it to 'preProcessAST' with `>>=`.++If it goes more complex, it may be more appropriate to split different manipulations to different modules.+-}+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.+-}+mergeImports :: forall a. HieAST a -> Reader (PreProcessEnv a) (HieAST a)+mergeImports node = pure $ node { nodeChildren = children }+ where+ children :: [HieAST a]+ children = mapMaybe merge+ . groupBy (\x y -> nodeIsImport x && nodeIsImport y)+ . nodeChildren $ node++ merge :: [HieAST a] -> Maybe (HieAST a)+ merge [] = Nothing+ merge [x] = Just x+ merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs)++nodeIsImport :: HieAST a -> Bool+nodeIsImport = isAnnotationInAstNode ("ImportDecl", "ImportDecl")++{-|+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.+-}+mergeSignatureWithDefinition :: HieAST a -> Reader (PreProcessEnv a) (HieAST a)+mergeSignatureWithDefinition node = do+ refMap <- asks preProcessEnvRefMap+ -- Do this recursively for children, so that non top level functions can be handled.+ children' <- traverse mergeSignatureWithDefinition (nodeChildren node)+ pure $ node { nodeChildren = reverse $ foldl' (go refMap) [] children' }+ where+ -- For every two adjacent nodes, we try to combine them into one.+ go :: RefMap a -> [HieAST a] -> HieAST a -> [HieAST a]+ go _ [] node' = [node']+ go refMap (prev:others) node' =+ case mergeAdjacentSigDef refMap (prev, node') of+ Nothing -> node':prev:others+ Just comb -> comb:others++-- | Merge adjacent type signature and variable/function definition, if the type signature belongs to that variable or+-- function.+--+-- The implementation potentially has some corner cases not handled properly.+mergeAdjacentSigDef :: RefMap a -> (HieAST a, HieAST a) -> Maybe (HieAST a)+mergeAdjacentSigDef refMap (n1, n2) = do+ -- Let's check the node's annotation. There should be a function binding following its type signature.+ checkAnnotation+ -- Find the identifier of the type signature.+ typeSigId <- identifierForTypeSig n1+ -- 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 . createCustomNode CustomNodeAdjacentSignatureDefinition $ n1 NonEmpty.:| [n2]+ else Nothing+ where+ checkAnnotation :: Maybe ()+ checkAnnotation =+ if ("TypeSig", "Sig") `isAnnotationInAstNode` n1 &&+ (("FunBind", "HsBindLR") `isAnnotationInAstNode` n2 || ("VarBind", "HsBindLR") `isAnnotationInAstNode` n2)+ then Just ()+ else Nothing++{-|+Given the AST node of a type signature, tries to find the identifier of it.+-}+identifierForTypeSig :: forall a. HieAST a -> Maybe Identifier+identifierForTypeSig node =+ {-+ It seems that the identifier lives in one of the children, so we search for the first 'TyDecl' node in+ its children recursively.+ -}+ case mapMaybe extractIdentifier nodes of+ [] -> Nothing+ (ident:_) -> Just ident+ where+ nodes = flattenAst node++ extractIdentifier :: HieAST a -> Maybe Identifier+ extractIdentifier node' = sourceNodeInfo node' >>=+ (fmap fst . find (\(_, detail) -> TyDecl `Set.member` identInfo detail)+ . Map.toList . nodeIdentifiers)++-- | Determines if the given occurence of an identifier is a function/variable definition in the outer span+isIdentADef :: Span -> (Span, IdentifierDetails a) -> Bool+isIdentADef outerSpan (span, detail) =+ realSrcSpanStart span >= realSrcSpanStart outerSpan && realSrcSpanEnd span <= realSrcSpanEnd outerSpan+ && isDef+ where+ isDef :: Bool+ isDef = any isContextInfoDef . toList . identInfo $ detail++ -- Determines if the 'ContextInfo' represents a variable/function definition+ isContextInfoDef :: ContextInfo -> Bool+ isContextInfoDef ValBind{} = True+ isContextInfoDef MatchBind = True+ isContextInfoDef _ = False++isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool+isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo
+ src/Ide/Plugin/CodeRange/Rules.hs view
@@ -0,0 +1,192 @@+{-# 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 (HieAST (..),+ HieASTs (getAsts),+ RefMap)+import Development.IDE.GHC.Compat.Util+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 -> 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+ let (codeRange, warnings) = runWriter (buildCodeRange ast refMap)+ 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)
+ test/Ide/Plugin/CodeRange/RulesTest.hs view
@@ -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'
+ test/Ide/Plugin/CodeRangeTest.hs view
@@ -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+ )+ )+ ]+ ]
+ test/Main.hs view
@@ -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
+ test/testdata/selection-range/Function.golden.txt view
@@ -0,0 +1,4 @@+(5,16) (5,20) => (5,16) (5,40) => (5,14) (11,20) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(5,12) (5,13) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(4,1) (4,9) => (4,1) (4,29) => (4,1) (11,20) => (3,1) (11,20) => (3,1) (14,15)+(3,1) (3,9) => (3,1) (3,61) => (3,1) (11,20) => (3,1) (14,15)
+ test/testdata/selection-range/Function.hs view
@@ -0,0 +1,14 @@+module FuncMultiMatch where++someFunc :: Integral a => a -> String -> Maybe (Int, String)+someFunc _ "magic" = Nothing+someFunc x y = Just (fromIntegral x, y)+ where+ go :: Int -> Int+ go 0 = -1+ go x = x + 1++ hi = "greeting"++otherFunc :: String -> String+otherFunc = id
+ test/testdata/selection-range/Import.golden.txt view
@@ -0,0 +1,2 @@+(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47)+(1,8) (1,8)
+ test/testdata/selection-range/Import.hs view
@@ -0,0 +1,4 @@+module MultiPositions where++import Data.List (find)+import qualified Data.Foldable (foldl, foldl')
+ test/testdata/selection-range/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+ direct:+ arguments:+ - "Import"+ - "Function"