Skip to content

Commit 9e5fc88

Browse files
ozkutukozkutuk
authored
Add RangeMap for unified "in-range" filtering (#3343)
* Move RangeMap under hls-plugin-api and add benchmark * Add some documentation * Rename benchmark case * Make explicit fields plugin work with RealSrcSpans * Add test to ensure both filtering approaches are identical * Add some coverage checks (for reference) * Remove outdated comment * Add use-fingertree flag to hls-plugin-api * Add more instances to RangeMap * Extend test generators to cover multiline ranges * Add more documentation
1 parent d7690c5 commit 9e5fc88

File tree

8 files changed

+312
-121
lines changed

8 files changed

+312
-121
lines changed

‎hls-plugin-api/bench/Main.hs

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
-- A benchmark comparing the performance characteristics of list-based
2+
-- vs RangeMap-based "in-range filtering" approaches
3+
module Main (main) where
4+
5+
import Control.DeepSeq (force)
6+
import Control.Exception (evaluate)
7+
import Control.Monad (replicateM)
8+
import qualified Criterion
9+
import qualified Criterion.Main
10+
import Data.Random (RVar)
11+
import qualified Data.Random as Fu
12+
import qualified Ide.Plugin.RangeMap as RangeMap
13+
import Language.LSP.Types (Position (..), Range (..), UInt,
14+
isSubrangeOf)
15+
import qualified System.Random.Stateful as Random
16+
17+
18+
genRangeList :: Int -> RVar [Range]
19+
genRangeList n = replicateM n genRange
20+
21+
genRange :: RVar Range
22+
genRange = do
23+
x1 <- genPosition
24+
delta <- genRangeLength
25+
let x2 = x1 { _character = _character x1 + delta }
26+
pure $ Range x1 x2
27+
where
28+
genRangeLength :: RVar UInt
29+
genRangeLength = fromInteger <$> Fu.uniform 5 50
30+
31+
genPosition :: RVar Position
32+
genPosition = Position
33+
<$> (fromInteger <$> Fu.uniform 0 10000)
34+
<*> (fromInteger <$> Fu.uniform 0 150)
35+
36+
filterRangeList :: Range -> [Range] -> [Range]
37+
filterRangeList r = filter (isSubrangeOf r)
38+
39+
main :: IO ()
40+
main = do
41+
rangeLists@[rangeList100, rangeList1000, rangeList10000]
42+
<- traverse (Fu.sampleFrom Random.globalStdGen . genRangeList) [100, 1000, 10000]
43+
[rangeMap100, rangeMap1000, rangeMap10000] <- evaluate $ force $ map (RangeMap.fromList id) rangeLists
44+
targetRange <- Fu.sampleFrom Random.globalStdGen genRange
45+
Criterion.Main.defaultMain
46+
[ Criterion.bgroup "List"
47+
[ Criterion.bench "Size 100" $ Criterion.nf (filterRangeList targetRange) rangeList100
48+
, Criterion.bench "Size 1000" $ Criterion.nf (filterRangeList targetRange) rangeList1000
49+
, Criterion.bench "Size 10000" $ Criterion.nf (filterRangeList targetRange) rangeList10000
50+
]
51+
, Criterion.bgroup "RangeMap"
52+
[ Criterion.bench "Size 100" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap100
53+
, Criterion.bench "Size 1000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap1000
54+
, Criterion.bench "Size 10000" $ Criterion.nf (RangeMap.filterByRange targetRange) rangeMap10000
55+
]
56+
]

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

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,14 @@ flag pedantic
2020
default: False
2121
manual: True
2222

23+
-- This flag can be used to avoid the dependency on hw-fingertree.
24+
-- We can set this temporarily if we have problems building hw-fingertree
25+
-- for a new version of GHC.
26+
flag use-fingertree
27+
description: Use fingertree implementation of RangeMap
28+
default: True
29+
manual: False
30+
2331
source-repository head
2432
type: git
2533
location: https://github.com/haskell/haskell-language-server
@@ -29,6 +37,7 @@ library
2937
Ide.Plugin.Config
3038
Ide.Plugin.ConfigUtils
3139
Ide.Plugin.Properties
40+
Ide.Plugin.RangeMap
3241
Ide.PluginUtils
3342
Ide.Types
3443

@@ -73,6 +82,10 @@ library
7382
if impl(ghc >= 9)
7483
ghc-options: -Wunused-packages
7584

85+
if flag(use-fingertree)
86+
cpp-options: -DUSE_FINGERTREE
87+
build-depends: hw-fingertree
88+
7689
default-language: Haskell2010
7790
default-extensions:
7891
DataKinds
@@ -92,5 +105,26 @@ test-suite tests
92105
, tasty
93106
, tasty-hunit
94107
, tasty-rerun
108+
, tasty-quickcheck
95109
, text
96110
, lsp-types
111+
, containers
112+
113+
benchmark rangemap-benchmark
114+
-- Benchmark doesn't make sense if fingertree implementation
115+
-- is not used.
116+
if !flag(use-fingertree)
117+
buildable: False
118+
type: exitcode-stdio-1.0
119+
default-language: Haskell2010
120+
hs-source-dirs: bench
121+
main-is: Main.hs
122+
ghc-options: -threaded -Wall
123+
build-depends:
124+
base
125+
, hls-plugin-api
126+
, lsp-types
127+
, criterion
128+
, random
129+
, random-fu
130+
, deepseq

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

Lines changed: 83 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveFoldable #-}
3+
{-# LANGUAGE DeriveFunctor #-}
4+
{-# LANGUAGE DeriveTraversable #-}
5+
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
8+
-- | A map that allows fast \"in-range\" filtering. 'RangeMap' is meant
9+
-- to be constructed once and cached as part of a Shake rule. If
10+
-- not, the map will be rebuilt upon each invocation, yielding slower
11+
-- results compared to the list-based approach!
12+
--
13+
-- Note that 'RangeMap' falls back to the list-based approach if
14+
-- `use-fingertree` flag of `hls-plugin-api` is set to false.
15+
module Ide.Plugin.RangeMap
16+
( RangeMap(..),
17+
fromList,
18+
fromList',
19+
filterByRange,
20+
) where
21+
22+
import Data.Bifunctor (first)
23+
import Data.Foldable (foldl')
24+
import Development.IDE.Graph.Classes (NFData)
25+
import Language.LSP.Types (Position,
26+
Range (Range),
27+
isSubrangeOf)
28+
#ifdef USE_FINGERTREE
29+
import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM
30+
#endif
31+
32+
-- | A map from code ranges to values.
33+
#ifdef USE_FINGERTREE
34+
newtype RangeMap a = RangeMap
35+
{ unRangeMap :: IM.IntervalMap Position a
36+
-- ^ 'IM.Interval' of 'Position' corresponds to a 'Range'
37+
}
38+
deriving newtype (NFData, Semigroup, Monoid)
39+
deriving stock (Functor, Foldable, Traversable)
40+
#else
41+
newtype RangeMap a = RangeMap
42+
{ unRangeMap :: [(Range, a)] }
43+
deriving newtype (NFData, Semigroup, Monoid)
44+
deriving stock (Functor, Foldable, Traversable)
45+
#endif
46+
47+
-- | Construct a 'RangeMap' from a 'Range' accessor and a list of values.
48+
fromList :: (a -> Range) -> [a] -> RangeMap a
49+
fromList extractRange = fromList' . map (\x -> (extractRange x, x))
50+
51+
fromList' :: [(Range, a)] -> RangeMap a
52+
#ifdef USE_FINGERTREE
53+
fromList' = RangeMap . toIntervalMap . map (first rangeToInterval)
54+
where
55+
toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a
56+
toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty
57+
#else
58+
fromList' = RangeMap
59+
#endif
60+
61+
-- | Filter a 'RangeMap' by a given 'Range'.
62+
filterByRange :: Range -> RangeMap a -> [a]
63+
#ifdef USE_FINGERTREE
64+
filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap
65+
#else
66+
filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap
67+
#endif
68+
69+
#ifdef USE_FINGERTREE
70+
-- NOTE(ozkutuk): In itself, this conversion is wrong. As Michael put it:
71+
-- "LSP Ranges have exclusive upper bounds, whereas the intervals here are
72+
-- supposed to be closed (i.e. inclusive at both ends)"
73+
-- However, in our use-case this turns out not to be an issue (supported
74+
-- by the accompanying property test). I think the reason for this is,
75+
-- even if rangeToInterval isn't a correct 1:1 conversion by itself, it
76+
-- is used for both the construction of the RangeMap and during the actual
77+
-- filtering (filterByRange), so it still behaves identical to the list
78+
-- approach.
79+
-- This definition isn't exported from the module, therefore we need not
80+
-- worry about other uses where it potentially makes a difference.
81+
rangeToInterval :: Range -> IM.Interval Position
82+
rangeToInterval (Range s e) = IM.Interval s e
83+
#endif

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

Lines changed: 55 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,27 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TypeApplications #-}
23

34
module Ide.PluginUtilsTest
45
( tests
56
) where
67

7-
import Data.Char (isPrint)
8-
import qualified Data.Text as T
9-
import Ide.PluginUtils (positionInRange, unescape)
10-
import Language.LSP.Types (Position (Position), Range (Range))
8+
import Data.Char (isPrint)
9+
import qualified Data.Set as Set
10+
import qualified Data.Text as T
11+
import qualified Ide.Plugin.RangeMap as RangeMap
12+
import Ide.PluginUtils (positionInRange, unescape)
13+
import Language.LSP.Types (Position (..), Range (Range), UInt,
14+
isSubrangeOf)
1115
import Test.Tasty
1216
import Test.Tasty.HUnit
17+
import Test.Tasty.QuickCheck
1318

1419
tests :: TestTree
1520
tests = testGroup "PluginUtils"
1621
[ unescapeTest
22+
, localOption (QuickCheckMaxSize 10000) $
23+
testProperty "RangeMap-List filtering identical" $
24+
prop_rangemapListEq @Int
1725
]
1826

1927
unescapeTest :: TestTree
@@ -33,3 +41,46 @@ unescapeTest = testGroup "unescape"
3341
, testCase "control characters should not be escaped" $
3442
unescape "\"\\n\\t\"" @?= "\"\\n\\t\""
3543
]
44+
45+
genRange :: Gen Range
46+
genRange = oneof [ genRangeInline, genRangeMultiline ]
47+
48+
genRangeInline :: Gen Range
49+
genRangeInline = do
50+
x1 <- genPosition
51+
delta <- genRangeLength
52+
let x2 = x1 { _character = _character x1 + delta }
53+
pure $ Range x1 x2
54+
where
55+
genRangeLength :: Gen UInt
56+
genRangeLength = fromInteger <$> chooseInteger (5, 50)
57+
58+
genRangeMultiline :: Gen Range
59+
genRangeMultiline = do
60+
x1 <- genPosition
61+
let heightDelta = 1
62+
secondX <- genSecond
63+
let x2 = x1 { _line = _line x1 + heightDelta
64+
, _character = secondX
65+
}
66+
pure $ Range x1 x2
67+
where
68+
genSecond :: Gen UInt
69+
genSecond = fromInteger <$> chooseInteger (0, 10)
70+
71+
genPosition :: Gen Position
72+
genPosition = Position
73+
<$> (fromInteger <$> chooseInteger (0, 1000))
74+
<*> (fromInteger <$> chooseInteger (0, 150))
75+
76+
instance Arbitrary Range where
77+
arbitrary = genRange
78+
79+
prop_rangemapListEq :: (Show a, Eq a, Ord a) => Range -> [(Range, a)] -> Property
80+
prop_rangemapListEq r xs =
81+
let filteredList = (map snd . filter (isSubrangeOf r . fst)) xs
82+
filteredRangeMap = RangeMap.filterByRange r (RangeMap.fromList' xs)
83+
in classify (null filteredList) "no matches" $
84+
cover 5 (length filteredList == 1) "1 match" $
85+
cover 2 (length filteredList > 1) ">1 matches" $
86+
Set.fromList filteredList === Set.fromList filteredRangeMap

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

Lines changed: 6 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,8 @@ import Ide.Plugin.Conversion (AlternateFormat,
2525
ExtensionNeeded (NeedsExtension, NoExtension),
2626
alternateFormat)
2727
import Ide.Plugin.Literals
28+
import Ide.Plugin.RangeMap (RangeMap)
29+
import qualified Ide.Plugin.RangeMap as RangeMap
2830
import Ide.PluginUtils (getNormalizedFilePath,
2931
handleMaybeM, pluginResponse)
3032
import Ide.Types
@@ -52,7 +54,7 @@ instance NFData CollectLiterals
5254
type instance RuleResult CollectLiterals = CollectLiteralsResult
5355

5456
data CollectLiteralsResult = CLR
55-
{ literals :: [Literal]
57+
{ literals :: RangeMap Literal
5658
, enabledExtensions :: [GhcExtension]
5759
} deriving (Generic)
5860

@@ -73,25 +75,22 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec
7375
let exts = map GhcExtension . getExtensions <$> pm
7476
-- collect all the literals for a file
7577
lits = collectLiterals . pm_parsed_source <$> pm
76-
pure ([], CLR <$> lits <*> exts)
78+
litMap = RangeMap.fromList (realSrcSpanToRange . getSrcSpan) <$> lits
79+
pure ([], CLR <$> litMap <*> exts)
7780

7881
codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction
7982
codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do
8083
nfp <- getNormalizedFilePath (docId ^. L.uri)
8184
CLR{..} <- requestLiterals pId state nfp
8285
pragma <- getFirstPragma pId state nfp
8386
-- remove any invalid literals (see validTarget comment)
84-
let litsInRange = filter inCurrentRange literals
87+
let litsInRange = RangeMap.filterByRange currRange literals
8588
-- generate alternateFormats and zip with the literal that generated the alternates
8689
literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange
8790
-- make a code action for every literal and its' alternates (then flatten the result)
8891
actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs
8992
pure $ List actions
9093
where
91-
inCurrentRange :: Literal -> Bool
92-
inCurrentRange lit = let srcSpan = getSrcSpan lit
93-
in currRange `contains` srcSpan
94-
9594
mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction
9695
mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction {
9796
_title = mkCodeActionTitle lit af enabled
@@ -127,13 +126,6 @@ mkCodeActionTitle lit (alt, ext) ghcExts
127126
needsExtension :: Extension -> [GhcExtension] -> Bool
128127
needsExtension ext ghcExts = ext `notElem` map unExt ghcExts
129128

130-
-- from HaddockComments.hs
131-
contains :: Range -> RealSrcSpan -> Bool
132-
contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSrcSpan _end x
133-
134-
isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool
135-
p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep
136-
137129
requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m CollectLiteralsResult
138130
requestLiterals (PluginId pId) state = handleMaybeM "Could not Collect Literals"
139131
. liftIO

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ test :: TestTree
2929
test = testGroup "alternateNumberFormat" [
3030
codeActionHex "TIntDtoH" 3 13
3131
, codeActionOctal "TIntDtoO" 3 13
32-
, codeActionBinary "TIntDtoB" 4 12
32+
, codeActionBinary "TIntDtoB" 4 13
3333
, codeActionNumDecimal "TIntDtoND" 5 13
3434
, codeActionFracExp "TFracDtoE" 3 13
3535
, codeActionFloatHex "TFracDtoHF" 4 13

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,6 @@ library
3838
, transformers
3939
, ghc-boot-th
4040
, unordered-containers
41-
, hw-fingertree
4241
hs-source-dirs: src
4342
default-language: Haskell2010
4443

0 commit comments

Comments
 (0)