Add RangeMap for unified "in-range" filtering

hls-plugin-api/bench/Main.hs

@@ -0,0 +1,56 @@
+-- A benchmark comparing the performance characteristics of list-based
+-- vs RangeMap-based "in-range filtering" approaches
+module Main (main) where
+
+import           Control.DeepSeq        (force)
+import           Control.Exception      (evaluate)
+import           Control.Monad          (replicateM)
+import qualified Criterion
+import qualified Criterion.Main
+import           Data.Random            (RVar)
+import qualified Data.Random            as Fu
+import qualified Ide.Plugin.RangeMap    as RangeMap
+import           Language.LSP.Types     (Position (..), Range (..), UInt,
+                                         isSubrangeOf)
+import qualified System.Random.Stateful as Random
+
+
+genRangeList :: Int -> RVar [Range]
+genRangeList n = replicateM n genRange
+
+genRange :: RVar Range
+genRange = do
+  x1 <- genPosition
+  delta <- genRangeLength
+  let x2 = x1 { _character = _character x1 + delta }
+  pure $ Range x1 x2
+  where
+    genRangeLength :: RVar UInt
+    genRangeLength = fromInteger <$> Fu.uniform 5 50
+
+genPosition :: RVar Position
+genPosition = Position
+  <$> (fromInteger <$> Fu.uniform 0 10000)
+  <*> (fromInteger <$> Fu.uniform 0 150)
+
+filterRangeList :: Range -> [Range] -> [Range]
+filterRangeList r = filter (isSubrangeOf r)
+
+main :: IO ()
+main = do
+  rangeLists@[rangeList100, rangeList1000, rangeList10000]
+    <- traverse (Fu.sampleFrom Random.globalStdGen . genRangeList) [100, 1000, 10000]
+  [rangeMap100, rangeMap1000, rangeMap10000] <- evaluate $ force $ map (RangeMap.fromList id) rangeLists
+  targetRange <- Fu.sampleFrom Random.globalStdGen genRange
+  Criterion.Main.defaultMain
+    [ Criterion.bgroup "List"
+        [ Criterion.bench "Size 100" $ Criterion.nf (filterRangeList targetRange) rangeList100
+        , Criterion.bench "Size 1000" $ Criterion.nf (filterRangeList targetRange) rangeList1000
+        , Criterion.bench "Size 10000" $ Criterion.nf (filterRangeList targetRange) rangeList10000
+        ]
+    , Criterion.bgroup "RangeMap"
+        [ Criterion.bench "Size 100" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap100
+        , Criterion.bench "Size 1000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap1000
+        , Criterion.bench "Size 10000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap10000
+        ]
+    ]

hls-plugin-api/hls-plugin-api.cabal

@@ -20,6 +20,11 @@ flag pedantic
   default:     False
   manual:      True
 
+flag use-fingertree
+  description: Use fingertree implementation of RangeMap
+  default:     True
+  manual:      False
+
 source-repository head
   type:     git
   location: https://github.com/haskell/haskell-language-server
@@ -29,6 +34,7 @@ library
     Ide.Plugin.Config
     Ide.Plugin.ConfigUtils
     Ide.Plugin.Properties
+    Ide.Plugin.RangeMap
     Ide.PluginUtils
     Ide.Types
 
@@ -73,6 +79,10 @@ library
   if impl(ghc >= 9)
     ghc-options: -Wunused-packages
 
+  if flag(use-fingertree)
+    cpp-options: -DUSE_FINGERTREE
+    build-depends: hw-fingertree
+
   default-language:   Haskell2010
   default-extensions:
     DataKinds
@@ -92,5 +102,24 @@ test-suite tests
     , tasty
     , tasty-hunit
     , tasty-rerun
+    , tasty-quickcheck
     , text
     , lsp-types
+    , containers
+
+benchmark rangemap-benchmark
+  if !flag(use-fingertree)
+    buildable: False
+  type:             exitcode-stdio-1.0
+  default-language: Haskell2010
+  hs-source-dirs:   bench
+  main-is:          Main.hs
+  ghc-options:      -threaded -Wall
+  build-depends:
+      base
+    , hls-plugin-api
+    , lsp-types
+    , criterion
+    , random
+    , random-fu
+    , deepseq

hls-plugin-api/src/Ide/Plugin/RangeMap.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | A map that allows fast \"in-range\" filtering. 'RangeMap' is meant
+-- to be constructed once and cached as part of a Shake rule. If
+-- not, the map will be rebuilt upon each invocation, yielding slower
+-- results compared to the list-based approach!
+--
+-- Note that 'RangeMap' falls back to the list-based approach if
+-- `use-fingertree` flag of `hls-plugin-api` is set to false.
+module Ide.Plugin.RangeMap
+  ( RangeMap(..),
+    fromList,
+    fromList',
+    filterByRange,
+  ) where
+
+import           Data.Bifunctor                           (first)
+import           Data.Foldable                            (foldl')
+import           Development.IDE.Graph.Classes            (NFData)
+import           Language.LSP.Types                       (Position,
+                                                           Range (Range),
+                                                           isSubrangeOf)
+#ifdef USE_FINGERTREE
+import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM
+#endif
+
+-- | A map from code ranges to values.
+#ifdef USE_FINGERTREE
+newtype RangeMap a = RangeMap
+  { unRangeMap :: IM.IntervalMap Position a
+    -- ^ 'IM.Interval' of 'Position' corresponds to a 'Range'
+  }
+  deriving newtype (NFData, Semigroup, Monoid)
+  deriving stock (Functor, Foldable, Traversable)
+#else
+newtype RangeMap a = RangeMap
+  { unRangeMap :: [(Range, a)] }
+  deriving newtype (NFData, Semigroup, Monoid)
+  deriving stock (Functor, Foldable, Traversable)
+#endif
+
+-- | Construct a 'RangeMap' from a 'Range' accessor and a list of values.
+fromList :: (a -> Range) -> [a] -> RangeMap a
+fromList extractRange = fromList' . map (\x -> (extractRange x, x))
+
+fromList' :: [(Range, a)] -> RangeMap a
+#ifdef USE_FINGERTREE
+fromList' = RangeMap . toIntervalMap . map (first rangeToInterval)
+  where
+    toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a
+    toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty
+#else
+fromList' = RangeMap
+#endif
+
+-- | Filter a 'RangeMap' by a given 'Range'.
+filterByRange :: Range -> RangeMap a -> [a]
+#ifdef USE_FINGERTREE
+filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap
+#else
+filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap
+#endif
+
+#ifdef USE_FINGERTREE
+rangeToInterval :: Range -> IM.Interval Position
+rangeToInterval (Range s e) = IM.Interval s e
+#endif

hls-plugin-api/test/Ide/PluginUtilsTest.hs

@@ -1,19 +1,27 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
 
 module Ide.PluginUtilsTest
     ( tests
     ) where
 
-import           Data.Char          (isPrint)
-import qualified Data.Text          as T
-import           Ide.PluginUtils    (positionInRange, unescape)
-import           Language.LSP.Types (Position (Position), Range (Range))
+import           Data.Char             (isPrint)
+import qualified Data.Set              as Set
+import qualified Data.Text             as T
+import qualified Ide.Plugin.RangeMap   as RangeMap
+import           Ide.PluginUtils       (positionInRange, unescape)
+import           Language.LSP.Types    (Position (..), Range (Range), UInt,
+                                        isSubrangeOf)
 import           Test.Tasty
 import           Test.Tasty.HUnit
+import           Test.Tasty.QuickCheck
 
 tests :: TestTree
 tests = testGroup "PluginUtils"
     [ unescapeTest
+    , localOption (QuickCheckMaxSize 10000) $
+        testProperty "RangeMap-List filtering identical" $
+          prop_rangemapListEq @Int
     ]
 
 unescapeTest :: TestTree
@@ -33,3 +41,46 @@ unescapeTest = testGroup "unescape"
     , testCase "control characters should not be escaped" $
         unescape "\"\\n\\t\"" @?= "\"\\n\\t\""
     ]
+
+genRange :: Gen Range
+genRange = oneof [ genRangeInline, genRangeMultiline ]
+
+genRangeInline :: Gen Range
+genRangeInline = do
+  x1 <- genPosition
+  delta <- genRangeLength
+  let x2 = x1 { _character = _character x1 + delta }
+  pure $ Range x1 x2
+  where
+    genRangeLength :: Gen UInt
+    genRangeLength = fromInteger <$> chooseInteger (5, 50)
+
+genRangeMultiline :: Gen Range
+genRangeMultiline = do
+  x1 <- genPosition
+  let heightDelta = 1
+  secondX <- genSecond
+  let x2 = x1 { _line = _line x1 + heightDelta
+              , _character = secondX
+              }
+  pure $ Range x1 x2
+  where
+    genSecond :: Gen UInt
+    genSecond = fromInteger <$> chooseInteger (0, 10)
+
+genPosition :: Gen Position
+genPosition = Position
+  <$> (fromInteger <$> chooseInteger (0, 1000))
+  <*> (fromInteger <$> chooseInteger (0, 150))
+
+instance Arbitrary Range where
+  arbitrary = genRange
+
+prop_rangemapListEq :: (Show a, Eq a, Ord a) => Range -> [(Range, a)] -> Property
+prop_rangemapListEq r xs =
+  let filteredList = (map snd . filter (isSubrangeOf r . fst)) xs
+      filteredRangeMap = RangeMap.filterByRange r (RangeMap.fromList' xs)
+   in classify (null filteredList) "no matches" $
+      cover 5 (length filteredList == 1) "1 match" $
+      cover 2 (length filteredList > 1) ">1 matches" $
+      Set.fromList filteredList === Set.fromList filteredRangeMap

plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs

@@ -25,6 +25,8 @@ import           Ide.Plugin.Conversion         (AlternateFormat,
                                                 ExtensionNeeded (NeedsExtension, NoExtension),
                                                 alternateFormat)
 import           Ide.Plugin.Literals
+import           Ide.Plugin.RangeMap           (RangeMap)
+import qualified Ide.Plugin.RangeMap           as RangeMap
 import           Ide.PluginUtils               (getNormalizedFilePath,
                                                 handleMaybeM, pluginResponse)
 import           Ide.Types
@@ -52,7 +54,7 @@ instance NFData CollectLiterals
 type instance RuleResult CollectLiterals = CollectLiteralsResult
 
 data CollectLiteralsResult = CLR
-    { literals          :: [Literal]
+    { literals          :: RangeMap Literal
     , enabledExtensions :: [GhcExtension]
     } deriving (Generic)
 
@@ -73,25 +75,22 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec
     let exts = map GhcExtension . getExtensions <$> pm
         -- collect all the literals for a file
         lits = collectLiterals . pm_parsed_source <$> pm
-    pure ([], CLR <$> lits <*> exts)
+        litMap = RangeMap.fromList (realSrcSpanToRange . getSrcSpan) <$> lits
+    pure ([], CLR <$> litMap <*> exts)
 
 codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
 codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
     nfp <- getNormalizedFilePath (docId ^. L.uri)
     CLR{..} <- requestLiterals pId state nfp
     pragma <- getFirstPragma pId state nfp
         -- remove any invalid literals (see validTarget comment)
-    let litsInRange = filter inCurrentRange literals
+    let litsInRange = RangeMap.filterByRange currRange literals
         -- generate alternateFormats and zip with the literal that generated the alternates
         literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange
         -- make a code action for every literal and its' alternates (then flatten the result)
         actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs
     pure $ List actions
     where
-        inCurrentRange :: Literal -> Bool
-        inCurrentRange lit = let srcSpan = getSrcSpan lit
-                              in currRange `contains` srcSpan
-
         mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction
         mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction {
             _title = mkCodeActionTitle lit af enabled
@@ -127,13 +126,6 @@ mkCodeActionTitle lit (alt, ext) ghcExts
 needsExtension :: Extension -> [GhcExtension] -> Bool
 needsExtension ext ghcExts = ext `notElem` map unExt ghcExts
 
--- from HaddockComments.hs
-contains :: Range -> RealSrcSpan -> Bool
-contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSrcSpan _end x
-
-isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool
-p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep
-
 requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
 requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals"
                 . liftIO

plugins/hls-alternate-number-format-plugin/test/Main.hs

@@ -29,7 +29,7 @@ test :: TestTree
 test = testGroup "alternateNumberFormat" [
     codeActionHex "TIntDtoH" 3 13
     , codeActionOctal "TIntDtoO" 3 13
-    , codeActionBinary "TIntDtoB" 4 12
+    , codeActionBinary "TIntDtoB" 4 13
     , codeActionNumDecimal "TIntDtoND" 5 13
     , codeActionFracExp "TFracDtoE" 3 13
     , codeActionFloatHex "TFracDtoHF" 4 13

plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal

@@ -38,7 +38,6 @@ library
       , transformers
       , ghc-boot-th
       , unordered-containers
-      , hw-fingertree
     hs-source-dirs:   src
     default-language: Haskell2010