Fix error in code range

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

@@ -13,23 +13,23 @@ module Ide.Plugin.CodeRange (
     ) where
 
 import           Control.Monad.Except                 (ExceptT (ExceptT),
-                                                       runExceptT)
+                                                       mapExceptT)
 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,
+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)
@@ -44,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),
@@ -77,49 +77,62 @@ 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 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
+getFoldingRanges :: NormalizedFilePath -> Action [FoldingRange]
+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
 
     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
-    (codeRange, positionMapping) <- maybeToExceptT "fail to get code range" $ useE GetCodeRange file
+    (codeRange, positionMapping) <- maybeToExceptT SelectionRangeBadDependency . MaybeT $
+        useWithStaleFast GetCodeRange file
     -- 'positionMapping' should be appied to the input before using them
-    positions' <- maybeToExceptT "fail to apply position mapping to input positions" . MaybeT . pure $
+    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.
+            -- 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 $
+    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'.
@@ -169,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

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"