From 33e11600b65ea88130f6f54512f6d062802e53e8 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 27 Sep 2022 17:30:15 +0000 Subject: [PATCH 1/5] add test case --- plugins/hls-code-range-plugin/test/Main.hs | 9 +++++---- .../test/testdata/selection-range/Empty.golden.txt | 0 .../test/testdata/selection-range/Empty.hs | 1 + .../test/testdata/selection-range/hie.yaml | 1 + 4 files changed, 7 insertions(+), 4 deletions(-) create mode 100644 plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt create mode 100644 plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 1738c41fbe..5ad43de5f2 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -27,8 +27,9 @@ main = do 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)], + selectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)], + selectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)], + selectionRangeGoldenTest recorder "Empty" [(1, 5)], foldingRangeGoldenTest recorder "Function" ], testGroup "Unit Tests" [ @@ -37,8 +38,8 @@ main = do ] ] -makeSelectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree -makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do +selectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree +selectionRangeGoldenTest 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 diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs new file mode 100644 index 0000000000..444d0ce37b --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs @@ -0,0 +1 @@ +module Empty where diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml index bf7a576fe2..dd72f7881e 100644 --- a/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml @@ -3,3 +3,4 @@ cradle: arguments: - "Import" - "Function" + - "Empty" From 4c5c64c5b8c5b4906d48934091ccdebe2da7a150 Mon Sep 17 00:00:00 2001 From: kokobd Date: Tue, 27 Sep 2022 17:31:05 +0000 Subject: [PATCH 2/5] handle error more properly --- .../src/Ide/Plugin/CodeRange.hs | 48 ++++++++++--------- .../src/Ide/Plugin/CodeRange/Rules.hs | 2 +- .../testdata/folding-range/Empty.golden.txt | 0 .../test/testdata/folding-range/Empty.hs | 1 + .../test/testdata/folding-range/hie.yaml | 1 + 5 files changed, 28 insertions(+), 24 deletions(-) create mode 100644 plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt create mode 100644 plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs 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 75fb1eca53..8696e9d64f 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -15,21 +15,22 @@ module Ide.Plugin.CodeRange ( import Control.Monad.Except (ExceptT (ExceptT), runExceptT) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) 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, +import Development.IDE (Action, IdeAction, IdeState (shakeExtras), Range (Range), Recorder, WithPriority, - cmapWithPrio, + cmapWithPrio, runAction, runIdeAction, toNormalizedFilePath', - uriToFilePath') -import Development.IDE.Core.Actions (useE) + uriToFilePath', use, + useWithStaleFast) import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) @@ -77,19 +78,18 @@ 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 $ + foldingRanges <- liftIO . runAction "FoldingRange" ide $ getFoldingRanges filePath pure . List $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument -getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange] +getFoldingRanges :: NormalizedFilePath -> Action [FoldingRange] getFoldingRanges file = do - (codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file - - -- removing first node because it folds the entire file - pure $ drop 1 $ findFoldingRanges codeRange + codeRange <- use GetCodeRange file + -- removing the first node because it folds the entire file + pure $ maybe [] (drop 1 . findFoldingRanges) codeRange selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) selectionRangeHandler ide _ SelectionRangeParams{..} = do @@ -108,19 +108,21 @@ 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 - - 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 + codeRangeResult <- lift $ useWithStaleFast GetCodeRange file + flip (maybe (pure [])) codeRangeResult $ \(codeRange, positionMapping) -> do + -- '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 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 13a2dd3847..311984a403 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 @@ -188,7 +188,7 @@ handleError recorder action' = do valueEither <- runExceptT action' case valueEither of Left msg -> do - logWith recorder Error msg + logWith recorder Warning msg pure $ toIdeResult (Left []) Right value -> pure $ toIdeResult (Right value) diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs new file mode 100644 index 0000000000..444d0ce37b --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs @@ -0,0 +1 @@ +module Empty where diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml index 22a5941a9b..1a62ad9a94 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml @@ -2,3 +2,4 @@ cradle: direct: arguments: - "Function" + - "Empty" From 0820ca9be86032b3e3e2c8de60466dd4bbac1865 Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 28 Sep 2022 16:08:37 +0000 Subject: [PATCH 3/5] add an error type --- .../src/Ide/Plugin/CodeRange.hs | 72 +++++++++++-------- 1 file changed, 44 insertions(+), 28 deletions(-) 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 8696e9d64f..861cf86cfd 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -13,9 +13,8 @@ module Ide.Plugin.CodeRange ( ) where import Control.Monad.Except (ExceptT (ExceptT), - runExceptT) + mapExceptT) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), maybeToExceptT) import Data.Either.Extra (maybeToEither) @@ -45,7 +44,7 @@ import Ide.Types (PluginDescriptor (pluginH PluginId, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Server (LspM) +import Language.LSP.Server (LspM, LspT) import Language.LSP.Types (FoldingRange (..), FoldingRangeParams (..), List (List), @@ -86,19 +85,14 @@ foldingRangeHandler ide _ FoldingRangeParams{..} = do TextDocumentIdentifier uri = _textDocument getFoldingRanges :: NormalizedFilePath -> Action [FoldingRange] -getFoldingRanges file = do - codeRange <- use GetCodeRange file - -- removing the first node because it folds the entire file - pure $ maybe [] (drop 1 . findFoldingRanges) codeRange +getFoldingRanges file = fmap (maybe [] findFoldingRanges) $ use GetCodeRange file 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 + fmap List . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -106,23 +100,40 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do positions :: [Position] List positions = _positions -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange] + runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange]) + runIdeAction' action = do + result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action + pure $ case result of + Left err -> maybe (Right []) Left (showError err) + Right list -> Right list + + showError :: SelectionRangeError -> Maybe String + -- This might happen if the HieAst is not ready, so we give it a default value instead of throwing an error + showError SelectionRangeBadDependency = Nothing + showError SelectionRangeInputPositionMappingFailure = Just "failed to apply position mapping to input positions" + showError SelectionRangeOutputPositionMappingFailure = Just "failed to apply position mapping to output positions" + +data SelectionRangeError = SelectionRangeBadDependency + | SelectionRangeInputPositionMappingFailure + | SelectionRangeOutputPositionMappingFailure + +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange] getSelectionRanges file positions = do - codeRangeResult <- lift $ useWithStaleFast GetCodeRange file - flip (maybe (pure [])) codeRangeResult $ \(codeRange, positionMapping) -> do - -- '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 + (codeRange, positionMapping) <- maybeToExceptT SelectionRangeBadDependency . MaybeT $ + useWithStaleFast GetCodeRange file + -- 'positionMapping' should be appied to the input before using them + positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . 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 SelectionRangeOutputPositionMappingFailure . 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 @@ -171,8 +182,13 @@ findPosition pos root = go Nothing root -- -- Discussion reference: https://github.com/haskell/haskell-language-server/pull/3058#discussion_r973737211 findFoldingRanges :: CodeRange -> [FoldingRange] -findFoldingRanges r@(CodeRange _ children _) = - let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children +findFoldingRanges codeRange = + -- removing the first node because it folds the entire file + drop 1 $ findFoldingRangesRec codeRange + +findFoldingRangesRec :: CodeRange -> [FoldingRange] +findFoldingRangesRec r@(CodeRange _ children _) = + let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRangesRec children in case createFoldingRange r of Just x -> x:frChildren Nothing -> frChildren From d410bae90d693f3206b898e93bfef3b0a506dcbd Mon Sep 17 00:00:00 2001 From: kokobd Date: Wed, 28 Sep 2022 17:09:23 +0000 Subject: [PATCH 4/5] fix tests --- .../test/Ide/Plugin/CodeRangeTest.hs | 41 +++++++++---------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 8495b1ee4d..1157b03930 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -66,38 +66,37 @@ testTree = -- General test testCase "Test General Code Block" $ check (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)], + [], -- Tests for code kind testCase "Test Code Kind Region" $ check - (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)], + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion)], testCase "Test Code Kind Comment" $ check - (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindComment) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeComment)], + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeComment)], testCase "Test Code Kind Import" $ check - (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindImports) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeImports)], + (mkCodeRange (Position 1 1) (Position 5 10) [ + mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports + ] CodeKindRegion) + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeImports)], -- Test for Code Portions with children testCase "Test Children" $ check (mkCodeRange (Position 1 1) (Position 5 10) [ - mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion, + mkCodeRange (Position 1 2) (Position 3 6) [ + mkCodeRange (Position 1 3) (Position 1 5) [] CodeKindRegion + ] CodeKindRegion, mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion ] CodeKindRegion) - [FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion), - FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), - FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)], - - -- Single line returns [] because single line ranges need not be folded - testCase "Test Single Line" $ check - (mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion) - [FoldingRange 1 (Just 0) 1 (Just 15) (Just FoldingRangeRegion)], - - -- MultiLine imports - testCase "MultiLine Imports" $ check - (mkCodeRange (Position 1 0) (Position 5 15) [] CodeKindImports) - [FoldingRange 1 (Just 0) 5 (Just 15) (Just FoldingRangeImports)] + [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), + FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeRegion), + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion) + ] ], testGroup "createFoldingRange" $ From ef09914279acb0c86cda826ea52c0b2ccac0cb72 Mon Sep 17 00:00:00 2001 From: kokobd Date: Thu, 29 Sep 2022 02:52:13 +0000 Subject: [PATCH 5/5] log the bad dependency case --- .../src/Ide/Plugin/CodeRange.hs | 80 ++++++++++++------- 1 file changed, 51 insertions(+), 29 deletions(-) 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 861cf86cfd..1fef9060b1 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin.CodeRange ( descriptor @@ -33,7 +34,9 @@ import Development.IDE (Action, IdeAction, import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) -import Development.IDE.Types.Logger (Pretty (..)) +import Development.IDE.Types.Logger (Pretty (..), + Priority (Warning), + logWith) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), codeRangeRule, crkToFrk) @@ -61,34 +64,50 @@ import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler - <> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler + { pluginHandlers = mkPluginHandler STextDocumentSelectionRange (selectionRangeHandler recorder) + <> mkPluginHandler STextDocumentFoldingRange (foldingRangeHandler recorder) , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } data Log = LogRules Rules.Log + | forall rule. Show rule => LogBadDependency rule instance Pretty Log where pretty log = case log of LogRules codeRangeLog -> pretty codeRangeLog + LogBadDependency rule -> pretty $ "bad dependency: " <> show rule -foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) -foldingRangeHandler ide _ FoldingRangeParams{..} = do +foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) +foldingRangeHandler recorder ide _ FoldingRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ toNormalizedFilePath' <$> uriToFilePath' uri - foldingRanges <- liftIO . runAction "FoldingRange" ide $ + foldingRanges <- mapExceptT runAction' $ getFoldingRanges filePath pure . List $ foldingRanges - where - uri :: Uri - TextDocumentIdentifier uri = _textDocument - -getFoldingRanges :: NormalizedFilePath -> Action [FoldingRange] -getFoldingRanges file = fmap (maybe [] findFoldingRanges) $ use GetCodeRange file + where + uri :: Uri + TextDocumentIdentifier uri = _textDocument -selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) -selectionRangeHandler ide _ SelectionRangeParams{..} = do + runAction' :: Action (Either FoldingRangeError [FoldingRange]) -> LspT c IO (Either String [FoldingRange]) + runAction' action = do + result <- liftIO $ runAction "FoldingRange" ide action + case result of + Left err -> case err of + FoldingRangeBadDependency rule -> do + logWith recorder Warning $ LogBadDependency rule + pure $ Right [] + Right list -> pure $ Right list + +data FoldingRangeError = forall rule. Show rule => FoldingRangeBadDependency rule + +getFoldingRanges :: NormalizedFilePath -> ExceptT FoldingRangeError Action [FoldingRange] +getFoldingRanges file = do + codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use GetCodeRange file + pure $ findFoldingRanges codeRange + +selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) +selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ toNormalizedFilePath' <$> uriToFilePath' uri @@ -103,23 +122,26 @@ selectionRangeHandler ide _ SelectionRangeParams{..} = do runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange]) runIdeAction' action = do result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action - pure $ case result of - Left err -> maybe (Right []) Left (showError err) - Right list -> Right list - - showError :: SelectionRangeError -> Maybe String - -- This might happen if the HieAst is not ready, so we give it a default value instead of throwing an error - showError SelectionRangeBadDependency = Nothing - showError SelectionRangeInputPositionMappingFailure = Just "failed to apply position mapping to input positions" - showError SelectionRangeOutputPositionMappingFailure = Just "failed to apply position mapping to output positions" - -data SelectionRangeError = SelectionRangeBadDependency + case result of + Left err -> case err of + SelectionRangeBadDependency rule -> do + logWith recorder Warning $ LogBadDependency rule + -- This might happen if the HieAst is not ready, + -- so we give it a default value instead of throwing an error + pure $ Right [] + SelectionRangeInputPositionMappingFailure -> pure $ + Left "failed to apply position mapping to input positions" + SelectionRangeOutputPositionMappingFailure -> pure $ + Left "failed to apply position mapping to output positions" + Right list -> pure $ Right list + +data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule | SelectionRangeInputPositionMappingFailure | SelectionRangeOutputPositionMappingFailure getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange] getSelectionRanges file positions = do - (codeRange, positionMapping) <- maybeToExceptT SelectionRangeBadDependency . MaybeT $ + (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $ useWithStaleFast GetCodeRange file -- 'positionMapping' should be appied to the input before using them positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $