Fix error in code range

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

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)
 

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

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

@@ -0,0 +1 @@
+module Empty where

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

@@ -2,3 +2,4 @@ cradle:
   direct:
     arguments:
       - "Function"
+      - "Empty"

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

@@ -0,0 +1 @@
+module Empty where

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

@@ -3,3 +3,4 @@ cradle:
     arguments:
       - "Import"
       - "Function"
+      - "Empty"