Skip to content

Commit 011d110

Browse files
author
Kobayashi
authored
Fix error in code range (#3229)
* add test case * handle error more properly * add an error type * fix tests * log the bad dependency case
1 parent f6dc206 commit 011d110

File tree

10 files changed

+105
-61
lines changed

10 files changed

+105
-61
lines changed

‎plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs‎

Lines changed: 75 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
1-
{-# LANGUAGE OverloadedStrings #-}
2-
{-# LANGUAGE RecordWildCards #-}
3-
{-# LANGUAGE ScopedTypeVariables #-}
1+
{-# LANGUAGE ExistentialQuantification #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
45

56
module Ide.Plugin.CodeRange (
67
descriptor
@@ -13,27 +14,29 @@ module Ide.Plugin.CodeRange (
1314
) where
1415

1516
import Control.Monad.Except (ExceptT (ExceptT),
16-
runExceptT)
17+
mapExceptT)
1718
import Control.Monad.IO.Class (liftIO)
1819
import Control.Monad.Trans.Maybe (MaybeT (MaybeT),
1920
maybeToExceptT)
2021
import Data.Either.Extra (maybeToEither)
2122
import Data.Maybe (fromMaybe)
2223
import Data.Vector (Vector)
2324
import qualified Data.Vector as V
24-
import Development.IDE (IdeAction,
25+
import Development.IDE (Action, IdeAction,
2526
IdeState (shakeExtras),
2627
Range (Range), Recorder,
2728
WithPriority,
28-
cmapWithPrio,
29+
cmapWithPrio, runAction,
2930
runIdeAction,
3031
toNormalizedFilePath',
31-
uriToFilePath')
32-
import Development.IDE.Core.Actions (useE)
32+
uriToFilePath', use,
33+
useWithStaleFast)
3334
import Development.IDE.Core.PositionMapping (PositionMapping,
3435
fromCurrentPosition,
3536
toCurrentRange)
36-
import Development.IDE.Types.Logger (Pretty (..))
37+
import Development.IDE.Types.Logger (Pretty (..),
38+
Priority (Warning),
39+
logWith)
3740
import Ide.Plugin.CodeRange.Rules (CodeRange (..),
3841
GetCodeRange (..),
3942
codeRangeRule, crkToFrk)
@@ -44,7 +47,7 @@ import Ide.Types (PluginDescriptor (pluginH
4447
PluginId,
4548
defaultPluginDescriptor,
4649
mkPluginHandler)
47-
import Language.LSP.Server (LspM)
50+
import Language.LSP.Server (LspM, LspT)
4851
import Language.LSP.Types (FoldingRange (..),
4952
FoldingRangeParams (..),
5053
List (List),
@@ -61,65 +64,97 @@ import Prelude hiding (log, span)
6164

6265
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
6366
descriptor recorder plId = (defaultPluginDescriptor plId)
64-
{ pluginHandlers = mkPluginHandler STextDocumentSelectionRange selectionRangeHandler
65-
<> mkPluginHandler STextDocumentFoldingRange foldingRangeHandler
67+
{ pluginHandlers = mkPluginHandler STextDocumentSelectionRange (selectionRangeHandler recorder)
68+
<> mkPluginHandler STextDocumentFoldingRange (foldingRangeHandler recorder)
6669
, pluginRules = codeRangeRule (cmapWithPrio LogRules recorder)
6770
}
6871

6972
data Log = LogRules Rules.Log
73+
| forall rule. Show rule => LogBadDependency rule
7074

7175
instance Pretty Log where
7276
pretty log = case log of
7377
LogRules codeRangeLog -> pretty codeRangeLog
78+
LogBadDependency rule -> pretty $ "bad dependency: " <> show rule
7479

75-
foldingRangeHandler :: IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange))
76-
foldingRangeHandler ide _ FoldingRangeParams{..} = do
80+
foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange))
81+
foldingRangeHandler recorder ide _ FoldingRangeParams{..} = do
7782
pluginResponse $ do
7883
filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $
7984
toNormalizedFilePath' <$> uriToFilePath' uri
80-
foldingRanges <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $
85+
foldingRanges <- mapExceptT runAction' $
8186
getFoldingRanges filePath
8287
pure . List $ foldingRanges
83-
where
84-
uri :: Uri
85-
TextDocumentIdentifier uri = _textDocument
88+
where
89+
uri :: Uri
90+
TextDocumentIdentifier uri = _textDocument
8691

87-
getFoldingRanges :: NormalizedFilePath -> ExceptT String IdeAction [FoldingRange]
88-
getFoldingRanges file = do
89-
(codeRange, _) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file
92+
runAction' :: Action (Either FoldingRangeError [FoldingRange]) -> LspT c IO (Either String [FoldingRange])
93+
runAction' action = do
94+
result <- liftIO $ runAction "FoldingRange" ide action
95+
case result of
96+
Left err -> case err of
97+
FoldingRangeBadDependency rule -> do
98+
logWith recorder Warning $ LogBadDependency rule
99+
pure $ Right []
100+
Right list -> pure $ Right list
90101

91-
-- removing first node because it folds the entire file
92-
pure $ drop 1 $ findFoldingRanges codeRange
102+
data FoldingRangeError = forall rule. Show rule => FoldingRangeBadDependency rule
93103

94-
selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange))
95-
selectionRangeHandler ide _ SelectionRangeParams{..} = do
104+
getFoldingRanges :: NormalizedFilePath -> ExceptT FoldingRangeError Action [FoldingRange]
105+
getFoldingRanges file = do
106+
codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use GetCodeRange file
107+
pure $ findFoldingRanges codeRange
108+
109+
selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange))
110+
selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do
96111
pluginResponse $ do
97112
filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $
98113
toNormalizedFilePath' <$> uriToFilePath' uri
99-
selectionRanges <- ExceptT . liftIO . runIdeAction "SelectionRange" (shakeExtras ide) . runExceptT $
100-
getSelectionRanges filePath positions
101-
pure . List $ selectionRanges
114+
fmap List . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions
102115
where
103116
uri :: Uri
104117
TextDocumentIdentifier uri = _textDocument
105118

106119
positions :: [Position]
107120
List positions = _positions
108121

109-
getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT String IdeAction [SelectionRange]
122+
runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange])
123+
runIdeAction' action = do
124+
result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action
125+
case result of
126+
Left err -> case err of
127+
SelectionRangeBadDependency rule -> do
128+
logWith recorder Warning $ LogBadDependency rule
129+
-- This might happen if the HieAst is not ready,
130+
-- so we give it a default value instead of throwing an error
131+
pure $ Right []
132+
SelectionRangeInputPositionMappingFailure -> pure $
133+
Left "failed to apply position mapping to input positions"
134+
SelectionRangeOutputPositionMappingFailure -> pure $
135+
Left "failed to apply position mapping to output positions"
136+
Right list -> pure $ Right list
137+
138+
data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency rule
139+
| SelectionRangeInputPositionMappingFailure
140+
| SelectionRangeOutputPositionMappingFailure
141+
142+
getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange]
110143
getSelectionRanges file positions = do
111-
(codeRange, positionMapping) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file
144+
(codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $
145+
useWithStaleFast GetCodeRange file
112146
-- 'positionMapping' should be appied to the input before using them
113-
positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $
147+
positions' <- maybeToExceptT SelectionRangeInputPositionMappingFailure . MaybeT . pure $
114148
traverse (fromCurrentPosition positionMapping) positions
115149

116150
let selectionRanges = flip fmap positions' $ \pos ->
117-
-- We need a default selection range if the lookup fails, so that other positions can still have valid results.
151+
-- We need a default selection range if the lookup fails,
152+
-- so that other positions can still have valid results.
118153
let defaultSelectionRange = SelectionRange (Range pos pos) Nothing
119154
in fromMaybe defaultSelectionRange . findPosition pos $ codeRange
120155

121156
-- 'positionMapping' should be applied to the output ranges before returning them
122-
maybeToExceptT "fail to apply position mapping to output positions" . MaybeT . pure $
157+
maybeToExceptT SelectionRangeOutputPositionMappingFailure . MaybeT . pure $
123158
traverse (toCurrentSelectionRange positionMapping) selectionRanges
124159

125160
-- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'.
@@ -169,8 +204,13 @@ findPosition pos root = go Nothing root
169204
--
170205
-- Discussion reference: https://github.com/haskell/haskell-language-server/pull/3058#discussion_r973737211
171206
findFoldingRanges :: CodeRange -> [FoldingRange]
172-
findFoldingRanges r@(CodeRange _ children _) =
173-
let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRanges children
207+
findFoldingRanges codeRange =
208+
-- removing the first node because it folds the entire file
209+
drop 1 $ findFoldingRangesRec codeRange
210+
211+
findFoldingRangesRec :: CodeRange -> [FoldingRange]
212+
findFoldingRangesRec r@(CodeRange _ children _) =
213+
let frChildren :: [FoldingRange] = concat $ V.toList $ fmap findFoldingRangesRec children
174214
in case createFoldingRange r of
175215
Just x -> x:frChildren
176216
Nothing -> frChildren

‎plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -188,7 +188,7 @@ handleError recorder action' = do
188188
valueEither <- runExceptT action'
189189
case valueEither of
190190
Left msg -> do
191-
logWith recorder Error msg
191+
logWith recorder Warning msg
192192
pure $ toIdeResult (Left [])
193193
Right value -> pure $ toIdeResult (Right value)
194194

‎plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs‎

Lines changed: 20 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -66,38 +66,37 @@ testTree =
6666
-- General test
6767
testCase "Test General Code Block" $ check
6868
(mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion)
69-
[FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)],
69+
[],
7070

7171
-- Tests for code kind
7272
testCase "Test Code Kind Region" $ check
73-
(mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion)
74-
[FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion)],
73+
(mkCodeRange (Position 1 1) (Position 5 10) [
74+
mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion
75+
] CodeKindRegion)
76+
[FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion)],
7577
testCase "Test Code Kind Comment" $ check
76-
(mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindComment)
77-
[FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeComment)],
78+
(mkCodeRange (Position 1 1) (Position 5 10) [
79+
mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment
80+
] CodeKindRegion)
81+
[FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeComment)],
7882
testCase "Test Code Kind Import" $ check
79-
(mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindImports)
80-
[FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeImports)],
83+
(mkCodeRange (Position 1 1) (Position 5 10) [
84+
mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports
85+
] CodeKindRegion)
86+
[FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeImports)],
8187

8288
-- Test for Code Portions with children
8389
testCase "Test Children" $ check
8490
(mkCodeRange (Position 1 1) (Position 5 10) [
85-
mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion,
91+
mkCodeRange (Position 1 2) (Position 3 6) [
92+
mkCodeRange (Position 1 3) (Position 1 5) [] CodeKindRegion
93+
] CodeKindRegion,
8694
mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion
8795
] CodeKindRegion)
88-
[FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion),
89-
FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion),
90-
FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)],
91-
92-
-- Single line returns [] because single line ranges need not be folded
93-
testCase "Test Single Line" $ check
94-
(mkCodeRange (Position 1 0) (Position 1 15) [] CodeKindRegion)
95-
[FoldingRange 1 (Just 0) 1 (Just 15) (Just FoldingRangeRegion)],
96-
97-
-- MultiLine imports
98-
testCase "MultiLine Imports" $ check
99-
(mkCodeRange (Position 1 0) (Position 5 15) [] CodeKindImports)
100-
[FoldingRange 1 (Just 0) 5 (Just 15) (Just FoldingRangeImports)]
96+
[ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion),
97+
FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeRegion),
98+
FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion)
99+
]
101100
],
102101

103102
testGroup "createFoldingRange" $

‎plugins/hls-code-range-plugin/test/Main.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -27,8 +27,9 @@ main = do
2727
defaultTestRunner $
2828
testGroup "Code Range" [
2929
testGroup "Integration Tests" [
30-
makeSelectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)],
31-
makeSelectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)],
30+
selectionRangeGoldenTest recorder "Import" [(4, 36), (1, 8)],
31+
selectionRangeGoldenTest recorder "Function" [(5, 19), (5, 12), (4, 4), (3, 5)],
32+
selectionRangeGoldenTest recorder "Empty" [(1, 5)],
3233
foldingRangeGoldenTest recorder "Function"
3334
],
3435
testGroup "Unit Tests" [
@@ -37,8 +38,8 @@ main = do
3738
]
3839
]
3940

40-
makeSelectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree
41-
makeSelectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do
41+
selectionRangeGoldenTest :: Recorder (WithPriority Log) -> TestName -> [(UInt, UInt)] -> TestTree
42+
selectionRangeGoldenTest recorder testName positions = goldenGitDiff testName (testDataDir </> testName <.> "golden" <.> "txt") $ do
4243
res <- runSessionWithServer (plugin recorder) testDataDir $ do
4344
doc <- openDoc (testName <.> "hs") "haskell"
4445
resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc

‎plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.golden.txt‎

Whitespace-only changes.

‎plugins/hls-code-range-plugin/test/testdata/folding-range/Empty.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
module Empty where

‎plugins/hls-code-range-plugin/test/testdata/folding-range/hie.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,4 @@ cradle:
22
direct:
33
arguments:
44
- "Function"
5+
- "Empty"

‎plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt‎

Whitespace-only changes.

‎plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
module Empty where

‎plugins/hls-code-range-plugin/test/testdata/selection-range/hie.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,3 +3,4 @@ cradle:
33
arguments:
44
- "Import"
55
- "Function"
6+
- "Empty"

0 commit comments

Comments
 (0)