From e6a2b5ca3e8232bc082ce84d22545a5bd462a2ff Mon Sep 17 00:00:00 2001 From: sloorush Date: Fri, 12 Aug 2022 16:14:37 +0530 Subject: [PATCH] format: run formatter and add comments --- hls-plugin-api/src/Ide/Plugin/Config.hs | 2 +- .../src/Ide/Plugin/CodeRange.hs | 165 ++++++++------- .../src/Ide/Plugin/CodeRange/ASTPreProcess.hs | 182 ++++++++-------- .../src/Ide/Plugin/CodeRange/Rules.hs | 195 +++++++++--------- .../src/Ide/Plugin/Eval/Config.hs | 4 +- 5 files changed, 284 insertions(+), 264 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index e7cbb5ccdb..13f33278a8 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -110,7 +110,7 @@ data PluginConfig = , plcCompletionOn :: !Bool , plcRenameOn :: !Bool , plcSelectionRangeOn :: !Bool - , plcFoldingRangeOn :: !Bool + , plcFoldingRangeOn :: !Bool , plcConfig :: !A.Object } deriving (Show,Eq) diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index ca20e1c01f..3e2512658c 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Ide.Plugin.CodeRange ( - descriptor - , Log +module Ide.Plugin.CodeRange + ( descriptor, + Log, -- * Internal - , findPosition - ) where + findPosition, + ) +where import Control.Monad.Except (ExceptT (ExceptT), runExceptT) @@ -16,7 +17,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe (fromMaybe) import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE (IdeAction, @@ -43,62 +44,67 @@ import Ide.Types (PluginDescriptor (pluginH defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Server (LspM) -import Language.LSP.Types (List (List), +import Language.LSP.Types (FoldingRange (..), + FoldingRangeParams (..), + List (List), NormalizedFilePath, Position (..), Range (_start), ResponseError, - SMethod (STextDocumentSelectionRange, STextDocumentFoldingRange), + SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), - FoldingRange (..), - FoldingRangeParams(..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri - ) + Uri) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler - , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) +descriptor recorder plId = + (defaultPluginDescriptor plId) + { pluginHandlers = + mkPluginHandler STextDocumentSelectionRange selectionRangeHandler + <> 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 + pretty log = case log of + LogRules codeRangeLog -> pretty codeRangeLog foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler ide _ FoldingRangeParams{..} = do - pluginResponse $ do - filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ - toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ - getFoldingRanges filePath - pure . List $ foldingRanges - where - uri :: Uri - TextDocumentIdentifier uri = _textDocument +foldingRangeHandler ide _ FoldingRangeParams {..} = do + pluginResponse $ do + filePath <- + ExceptT . pure . maybeToEither "fail to convert uri to file path" $ + toNormalizedFilePath' <$> uriToFilePath' uri + foldingRanges <- + ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $ + getFoldingRanges filePath + pure . List $ foldingRanges + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] getFoldingRanges file = do - (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file + (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - let foldingRanges = findFoldingRanges codeRange + let foldingRanges = findFoldingRanges codeRange - maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) + maybeToExceptT "Fail to generate folding range" (MaybeT . pure $ Just foldingRanges) 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 +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 @@ -108,19 +114,20 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do 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 + (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 + 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 + -- '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 @@ -129,11 +136,11 @@ findPosition pos root = go Nothing root -- Helper function for recursion. The range list is built top-down go :: Maybe SelectionRange -> CodeRange -> Maybe SelectionRange go acc node = - if positionInRange pos range + if positionInRange pos range then maybe acc' (go acc') (binarySearchPos children) - -- If all children doesn't contain pos, acc' will be returned. + else -- 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 + Nothing where range = _codeRange_range node children = _codeRange_children node @@ -141,42 +148,46 @@ findPosition pos root = go Nothing root 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 - + | 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 + +-- | Traverses through the code range and children to a folding ranges findFoldingRanges :: CodeRange -> [FoldingRange] findFoldingRanges r@(CodeRange _ children _) = let frRoot :: [FoldingRange] = case createFoldingRange r of - Just x -> [x] + Just x -> [x] Nothing -> [] frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children in frRoot ++ frChildren +-- | Parses code range to folding range createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange node1 = do - let range = _codeRange_range node1 - let Range startPos endPos = range - let Position lineStart _= startPos - let Position lineEnd _ = endPos - let codeRangeKind = _codeRange_kind node1 + let range = _codeRange_range node1 + let Range startPos endPos = range + let Position lineStart _ = startPos + let Position lineEnd _ = endPos + let codeRangeKind = _codeRange_kind node1 - let frk = crkToFrk codeRangeKind + let frk = crkToFrk codeRangeKind - case frk of - Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) - Nothing -> Nothing + case frk of + Just _ -> Just (FoldingRange lineStart Nothing lineEnd Nothing frk) + Nothing -> Nothing -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange -toCurrentSelectionRange positionMapping SelectionRange{..} = do - newRange <- toCurrentRange positionMapping _range - pure $ SelectionRange { - _range = newRange, +toCurrentSelectionRange positionMapping SelectionRange {..} = do + newRange <- toCurrentRange positionMapping _range + pure $ + SelectionRange + { _range = newRange, _parent = _parent >>= toCurrentSelectionRange positionMapping - } + } diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs index d44ed3debd..2df7b8b7f5 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -2,11 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange.ASTPreProcess - ( preProcessAST - , PreProcessEnv(..) - , isCustomNode - , CustomNodeType(..) - ) where + ( preProcessAST, + PreProcessEnv (..), + isCustomNode, + CustomNodeType (..), + ) +where import Control.Monad.Reader (Reader, asks) import Data.Foldable @@ -23,32 +24,29 @@ 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 --} +-- | +-- Extra arguments for 'preProcessAST'. It's expected to be used in a 'Reader' context newtype PreProcessEnv a = PreProcessEnv - { preProcessEnvRefMap :: RefMap a - } + { 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. --} +-- | +-- 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. --} +-- | +-- 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 @@ -59,25 +57,26 @@ createCustomNode customNodeType children = mkAstNode customNodeInfo span' (NonEm isCustomNode :: HieAST a -> Maybe CustomNodeType isCustomNode node = do - nodeInfo <- generatedNodeInfo node - getFirst <$> foldMap go (nodeAnnotations nodeInfo) + 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 + | k == "HlsCustom", Just v' <- revCustomNodeTypeMapping Map.!? v = Just (First v') + | otherwise = Nothing -data CustomNodeType = - -- | a group of imports +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) + | -- | 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") +customNodeTypeMapping = + Map.fromList + [ (CustomNodeImportsGroup, "Imports"), + (CustomNodeAdjacentSignatureDefinition, "AdjacentSignatureDefinition") ] revCustomNodeTypeMapping :: Map FastStringCompat CustomNodeType @@ -86,44 +85,44 @@ revCustomNodeTypeMapping = Map.fromList . fmap (\(k, v) -> (v, k)) . Map.toList 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. --} +-- | +-- 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 } +mergeImports node = pure $ node {nodeChildren = children} where children :: [HieAST a] - children = mapMaybe merge + children = + mapMaybe merge . groupBy (\x y -> nodeIsImport x && nodeIsImport y) - . nodeChildren $ node + . nodeChildren + $ node merge :: [HieAST a] -> Maybe (HieAST a) - merge [] = Nothing - merge [x] = Just x - merge (x:xs) = Just $ createCustomNode CustomNodeImportsGroup (x NonEmpty.:| xs) + 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. --} +-- | +-- 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' } + 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 + 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. @@ -131,47 +130,52 @@ mergeSignatureWithDefinition node = do -- 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 + -- 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. --} + 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 + {- + 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) + 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 + realSrcSpanStart span >= realSrcSpanStart outerSpan + && realSrcSpanEnd span <= realSrcSpanEnd outerSpan && isDef where isDef :: Bool @@ -179,9 +183,9 @@ isIdentADef outerSpan (span, detail) = -- Determines if the 'ContextInfo' represents a variable/function definition isContextInfoDef :: ContextInfo -> Bool - isContextInfoDef ValBind{} = True - isContextInfoDef MatchBind = True - isContextInfoDef _ = False + isContextInfoDef ValBind {} = True + isContextInfoDef MatchBind = True + isContextInfoDef _ = False isAnnotationInAstNode :: (FastStringCompat, FastStringCompat) -> HieAST a -> Bool isAnnotationInAstNode p = maybe False (isAnnotationInNodeInfo p) . sourceNodeInfo diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index c52f796b72..f2efa51003 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -9,20 +9,21 @@ {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.CodeRange.Rules - ( CodeRange (..) - , codeRange_range - , codeRange_children - , codeRange_kind - , CodeRangeKind(..) - , GetCodeRange(..) - , codeRangeRule - , Log(..) + ( CodeRange (..), + codeRange_range, + codeRange_children, + codeRange_kind, + CodeRangeKind (..), + GetCodeRange (..), + codeRangeRule, + Log (..), -- * Internal - , removeInterleaving - , simplify - , crkToFrk - ) where + removeInterleaving, + simplify, + crkToFrk, + ) +where import Control.DeepSeq (NFData) import qualified Control.Lens as Lens @@ -55,72 +56,73 @@ import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), PreProcessEnv (..), isCustomNode, preProcessAST) +import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) import Language.LSP.Types.Lens (HasEnd (end), HasStart (start)) import Prelude hiding (log) -import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) -data Log = LogShake Shake.Log - | LogNoAST - | LogFoundInterleaving CodeRange CodeRange - deriving Show +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 + 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, +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), + _codeRange_children :: !(Vector CodeRange), -- The kind of current code range - _codeRange_kind :: !CodeRangeKind - } - deriving (Show, Generic, NFData) + _codeRange_kind :: !CodeRangeKind + } + deriving (Show, Generic, NFData) -- | 'CodeKind' represents the kind of a code range -data CodeRangeKind = - -- | ordinary code +data CodeRangeKind + = -- | ordinary code CodeKindRegion - -- | the group of imports - | CodeKindImports - -- | a comment - | CodeKindComment - deriving (Show, Eq, Generic, NFData) + | -- | the group of imports + CodeKindImports + | -- | a comment + CodeKindComment + deriving (Show, Eq, Generic, NFData) Lens.makeLenses ''CodeRange instance Eq CodeRange where - (==) = (==) `on` _codeRange_range + (==) = (==) `on` _codeRange_range instance Ord CodeRange where - compare :: CodeRange -> CodeRange -> Ordering - compare = compare `on` _codeRange_range + 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 + -- 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 + 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] @@ -129,77 +131,80 @@ removeInterleaving = fmap reverse . foldM go [] -- 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 + 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 + 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 + 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 } + withChildrenSimplified = r {_codeRange_children = simplify <$> _codeRange_children r} data GetCodeRange = GetCodeRange - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Typeable, Generic) instance Hashable GetCodeRange -instance NFData 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 + 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 + let (codeRange, warnings) = runWriter (buildCodeRange ast refMap annPS) + traverse_ (logWith recorder Warning) warnings - pure codeRange + 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) + valueEither <- runExceptT action' + case valueEither of + Left msg -> do + logWith recorder Error msg + pure $ toIdeResult (Left []) + Right value -> pure $ toIdeResult (Right value) -- | Maps type CodeRangeKind to FoldingRangeKind crkToFrk :: CodeRangeKind -> Maybe FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> Just FoldingRangeComment - CodeKindImports -> Just FoldingRangeImports - CodeKindRegion -> Just FoldingRangeRegion - _ -> Nothing \ No newline at end of file + CodeKindComment -> Just FoldingRangeComment + CodeKindImports -> Just FoldingRangeImports + CodeKindRegion -> Just FoldingRangeRegion + _ -> Nothing diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs index ca7b0cca9b..8ff948ba77 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs @@ -15,8 +15,8 @@ import Language.LSP.Server (MonadLsp) -- | The Eval plugin configuration. (see 'properties') data EvalConfig = EvalConfig - { eval_cfg_diff :: Bool - , eval_cfg_exception :: Bool + { eval_cfg_diff :: Bool + , eval_cfg_exception :: Bool } deriving (Eq, Ord, Show)