From d4d312e1c7e5bdeb24b571fdab9ad170f0a89c24 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Wed, 16 Nov 2022 22:07:01 +0100 Subject: [PATCH 01/11] Move RangeMap under hls-plugin-api and add benchmark --- hls-plugin-api/bench/Main.hs | 56 +++++++ hls-plugin-api/hls-plugin-api.cabal | 17 ++ hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 34 ++++ .../src/Ide/Plugin/AlternateNumberFormat.hs | 20 +-- .../test/Main.hs | 2 +- .../hls-explicit-record-fields-plugin.cabal | 1 - .../src/Ide/Plugin/ExplicitFields.hs | 152 ++++++++---------- 7 files changed, 177 insertions(+), 105 deletions(-) create mode 100644 hls-plugin-api/bench/Main.hs create mode 100644 hls-plugin-api/src/Ide/Plugin/RangeMap.hs diff --git a/hls-plugin-api/bench/Main.hs b/hls-plugin-api/bench/Main.hs new file mode 100644 index 0000000000..007e5a9544 --- /dev/null +++ b/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 "IntervalMap" + [ 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 + ] + ] diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 217e7ae30f..b287c8cafa 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -29,6 +29,7 @@ library Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Properties + Ide.Plugin.RangeMap Ide.PluginUtils Ide.Types @@ -57,6 +58,7 @@ library , transformers , unordered-containers , megaparsec > 9 + , hw-fingertree if os(windows) build-depends: Win32 @@ -94,3 +96,18 @@ test-suite tests , tasty-rerun , text , lsp-types + +benchmark rangemap-benchmark + 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 diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs new file mode 100644 index 0000000000..4719967bb8 --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Ide.Plugin.RangeMap + ( RangeMap(..), + fromList, + fromList', + filterByRange, + ) where + +import Data.Bifunctor (first) +import Data.Foldable (foldl') +import Development.IDE.Graph.Classes (NFData) +import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM +import Language.LSP.Types (Position, + Range (Range)) + +newtype RangeMap a + = RangeMap { unRangeMap :: IM.IntervalMap Position a } + deriving newtype (NFData) + +rangeToInterval :: Range -> IM.Interval Position +rangeToInterval (Range s e) = IM.Interval s e + +fromList :: (a -> Range) -> [a] -> RangeMap a +fromList extractRange = fromList' . map (\x -> (extractRange x, x)) + +fromList' :: [(Range, a)] -> RangeMap a +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 + +filterByRange :: Range -> RangeMap a -> [a] +filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index f2961d452a..364179a4d5 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/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,7 +75,8 @@ 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 @@ -81,17 +84,13 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginRes 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 diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index c71fffb9e8..d6b19d4e7b 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal index 2af84b89fb..92a4e1cf5a 100644 --- a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal +++ b/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 diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 1a32ae70bb..abf7ea1a5f 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -13,77 +12,65 @@ module Ide.Plugin.ExplicitFields ( descriptor ) where -import Control.Lens ((^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except (ExceptT) -import Data.Foldable (foldl') -import Data.Generics (GenericQ, everything, - extQ, mkQ) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (catMaybes, isJust, - mapMaybe, - maybeToList) -import Data.Text (Text) -import Development.IDE (IdeState, - NormalizedFilePath, - Pretty (..), - Range (..), - Recorder (..), Rules, - WithPriority (..), - srcSpanToRange) -import Development.IDE.Core.Rules (runAction) -import Development.IDE.Core.RuleTypes (TcModuleResult (..), - TypeCheck (..)) -import Development.IDE.Core.Shake (define, use) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsRecFields (..), - LPat, Outputable, - SrcSpan, getLoc, - unLoc) -import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, - HsExpr (RecordCon, rcon_flds), - LHsExpr, Pass (..), - Pat (..), - conPatDetails, - hfbPun, hs_valds, - mapConPatDetail, - mapLoc) -import Development.IDE.GHC.Util (getExtensions, - printOutputable) -import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, - NFData (rnf)) -import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), - getFirstPragma, - insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), - cmapWithPrio, - logWith, (<+>)) -import GHC.Generics (Generic) -import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM -import Ide.PluginUtils (getNormalizedFilePath, - handleMaybeM, - pluginResponse) -import Ide.Types (PluginDescriptor (..), - PluginId (..), - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Types (CodeAction (..), - CodeActionKind (CodeActionRefactorRewrite), - CodeActionParams (..), - Command, List (..), - Method (..), - Position, - SMethod (..), - TextEdit (..), - WorkspaceEdit (WorkspaceEdit), - fromNormalizedUri, - normalizedFilePathToUri, - type (|?) (InR)) -import qualified Language.LSP.Types.Lens as L +import Control.Lens ((^.)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT) +import Data.Generics (GenericQ, everything, extQ, + mkQ) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (catMaybes, fromJust, isJust, + maybeToList) +import Data.Text (Text) +import Development.IDE (IdeState, NormalizedFilePath, + Pretty (..), Recorder (..), + Rules, WithPriority (..), + srcSpanToRange) +import Development.IDE.Core.Rules (runAction) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import Development.IDE.Core.Shake (define, use) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (HsConDetails (RecCon), + HsRecFields (..), LPat, + Outputable, SrcSpan, getLoc, + unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + LHsExpr, Pass (..), Pat (..), + conPatDetails, hfbPun, + hs_valds, mapConPatDetail, + mapLoc) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, + logWith, (<+>)) +import GHC.Generics (Generic) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybeM, pluginResponse) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Types (CodeAction (..), + CodeActionKind (CodeActionRefactorRewrite), + CodeActionParams (..), + Command, List (..), + Method (..), SMethod (..), + TextEdit (..), + WorkspaceEdit (WorkspaceEdit), + fromNormalizedUri, + normalizedFilePathToUri, + type (|?) (InR)) +import qualified Language.LSP.Types.Lens as L data Log @@ -108,7 +95,7 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes nfp <- getNormalizedFilePath (docId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRR recMap (map unExt -> exts) <- collectRecords' ideState nfp - let actions = map (mkCodeAction nfp exts pragma) (filterRecords range recMap) + let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) pure $ List actions where @@ -154,7 +141,8 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect recs = concat $ maybeToList (getRecords <$> tmr) logWith recorder Debug (LogCollectedRecords recs) let renderedRecs = traverse renderRecordInfo recs - recMap = buildIntervalMap <$> renderedRecs + -- All spans are supposed to be `RealSrcSpan`, hence the use of `fromJust`. + recMap = RangeMap.fromList (fromJust . srcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) pure ([], CRR <$> recMap <*> exts) where @@ -172,7 +160,7 @@ instance Hashable CollectRecords instance NFData CollectRecords data CollectRecordsResult = CRR - { recordInfos :: IM.IntervalMap Position RenderedRecordInfo + { recordInfos :: RangeMap RenderedRecordInfo , enabledExtensions :: [GhcExtension] } deriving (Generic) @@ -273,17 +261,3 @@ collectRecords' ideState = . runAction "ExplicitFields" ideState . use CollectRecords -rangeToInterval :: Range -> IM.Interval Position -rangeToInterval (Range s e) = IM.Interval s e - -buildIntervalMap :: [RenderedRecordInfo] -> IM.IntervalMap Position RenderedRecordInfo -buildIntervalMap recs = toIntervalMap $ mapMaybe (\recInfo -> (,recInfo) <$> srcSpanToInterval (renderedSrcSpan recInfo)) recs - where - toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a - toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty - - srcSpanToInterval :: SrcSpan -> Maybe (IM.Interval Position) - srcSpanToInterval = fmap rangeToInterval . srcSpanToRange - -filterRecords :: Range -> IM.IntervalMap Position RenderedRecordInfo -> [RenderedRecordInfo] -filterRecords range = map snd . IM.dominators (rangeToInterval range) From 3fab3ac6810c4b9f97a2c521684b429110a248fd Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 18 Nov 2022 17:03:17 +0100 Subject: [PATCH 02/11] Add some documentation --- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 4719967bb8..58fa4bcc82 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -1,5 +1,10 @@ {-# 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! module Ide.Plugin.RangeMap ( RangeMap(..), fromList, @@ -14,13 +19,14 @@ import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM import Language.LSP.Types (Position, Range (Range)) -newtype RangeMap a - = RangeMap { unRangeMap :: IM.IntervalMap Position a } +-- | A map from code ranges to values. +newtype RangeMap a = RangeMap + { unRangeMap :: IM.IntervalMap Position a + -- ^ 'IM.Interval' of 'Position' corresponds to a 'Range' + } deriving newtype (NFData) -rangeToInterval :: Range -> IM.Interval Position -rangeToInterval (Range s e) = IM.Interval s e - +-- | 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)) @@ -30,5 +36,9 @@ fromList' = RangeMap . toIntervalMap . map (first rangeToInterval) toIntervalMap :: Ord v => [(IM.Interval v, a)] -> IM.IntervalMap v a toIntervalMap = foldl' (\m (i, v) -> IM.insert i v m) IM.empty +-- | Filter a 'RangeMap' by a given 'Range'. filterByRange :: Range -> RangeMap a -> [a] filterByRange range = map snd . IM.dominators (rangeToInterval range) . unRangeMap + +rangeToInterval :: Range -> IM.Interval Position +rangeToInterval (Range s e) = IM.Interval s e From 33477433766d98eedc2ed21057c8aae99f67fb83 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 18 Nov 2022 17:55:23 +0100 Subject: [PATCH 03/11] Rename benchmark case --- hls-plugin-api/bench/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/bench/Main.hs b/hls-plugin-api/bench/Main.hs index 007e5a9544..0fc64f49f1 100644 --- a/hls-plugin-api/bench/Main.hs +++ b/hls-plugin-api/bench/Main.hs @@ -48,7 +48,7 @@ main = do , Criterion.bench "Size 1000" $ Criterion.nf (filterRangeList targetRange) rangeList1000 , Criterion.bench "Size 10000" $ Criterion.nf (filterRangeList targetRange) rangeList10000 ] - , Criterion.bgroup "IntervalMap" + , 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 From 2d13a0c090029fda42e9b0c4c552bfed639b92d4 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 18 Nov 2022 21:23:22 +0100 Subject: [PATCH 04/11] Make explicit fields plugin work with RealSrcSpans --- .../src/Ide/Plugin/ExplicitFields.hs | 43 ++++++++++--------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index abf7ea1a5f..d3eb82dcce 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -18,13 +19,13 @@ import Control.Monad.Trans.Except (ExceptT) import Data.Generics (GenericQ, everything, extQ, mkQ) import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (catMaybes, fromJust, isJust, +import Data.Maybe (isJust, listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), Rules, WithPriority (..), - srcSpanToRange) + realSrcSpanToRange) import Development.IDE.Core.Rules (runAction) import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) @@ -32,15 +33,15 @@ import Development.IDE.Core.Shake (define, use) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, - Outputable, SrcSpan, getLoc, - unLoc) + Outputable, getLoc, unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), GhcPass, HsExpr (RecordCon, rcon_flds), LHsExpr, Pass (..), Pat (..), - conPatDetails, hfbPun, - hs_valds, mapConPatDetail, - mapLoc) + RealSrcSpan, conPatDetails, + hfbPun, hs_valds, + mapConPatDetail, mapLoc, + pattern RealSrcSpan) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -111,10 +112,10 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes , _xdata = Nothing } where - edits = catMaybes [ mkTextEdit rec , pragmaEdit ] + edits = mkTextEdit rec : maybeToList pragmaEdit - mkTextEdit :: RenderedRecordInfo -> Maybe TextEdit - mkTextEdit (RenderedRecordInfo ss r) = TextEdit <$> srcSpanToRange ss <*> pure r + mkTextEdit :: RenderedRecordInfo -> TextEdit + mkTextEdit (RenderedRecordInfo ss r) = TextEdit (realSrcSpanToRange ss) r pragmaEdit :: Maybe TextEdit pragmaEdit = if NamedFieldPuns `elem` exts @@ -142,7 +143,7 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect logWith recorder Debug (LogCollectedRecords recs) let renderedRecs = traverse renderRecordInfo recs -- All spans are supposed to be `RealSrcSpan`, hence the use of `fromJust`. - recMap = RangeMap.fromList (fromJust . srcSpanToRange . renderedSrcSpan) <$> renderedRecs + recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) pure ([], CRR <$> recMap <*> exts) where @@ -180,15 +181,15 @@ instance NFData GhcExtension where rnf x = x `seq` () data RecordInfo - = RecordInfoPat SrcSpan (Pat (GhcPass 'Renamed)) - | RecordInfoCon SrcSpan (HsExpr (GhcPass 'Renamed)) + = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) + | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) instance Pretty RecordInfo where pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) data RenderedRecordInfo = RenderedRecordInfo - { renderedSrcSpan :: SrcSpan + { renderedSrcSpan :: RealSrcSpan , renderedRecord :: Text } deriving (Generic) @@ -240,18 +241,20 @@ collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `e getRecCons :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo getRecCons e@(unLoc -> RecordCon _ _ flds) - | isJust (rec_dotdot flds) = Just $ mkRecInfo e + | isJust (rec_dotdot flds) = mkRecInfo e where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> RecordInfo - mkRecInfo expr = RecordInfoCon (getLoc expr) (unLoc expr) + mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> Maybe RecordInfo + mkRecInfo expr = listToMaybe + [ RecordInfoCon realSpan (unLoc expr) | RealSrcSpan realSpan _ <- [ getLoc expr ]] getRecCons _ = Nothing getRecPatterns :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) - | isJust (rec_dotdot flds) = Just $ mkRecInfo conPat + | isJust (rec_dotdot flds) = mkRecInfo conPat where - mkRecInfo :: LPat (GhcPass 'Renamed) -> RecordInfo - mkRecInfo pat = RecordInfoPat (getLoc pat) (unLoc pat) + mkRecInfo :: LPat (GhcPass 'Renamed) -> Maybe RecordInfo + mkRecInfo pat = listToMaybe + [ RecordInfoPat realSpan (unLoc pat) | RealSrcSpan realSpan _ <- [ getLoc pat ]] getRecPatterns _ = Nothing collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult From 288cbf151179988a78467e606ec73f323607e590 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Sat, 19 Nov 2022 14:34:31 +0100 Subject: [PATCH 05/11] Add test to ensure both filtering approaches are identical --- hls-plugin-api/hls-plugin-api.cabal | 2 ++ hls-plugin-api/test/Ide/PluginUtilsTest.hs | 38 +++++++++++++++++++--- 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index b287c8cafa..8f4f754c49 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -94,8 +94,10 @@ test-suite tests , tasty , tasty-hunit , tasty-rerun + , tasty-quickcheck , text , lsp-types + , containers benchmark rangemap-benchmark type: exitcode-stdio-1.0 diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index bad3c1dfbc..f46431bcd6 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -1,19 +1,26 @@ {-# 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 +40,26 @@ unescapeTest = testGroup "unescape" , testCase "control characters should not be escaped" $ unescape "\"\\n\\t\"" @?= "\"\\n\\t\"" ] + +genRange :: Gen Range +genRange = 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) + +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 = + Set.fromList ((map snd . filter (isSubrangeOf r . fst)) xs) + === Set.fromList (RangeMap.filterByRange r (RangeMap.fromList' xs)) From eda7f659a036defbfa4addbc38756e57a0f6ed50 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Sat, 19 Nov 2022 15:44:38 +0100 Subject: [PATCH 06/11] Add some coverage checks (for reference) --- hls-plugin-api/test/Ide/PluginUtilsTest.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index f46431bcd6..14aea6b3aa 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -20,7 +20,8 @@ tests :: TestTree tests = testGroup "PluginUtils" [ unescapeTest , localOption (QuickCheckMaxSize 10000) $ - testProperty "RangeMap-List filtering identical" (prop_rangemapListEq @Int) + testProperty "RangeMap-List filtering identical" $ + prop_rangemapListEq @Int ] unescapeTest :: TestTree @@ -61,5 +62,9 @@ instance Arbitrary Range where prop_rangemapListEq :: (Show a, Eq a, Ord a) => Range -> [(Range, a)] -> Property prop_rangemapListEq r xs = - Set.fromList ((map snd . filter (isSubrangeOf r . fst)) xs) - === Set.fromList (RangeMap.filterByRange r (RangeMap.fromList' 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 From ad02e7c800363929bd081be62a19b4869e4b6935 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 22 Nov 2022 16:47:40 +0100 Subject: [PATCH 07/11] Remove outdated comment --- .../src/Ide/Plugin/ExplicitFields.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index d3eb82dcce..b77281f05a 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -142,7 +142,6 @@ collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collect recs = concat $ maybeToList (getRecords <$> tmr) logWith recorder Debug (LogCollectedRecords recs) let renderedRecs = traverse renderRecordInfo recs - -- All spans are supposed to be `RealSrcSpan`, hence the use of `fromJust`. recMap = RangeMap.fromList (realSrcSpanToRange . renderedSrcSpan) <$> renderedRecs logWith recorder Debug (LogRenderedRecords (concat renderedRecs)) pure ([], CRR <$> recMap <*> exts) From d48138544652af47b450311b813e66dad1a09e99 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 22 Nov 2022 17:21:55 +0100 Subject: [PATCH 08/11] Add use-fingertree flag to hls-plugin-api --- hls-plugin-api/hls-plugin-api.cabal | 12 ++++++++++- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 26 +++++++++++++++++++++-- 2 files changed, 35 insertions(+), 3 deletions(-) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 8f4f754c49..10475d7fb1 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/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 @@ -58,7 +63,6 @@ library , transformers , unordered-containers , megaparsec > 9 - , hw-fingertree if os(windows) build-depends: Win32 @@ -75,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 @@ -100,6 +108,8 @@ test-suite tests , containers benchmark rangemap-benchmark + if !flag(use-fingertree) + buildable: False type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: bench diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 58fa4bcc82..41dc962203 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -5,6 +6,9 @@ -- 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, @@ -15,30 +19,48 @@ module Ide.Plugin.RangeMap import Data.Bifunctor (first) import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData) -import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM import Language.LSP.Types (Position, - Range (Range)) + 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) +#else +newtype RangeMap a = RangeMap + { unRangeMap :: [(Range, a)] } +#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 From 527e5fd5c69922c681e92f5d19d58cb5ec690dc4 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 22 Nov 2022 17:49:00 +0100 Subject: [PATCH 09/11] Add more instances to RangeMap --- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 41dc962203..6849923d57 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -22,7 +25,7 @@ import Development.IDE.Graph.Classes (NFData) import Language.LSP.Types (Position, Range (Range), isSubrangeOf) -# ifdef USE_FINGERTREE +#ifdef USE_FINGERTREE import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM #endif @@ -32,10 +35,13 @@ newtype RangeMap a = RangeMap { unRangeMap :: IM.IntervalMap Position a -- ^ 'IM.Interval' of 'Position' corresponds to a 'Range' } - deriving newtype (NFData) + 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. From 79f74461113787d8ea5ecee44d84f5746e774bc9 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Tue, 22 Nov 2022 18:15:27 +0100 Subject: [PATCH 10/11] Extend test generators to cover multiline ranges --- hls-plugin-api/test/Ide/PluginUtilsTest.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index 14aea6b3aa..f08821cd50 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -43,7 +43,10 @@ unescapeTest = testGroup "unescape" ] genRange :: Gen Range -genRange = do +genRange = oneof [ genRangeInline, genRangeMultiline ] + +genRangeInline :: Gen Range +genRangeInline = do x1 <- genPosition delta <- genRangeLength let x2 = x1 { _character = _character x1 + delta } @@ -52,6 +55,19 @@ genRange = do 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)) From f2d153672783e0695a1bc3dede6b6a5de5d97316 Mon Sep 17 00:00:00 2001 From: Berk Ozkutuk Date: Fri, 25 Nov 2022 14:40:56 +0100 Subject: [PATCH 11/11] Add more documentation --- hls-plugin-api/hls-plugin-api.cabal | 5 +++++ hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 11 +++++++++++ 2 files changed, 16 insertions(+) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 10475d7fb1..239c7a092b 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -20,6 +20,9 @@ flag pedantic default: False manual: True +-- This flag can be used to avoid the dependency on hw-fingertree. +-- We can set this temporarily if we have problems building hw-fingertree +-- for a new version of GHC. flag use-fingertree description: Use fingertree implementation of RangeMap default: True @@ -108,6 +111,8 @@ test-suite tests , containers benchmark rangemap-benchmark + -- Benchmark doesn't make sense if fingertree implementation + -- is not used. if !flag(use-fingertree) buildable: False type: exitcode-stdio-1.0 diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 6849923d57..461e0af432 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -67,6 +67,17 @@ filterByRange range = map snd . filter (isSubrangeOf range . fst) . unRangeMap #endif #ifdef USE_FINGERTREE +-- NOTE(ozkutuk): In itself, this conversion is wrong. As Michael put it: +-- "LSP Ranges have exclusive upper bounds, whereas the intervals here are +-- supposed to be closed (i.e. inclusive at both ends)" +-- However, in our use-case this turns out not to be an issue (supported +-- by the accompanying property test). I think the reason for this is, +-- even if rangeToInterval isn't a correct 1:1 conversion by itself, it +-- is used for both the construction of the RangeMap and during the actual +-- filtering (filterByRange), so it still behaves identical to the list +-- approach. +-- This definition isn't exported from the module, therefore we need not +-- worry about other uses where it potentially makes a difference. rangeToInterval :: Range -> IM.Interval Position rangeToInterval (Range s e) = IM.Interval s e #endif