mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Use HashMap/HashSet for maps indexed by Normalized{FilePath,Uri} (#420)
Now that we have optimized Hashable instances for these, it makes sense to use this consistently.
This commit is contained in:
Moritz Kiefer
GitHub
parent
5a65da1d15
commit
4e89d4574d
@ -46,7 +46,7 @@ import System.Exit
|
||||
import Paths_ghcide
|
||||
import Development.GitRev
|
||||
import Development.Shake (Action, action)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import GHC hiding (def)
|
||||
@ -142,7 +142,7 @@ main = do
|
||||
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
|
||||
|
||||
putStrLn "\nStep 6/6: Type checking the files"
|
||||
setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
|
||||
setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
|
||||
results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
|
||||
let (worked, failed) = partition fst $ zip (map isJust results) files
|
||||
when (failed /= []) $
|
||||
@ -170,7 +170,7 @@ expandFiles = concatMapM $ \x -> do
|
||||
kick :: Action ()
|
||||
kick = do
|
||||
files <- getFilesOfInterest
|
||||
void $ uses TypeCheck $ Set.toList files
|
||||
void $ uses TypeCheck $ HashSet.toList files
|
||||
|
||||
-- | Print an LSP event.
|
||||
showEvent :: Lock -> FromServerMessage -> IO ()
|
||||
|
||||
@ -60,7 +60,7 @@ library
|
||||
text,
|
||||
time,
|
||||
transformers,
|
||||
unordered-containers,
|
||||
unordered-containers >= 0.2.10.0,
|
||||
utf8-string,
|
||||
hslogger
|
||||
if flag(ghc-lib)
|
||||
@ -144,7 +144,7 @@ library
|
||||
executable ghcide-test-preprocessor
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test/preprocessor
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall -Wno-name-shadowing
|
||||
main-is: Main.hs
|
||||
build-depends:
|
||||
base == 4.*
|
||||
@ -181,7 +181,8 @@ executable ghcide
|
||||
ghcide,
|
||||
optparse-applicative,
|
||||
shake,
|
||||
text
|
||||
text,
|
||||
unordered-containers
|
||||
other-modules:
|
||||
Arguments
|
||||
Paths_ghcide
|
||||
|
||||
@ -14,8 +14,8 @@ import Control.Monad.Extra
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Binary
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Map.Strict ( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.FileStore
|
||||
@ -30,7 +30,7 @@ import Language.Haskell.LSP.Types.Capabilities
|
||||
import qualified System.Directory as Dir
|
||||
|
||||
-- | A map for tracking the file existence
|
||||
type FileExistsMap = (Map NormalizedFilePath Bool)
|
||||
type FileExistsMap = (HashMap NormalizedFilePath Bool)
|
||||
|
||||
-- | A wrapper around a mutable 'FileExistsMap'
|
||||
newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
|
||||
@ -53,12 +53,12 @@ modifyFileExistsAction f = do
|
||||
modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
|
||||
modifyFileExists state changes = do
|
||||
FileExistsMapVar var <- getIdeGlobalState state
|
||||
changesMap <- evaluate $ Map.fromList changes
|
||||
changesMap <- evaluate $ HashMap.fromList changes
|
||||
|
||||
-- Masked to ensure that the previous values are flushed together with the map update
|
||||
mask $ \_ -> do
|
||||
-- update the map
|
||||
modifyVar_ var $ evaluate . Map.union changesMap
|
||||
modifyVar_ var $ evaluate . HashMap.union changesMap
|
||||
-- flush previous values
|
||||
mapM_ (deleteValue state GetFileExists . fst) changes
|
||||
|
||||
@ -102,7 +102,7 @@ fileExistsRulesFast getLspId vfs = do
|
||||
addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
|
||||
defineEarlyCutoff $ \GetFileExists file -> do
|
||||
fileExistsMap <- getFileExistsMapUntracked
|
||||
let mbFilesWatched = Map.lookup file fileExistsMap
|
||||
let mbFilesWatched = HashMap.lookup file fileExistsMap
|
||||
case mbFilesWatched of
|
||||
Just fv -> pure (summarizeExists fv, ([], Just fv))
|
||||
Nothing -> do
|
||||
@ -113,7 +113,7 @@ fileExistsRulesFast getLspId vfs = do
|
||||
-- taking the FileExistsMap lock to prevent race conditions
|
||||
-- that would lead to multiple listeners for the same path
|
||||
modifyFileExistsAction $ \x -> do
|
||||
case Map.insertLookupWithKey (\_ x _ -> x) file exist x of
|
||||
case HashMap.alterF (,Just exist) file x of
|
||||
(Nothing, x') -> do
|
||||
-- if the listener addition fails, we never recover. This is a bug.
|
||||
addListener eventer file
|
||||
|
||||
@ -19,8 +19,8 @@ import GHC.Generics
|
||||
import Data.Typeable
|
||||
import qualified Data.ByteString.UTF8 as BS
|
||||
import Control.Exception
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Text as T
|
||||
import Data.Tuple.Extra
|
||||
import Data.Functor
|
||||
@ -31,10 +31,10 @@ import Development.IDE.Types.Logger
|
||||
import Development.IDE.Core.Shake
|
||||
|
||||
|
||||
newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
|
||||
newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
|
||||
instance IsIdeGlobal OfInterestVar
|
||||
|
||||
type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
|
||||
type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath
|
||||
|
||||
data GetFilesOfInterest = GetFilesOfInterest
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
@ -46,7 +46,7 @@ instance Binary GetFilesOfInterest
|
||||
-- | The rule that initialises the files of interest state.
|
||||
ofInterestRules :: Rules ()
|
||||
ofInterestRules = do
|
||||
addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
|
||||
addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)
|
||||
defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
|
||||
alwaysRerun
|
||||
filesOfInterest <- getFilesOfInterestUntracked
|
||||
@ -54,7 +54,7 @@ ofInterestRules = do
|
||||
|
||||
|
||||
-- | Get the files that are open in the IDE.
|
||||
getFilesOfInterest :: Action (Set NormalizedFilePath)
|
||||
getFilesOfInterest :: Action (HashSet NormalizedFilePath)
|
||||
getFilesOfInterest = useNoFile_ GetFilesOfInterest
|
||||
|
||||
|
||||
@ -64,19 +64,19 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest
|
||||
|
||||
-- | Set the files-of-interest - not usually necessary or advisable.
|
||||
-- The LSP client will keep this information up to date.
|
||||
setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
|
||||
setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()
|
||||
setFilesOfInterest state files = modifyFilesOfInterest state (const files)
|
||||
|
||||
getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
|
||||
getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)
|
||||
getFilesOfInterestUntracked = do
|
||||
OfInterestVar var <- getIdeGlobalAction
|
||||
liftIO $ readVar var
|
||||
|
||||
-- | Modify the files-of-interest - not usually necessary or advisable.
|
||||
-- The LSP client will keep this information up to date.
|
||||
modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
|
||||
modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()
|
||||
modifyFilesOfInterest state f = do
|
||||
OfInterestVar var <- getIdeGlobalState state
|
||||
files <- modifyVar var $ pure . dupe . f
|
||||
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
|
||||
logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
|
||||
void $ shakeRun state []
|
||||
|
||||
@ -49,7 +49,6 @@ import Development.Shake.Classes
|
||||
import Development.Shake.Rule
|
||||
import qualified Data.HashMap.Strict as HMap
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Map.Merge.Strict as Map
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Dynamic
|
||||
import Data.Maybe
|
||||
@ -95,13 +94,13 @@ data ShakeExtras = ShakeExtras
|
||||
,state :: Var Values
|
||||
,diagnostics :: Var DiagnosticStore
|
||||
,hiddenDiagnostics :: Var DiagnosticStore
|
||||
,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
|
||||
,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
|
||||
-- ^ This represents the set of diagnostics that we have published.
|
||||
-- Due to debouncing not every change might get published.
|
||||
,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
|
||||
,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))
|
||||
-- ^ Map from a text document version to a PositionMapping that describes how to map
|
||||
-- positions in a version of that document to positions in the latest version
|
||||
,inProgress :: Var (Map NormalizedFilePath Int)
|
||||
,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
|
||||
-- ^ How many rules are running for each file
|
||||
}
|
||||
|
||||
@ -200,14 +199,14 @@ valueVersion = \case
|
||||
Failed -> Nothing
|
||||
|
||||
mappingForVersion
|
||||
:: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
|
||||
:: HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping)
|
||||
-> NormalizedFilePath
|
||||
-> TextDocumentVersion
|
||||
-> PositionMapping
|
||||
mappingForVersion allMappings file ver =
|
||||
fromMaybe idMapping $
|
||||
Map.lookup ver =<<
|
||||
Map.lookup (filePathToUri' file) allMappings
|
||||
HMap.lookup (filePathToUri' file) allMappings
|
||||
|
||||
type IdeRule k v =
|
||||
( Shake.RuleResult k ~ v
|
||||
@ -301,14 +300,14 @@ shakeOpen :: IO LSP.LspId
|
||||
-> Rules ()
|
||||
-> IO IdeState
|
||||
shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
|
||||
inProgress <- newVar Map.empty
|
||||
inProgress <- newVar HMap.empty
|
||||
shakeExtras <- do
|
||||
globals <- newVar HMap.empty
|
||||
state <- newVar HMap.empty
|
||||
diagnostics <- newVar mempty
|
||||
hiddenDiagnostics <- newVar mempty
|
||||
publishedDiagnostics <- newVar mempty
|
||||
positionMapping <- newVar Map.empty
|
||||
positionMapping <- newVar HMap.empty
|
||||
pure ShakeExtras{..}
|
||||
(shakeDb, shakeClose) <-
|
||||
shakeOpenDatabase
|
||||
@ -323,7 +322,7 @@ shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress r
|
||||
shakeDb <- shakeDb
|
||||
return IdeState{..}
|
||||
|
||||
lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO ()
|
||||
lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
|
||||
lspShakeProgress getLspId sendMsg inProgress = do
|
||||
-- first sleep a bit, so we only show progress messages if it's going to take
|
||||
-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
|
||||
@ -356,8 +355,8 @@ lspShakeProgress getLspId sendMsg inProgress = do
|
||||
loop id prev = do
|
||||
sleep sample
|
||||
current <- readVar inProgress
|
||||
let done = length $ filter (== 0) $ Map.elems current
|
||||
let todo = Map.size current
|
||||
let done = length $ filter (== 0) $ HMap.elems current
|
||||
let todo = HMap.size current
|
||||
let next = Just $ T.pack $ show done <> "/" <> show todo
|
||||
when (next /= prev) $
|
||||
sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
|
||||
@ -452,9 +451,9 @@ garbageCollect keep = do
|
||||
return $! dupe values
|
||||
modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
|
||||
modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
|
||||
modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
|
||||
modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
|
||||
let versionsForFile =
|
||||
Map.fromListWith Set.union $
|
||||
HMap.fromListWith Set.union $
|
||||
mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
|
||||
HMap.toList newState
|
||||
modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
|
||||
@ -534,9 +533,9 @@ usesWithStale key files = do
|
||||
mapM (uncurry lastValue) (zip files values)
|
||||
|
||||
|
||||
withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b
|
||||
withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
|
||||
withProgress var file = actionBracket (f succ) (const $ f pred) . const
|
||||
where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file
|
||||
where f shift = modifyVar_ var $ return . HMap.alter (Just . shift . fromMaybe 0) file
|
||||
|
||||
|
||||
defineEarlyCutoff
|
||||
@ -724,10 +723,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
|
||||
let delay = if null newDiags then 0.1 else 0
|
||||
registerEvent debouncer delay uri $ do
|
||||
mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
|
||||
let lastPublish = Map.findWithDefault [] uri published
|
||||
let lastPublish = HMap.lookupDefault [] uri published
|
||||
when (lastPublish /= newDiags) $
|
||||
eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
|
||||
pure $! Map.insert uri newDiags published
|
||||
pure $! HMap.insert uri newDiags published
|
||||
|
||||
publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
|
||||
publishDiagnosticsNotification uri diags =
|
||||
@ -818,19 +817,18 @@ filterDiagnostics keep =
|
||||
HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
|
||||
|
||||
filterVersionMap
|
||||
:: Map NormalizedUri (Set.Set TextDocumentVersion)
|
||||
-> Map NormalizedUri (Map TextDocumentVersion a)
|
||||
-> Map NormalizedUri (Map TextDocumentVersion a)
|
||||
:: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
|
||||
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
|
||||
-> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
|
||||
filterVersionMap =
|
||||
Map.merge Map.dropMissing Map.dropMissing $
|
||||
Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
|
||||
HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
|
||||
|
||||
updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
|
||||
updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
|
||||
modifyVar_ positionMapping $ \allMappings -> do
|
||||
let uri = toNormalizedUri _uri
|
||||
let mappingForUri = Map.findWithDefault Map.empty uri allMappings
|
||||
let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
|
||||
let updatedMapping =
|
||||
Map.insert _version idMapping $
|
||||
Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
|
||||
pure $! Map.insert uri updatedMapping allMappings
|
||||
pure $! HMap.insert uri updatedMapping allMappings
|
||||
|
||||
@ -29,6 +29,8 @@ import Data.List
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Data.Either
|
||||
import Data.Graph
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.IntMap (IntMap)
|
||||
@ -36,8 +38,6 @@ import qualified Data.IntMap.Strict as IntMap
|
||||
import qualified Data.IntMap.Lazy as IntMapLazy
|
||||
import Data.IntSet (IntSet)
|
||||
import qualified Data.IntSet as IntSet
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map.Strict as MS
|
||||
import Data.Maybe
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
@ -68,32 +68,32 @@ newtype FilePathId = FilePathId { getFilePathId :: Int }
|
||||
|
||||
data PathIdMap = PathIdMap
|
||||
{ idToPathMap :: !(IntMap NormalizedFilePath)
|
||||
, pathToIdMap :: !(Map NormalizedFilePath FilePathId)
|
||||
, pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance NFData PathIdMap
|
||||
|
||||
emptyPathIdMap :: PathIdMap
|
||||
emptyPathIdMap = PathIdMap IntMap.empty MS.empty
|
||||
emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
|
||||
|
||||
getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
|
||||
getPathId path m@PathIdMap{..} =
|
||||
case MS.lookup path pathToIdMap of
|
||||
case HMS.lookup path pathToIdMap of
|
||||
Nothing ->
|
||||
let !newId = FilePathId $ MS.size pathToIdMap
|
||||
let !newId = FilePathId $ HMS.size pathToIdMap
|
||||
in (newId, insertPathId path newId m)
|
||||
Just id -> (id, m)
|
||||
|
||||
insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
|
||||
insertPathId path id PathIdMap{..} =
|
||||
PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)
|
||||
PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert path id pathToIdMap)
|
||||
|
||||
insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
|
||||
insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
|
||||
|
||||
pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
|
||||
pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path
|
||||
pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
|
||||
|
||||
idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
|
||||
idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
|
||||
|
||||
@ -20,7 +20,7 @@ import Development.IDE.Types.Logger
|
||||
import Control.Monad.Extra
|
||||
import Data.Foldable as F
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.HashSet as S
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Development.IDE.Core.FileStore (setSomethingModified)
|
||||
@ -69,4 +69,4 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
|
||||
logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
|
||||
modifyFileExists ide events
|
||||
setSomethingModified ide
|
||||
}
|
||||
}
|
||||
|
||||
@ -19,6 +19,7 @@ extra-deps:
|
||||
- regex-tdfa-1.3.1.0
|
||||
- parser-combinators-1.2.1
|
||||
- haddock-library-1.8.0
|
||||
- unordered-containers-0.2.10.0
|
||||
nix:
|
||||
packages: [zlib]
|
||||
allow-newer: true
|
||||
|
||||
Loading…
Reference in New Issue
Block a user