diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/hls-code-range-plugin.cabal b/hls-code-range-plugin.cabal new file mode 100644 --- /dev/null +++ b/hls-code-range-plugin.cabal @@ -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 + +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 diff --git a/src/Ide/Plugin/CodeRange.hs b/src/Ide/Plugin/CodeRange.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/CodeRange.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.CodeRange ( + descriptor + , Log + + -- * Internal + , findPosition + ) where + +import Control.Monad.Except (ExceptT (ExceptT), + runExceptT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + maybeToExceptT) +import Data.Either.Extra (maybeToEither) +import Data.Maybe (fromMaybe) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Development.IDE (IdeAction, + IdeState (shakeExtras), + Range (Range), Recorder, + WithPriority, + cmapWithPrio, + runIdeAction, + toNormalizedFilePath', + uriToFilePath') +import Development.IDE.Core.Actions (useE) +import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentPosition, + toCurrentRange) +import Development.IDE.Types.Logger (Pretty (..)) +import Ide.Plugin.CodeRange.Rules (CodeRange (..), + GetCodeRange (..), + codeRangeRule) +import qualified Ide.Plugin.CodeRange.Rules as Rules (Log) +import Ide.PluginUtils (pluginResponse, + positionInRange) +import Ide.Types (PluginDescriptor (pluginHandlers, pluginRules), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Server (LspM) +import Language.LSP.Types (List (List), + NormalizedFilePath, + Position (..), + Range (_start), + ResponseError, + SMethod (STextDocumentSelectionRange), + SelectionRange (..), + SelectionRangeParams (..), + TextDocumentIdentifier (TextDocumentIdentifier), + Uri) +import Prelude hiding (log, span) + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + -- TODO @sloorush add folding range + -- <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) + } + +data Log = LogRules Rules.Log + +instance Pretty Log where + pretty log = case log of + LogRules codeRangeLog -> pretty codeRangeLog + +selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) +selectionRangeHandler ide _ SelectionRangeParams{..} = do + pluginResponse $ do + filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $ + getSelectionRanges filePath positions + pure . List $ selectionRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument + + positions :: [Position] + List positions = _positions + +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] +getSelectionRanges file positions = do + (codeRange, positionMapping) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + -- 'positionMapping' should be appied to the input before using them + positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $ + traverse (fromCurrentPosition positionMapping) positions + + let selectionRanges = flip fmap positions' $ \pos -> + -- We need a default selection range if the lookup fails, so that other positions can still have valid results. + let defaultSelectionRange = SelectionRange (Range pos pos) Nothing + in fromMaybe defaultSelectionRange . findPosition pos $ codeRange + + -- 'positionMapping' should be applied to the output ranges before returning them + maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $ + traverse (toCurrentSelectionRange positionMapping) selectionRanges + +-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. +findPosition :: Position -> CodeRange -> Maybe SelectionRange +findPosition pos root = go Nothing root + where + -- Helper function for recursion. The range list is built top-down + go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange + go acc node = + if positionInRange pos range + then maybe acc' (go acc') (binarySearchPos children) + -- If all children doesn't contain pos, acc' will be returned. + -- acc' will be Nothing only if we are in the root level. + else Nothing + where + range = _codeRange_range node + children = _codeRange_children node + acc' = Just $ maybe (SelectionRange range Nothing) (SelectionRange range . Just) acc + + binarySearchPos :: Vector CodeRange -> Maybe CodeRange + binarySearchPos v + | V.null v = Nothing + | V.length v == 1, + Just r <- V.headM v = if positionInRange pos (_codeRange_range r) then Just r else Nothing + | otherwise = do + let (left, right) = V.splitAt (V.length v `div` 2) v + startOfRight <- _start . _codeRange_range <$> V.headM right + if pos < startOfRight then binarySearchPos left else binarySearchPos right + +-- | Likes 'toCurrentPosition', but works on 'SelectionRange' +toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange +toCurrentSelectionRange positionMapping SelectionRange{..} = do + newRange <- toCurrentRange positionMapping _range + pure $ SelectionRange { + _range = newRange, + _parent = _parent >>= toCurrentSelectionRange positionMapping + } diff --git a/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/src/Ide/Plugin/CodeRange/ASTPreProcess.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -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 diff --git a/src/Ide/Plugin/CodeRange/Rules.hs b/src/Ide/Plugin/CodeRange/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/CodeRange/Rules.hs @@ -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) diff --git a/test/Ide/Plugin/CodeRange/RulesTest.hs b/test/Ide/Plugin/CodeRange/RulesTest.hs new file mode 100644 --- /dev/null +++ b/test/Ide/Plugin/CodeRange/RulesTest.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRange.RulesTest (testTree) where + +import Control.Monad.Trans.Writer.CPS +import Data.Bifunctor (Bifunctor (first, second)) +import qualified Data.Vector as V +import Ide.Plugin.CodeRange.Rules +import Test.Hls +import Test.Tasty.HUnit + +testTree :: TestTree +testTree = + testGroup "CodeRange.Rules" [ + testGroup "removeInterleaving" $ + let check :: [CodeRange] -> ([CodeRange], [Log]) -> Assertion + check input want = + second (fmap LogEq) (runWriter (removeInterleaving input)) @?= second (fmap LogEq) want + mkNode :: UInt -> UInt -> CodeRange + mkNode startCol endCol = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) [] CodeKindRegion + in [ + testCase "empty list" $ check [] ([], []), + testCase "one" $ check [mkNode 1 5] ([mkNode 1 5], []), + testCase "two, without intersection" $ check [mkNode 1 5, mkNode 5 6] ([mkNode 1 5, mkNode 5 6], []), + testCase "two, with intersection" $ let (x, y) = (mkNode 1 5, mkNode 2 4) + in check [x, y] ([mkNode 1 2, mkNode 2 4], [LogFoundInterleaving x y]), + testCase "three, with intersection" $ let (x, y, z) = (mkNode 1 10, mkNode 2 6, mkNode 4 12) + in check [x, y, z] ([mkNode 1 2, mkNode 2 4, mkNode 4 12], + [LogFoundInterleaving x y, LogFoundInterleaving y z]) + ], + testGroup "simplify" $ + let mkNode :: UInt -> UInt -> V.Vector CodeRange -> CodeRange + mkNode startCol endCol children = + CodeRange (Range (Position 1 startCol) (Position 1 endCol)) children CodeKindRegion + in [ + testCase "one level should not change" $ + let codeRange = mkNode 1 5 [] + in codeRange @=? simplify codeRange, + testCase "dedup 3 nested layers" $ + let input = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + ] + ] + want = + mkNode 1 10 [ + mkNode 1 5 [], + mkNode 5 10 [ + mkNode 6 10 [] + ] + ] + in want @=? simplify input, + testCase "should not dedup node that has multiple children" $ + let input = + mkNode 1 10 [ + mkNode 1 10 [], + mkNode 2 10 [] + ] + in simplify input @?= input, + testCase "dedup simple two layers" $ + let input = mkNode 1 10 [ mkNode 1 10 []] + in simplify input @?= mkNode 1 10 [] + ] + ] + +newtype LogEq = LogEq Log + deriving Show + +instance Eq LogEq where + LogEq (LogShake _) == LogEq (LogShake _) = True + LogEq LogNoAST == LogEq LogNoAST = True + LogEq (LogFoundInterleaving left right) == LogEq (LogFoundInterleaving left' right') = + left == left' && right == right' diff --git a/test/Ide/Plugin/CodeRangeTest.hs b/test/Ide/Plugin/CodeRangeTest.hs new file mode 100644 --- /dev/null +++ b/test/Ide/Plugin/CodeRangeTest.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedLists #-} + +module Ide.Plugin.CodeRangeTest (testTree) where + +import qualified Data.Vector as V +import Ide.Plugin.CodeRange +import Ide.Plugin.CodeRange.Rules +import Test.Hls +import Test.Tasty.HUnit + +testTree :: TestTree +testTree = + testGroup "CodeRange" [ + testGroup "findPosition" $ + let check :: Position -> CodeRange -> Maybe SelectionRange -> Assertion + check position codeRange = (findPosition position codeRange @?=) + + mkCodeRange :: Position -> Position -> V.Vector CodeRange -> CodeRange + mkCodeRange start end children = CodeRange (Range start end) children CodeKindRegion + in [ + testCase "not in range" $ check + (Position 10 1) + (mkCodeRange (Position 1 1) (Position 5 10) []) + Nothing, + testCase "in top level range" $ check + (Position 3 8) + (mkCodeRange (Position 1 1) (Position 5 10) []) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in the gap between children, in parent" $ check + (Position 3 6) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 1) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "before all children, in parent" $ check + (Position 1 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing), + testCase "in children, in parent" $ check + (Position 2 1) + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [], + mkCodeRange (Position 3 7) (Position 5 10) [] + ]) + (Just $ SelectionRange (Range (Position 1 2) (Position 3 6)) $ Just + ( SelectionRange (Range (Position 1 1) (Position 5 10)) Nothing + ) + ) + ] + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Lens hiding (List, (<.>)) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBSChar8 +import Data.String (fromString) +import Development.IDE.Types.Logger (Priority (Debug), + Recorder (Recorder), + WithPriority (WithPriority), + makeDefaultStderrRecorder, + pretty) +import Ide.Plugin.CodeRange (Log, descriptor) +import qualified Ide.Plugin.CodeRange.RulesTest +import qualified Ide.Plugin.CodeRangeTest +import Language.LSP.Types.Lens +import System.FilePath ((<.>), ()) +import Test.Hls + +plugin :: Recorder (WithPriority Log) -> PluginDescriptor IdeState +plugin recorder = descriptor recorder "codeRange" + +main :: IO () +main = do + recorder <- contramap (fmap pretty) <$> makeDefaultStderrRecorder Nothing Debug + defaultTestRunner $ + testGroup "Code Range" [ + testGroup "Integration Tests" [ + makeSelectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], + makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)] + ], + testGroup "Unit Tests" [ + Ide.Plugin.CodeRangeTest.testTree, + Ide.Plugin.CodeRange.RulesTest.testTree + ] + ] + +makeSelectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree +makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do + res <- runSessionWithServer (plugin recorder) testDataDir $ do + doc <- openDoc (testName <.> "hs") "haskell" + resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) + let res = resp ^. result + pure $ fmap showSelectionRangesForTest res + case res of + Left err -> assertFailure (show err) + Right golden -> pure golden + where + testDataDir :: FilePath + testDataDir = "test" "testdata" "selection-range" + + showSelectionRangesForTest :: List SelectionRange -> ByteString + showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges + + showSelectionRangeForTest :: SelectionRange -> ByteString + showSelectionRangeForTest selectionRange = go True (Just selectionRange) + where + go :: Bool -> Maybe SelectionRange -> ByteString + go _ Nothing = "" + go isFirst (Just (SelectionRange (Range sp ep) parent)) = + (if isFirst then "" else " => ") <> showPosition sp <> " " <> showPosition ep <> go False parent + showPosition :: Position -> ByteString + showPosition (Position line col) = "(" <> showLBS (line + 1) <> "," <> showLBS (col + 1) <> ")" + showLBS = fromString . show diff --git a/test/testdata/selection-range/Function.golden.txt b/test/testdata/selection-range/Function.golden.txt new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Function.golden.txt @@ -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) diff --git a/test/testdata/selection-range/Function.hs b/test/testdata/selection-range/Function.hs new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Function.hs @@ -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 diff --git a/test/testdata/selection-range/Import.golden.txt b/test/testdata/selection-range/Import.golden.txt new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Import.golden.txt @@ -0,0 +1,2 @@ +(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47) +(1,8) (1,8) diff --git a/test/testdata/selection-range/Import.hs b/test/testdata/selection-range/Import.hs new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/Import.hs @@ -0,0 +1,4 @@ +module MultiPositions where + +import Data.List (find) +import qualified Data.Foldable (foldl, foldl') diff --git a/test/testdata/selection-range/hie.yaml b/test/testdata/selection-range/hie.yaml new file mode 100644 --- /dev/null +++ b/test/testdata/selection-range/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "Import" + - "Function"