diff --git a/hls-plugin-api/bench/Main.hs b/hls-plugin-api/bench/Main.hs new file mode 100644 index 0000000000..0fc64f49f1 --- /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 "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 + ] + ] diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 217e7ae30f..239c7a092b 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -20,6 +20,14 @@ 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 + manual: False + source-repository head type: git location: https://github.com/haskell/haskell-language-server @@ -29,6 +37,7 @@ library Ide.Plugin.Config Ide.Plugin.ConfigUtils Ide.Plugin.Properties + Ide.Plugin.RangeMap Ide.PluginUtils Ide.Types @@ -73,6 +82,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 +105,26 @@ test-suite tests , tasty , tasty-hunit , tasty-rerun + , tasty-quickcheck , text , lsp-types + , 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 + 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..461e0af432 --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -0,0 +1,83 @@ +{-# 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 +-- 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 diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index bad3c1dfbc..f08821cd50 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/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 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..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 @@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} @@ -13,77 +13,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 (isJust, listToMaybe, + maybeToList) +import Data.Text (Text) +import Development.IDE (IdeState, NormalizedFilePath, + Pretty (..), Recorder (..), + Rules, WithPriority (..), + realSrcSpanToRange) +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, getLoc, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + GhcPass, + HsExpr (RecordCon, rcon_flds), + LHsExpr, Pass (..), Pat (..), + RealSrcSpan, conPatDetails, + hfbPun, hs_valds, + mapConPatDetail, mapLoc, + pattern RealSrcSpan) +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 +96,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 @@ -124,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 @@ -154,7 +142,7 @@ 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 + recMap = RangeMap.fromList (realSrcSpanToRange . 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) @@ -192,15 +180,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) @@ -252,18 +240,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 @@ -273,17 +263,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)