Fix error in code range

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
@@ -13,27 +14,29 @@ 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)
-import           Development.IDE.Types.Logger         (Pretty (..))
+import           Development.IDE.Types.Logger         (Pretty (..),
+                                                       Priority (Warning),
+                                                       logWith)
 import           Ide.Plugin.CodeRange.Rules           (CodeRange (..),
                                                        GetCodeRange (..),
                                                        codeRangeRule, crkToFrk)
@@ -44,7 +47,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),
@@ -61,65 +64,97 @@ 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 <- ExceptT . liftIO . runIdeAction "FoldingRange" (shakeExtras ide) . runExceptT $
+        foldingRanges <- mapExceptT runAction' $
             getFoldingRanges filePath
         pure . List $ foldingRanges
-    where
-        uri :: Uri
-        TextDocumentIdentifier uri = _textDocument
+  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
+    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
 
-    -- removing first node because it folds the entire file
-    pure $ drop 1 $ findFoldingRanges codeRange
+data FoldingRangeError = forall rule. Show rule => FoldingRangeBadDependency rule
 
-selectionRangeHandler :: IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange))
-selectionRangeHandler ide _ SelectionRangeParams{..} = do
+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
-        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
+        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 "fail to get code range" $ useE GetCodeRange file
+    (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . 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 +204,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/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" $

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"