diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index bf88a55ed3..9c93aecc08 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -135,6 +135,7 @@ library Development.IDE.Core.FileStore Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration + Development.IDE.Core.InputPath Development.IDE.Core.OfInterest Development.IDE.Core.PluginUtils Development.IDE.Core.PositionMapping diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 280cd14028..39533182ae 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,6 +27,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph +import Development.IDE.Graph.Internal.RuleInput import Development.IDE.Types.Location import Development.IDE.Types.Options import Development.IDE.Types.Shake (toKey) @@ -39,6 +41,7 @@ import Language.LSP.Server hiding (getVirtualFile) import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob +import Development.IDE.Core.InputPath (InputPath (InputPath)) {- Note [File existence cache and LSP file watchers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -133,7 +136,7 @@ fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- -- | Returns True if the file exists -getFileExists :: NormalizedFilePath -> Action Bool +getFileExists :: HasInput i AllHaskellFiles => InputPath i -> Action Bool getFileExists fp = use_ GetFileExists fp {- Note [Which files should we watch?] @@ -167,7 +170,7 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules () +fileExistsRules :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> Rules () fileExistsRules recorder lspEnv = do supportsWatchedFiles <- case lspEnv of Nothing -> pure False @@ -189,15 +192,18 @@ fileExistsRules recorder lspEnv = do else const $ pure False if supportsWatchedFiles - then fileExistsRulesFast recorder isWatched - else fileExistsRulesSlow recorder + then fileExistsRulesFast @i recorder isWatched + else fileExistsRulesSlow @i recorder - fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched + fileStoreRules @i (cmapWithPrio LogFileStore recorder) (\(InputPath f) -> isWatched f) -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileExistsRulesFast :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileExistsRulesFast recorder isWatched = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics runGetFileExists + where + runGetFileExists :: GetFileExists -> InputPath i -> Action (Maybe BS.ByteString, Maybe Bool) + runGetFileExists GetFileExists (InputPath file) = do isWF <- isWatched file if isWF then fileExistsFast file @@ -236,9 +242,12 @@ fileExistsFast file = do summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules () +fileExistsRulesSlow :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Rules () fileExistsRulesSlow recorder = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics runGetFileExists + where + runGetFileExists :: GetFileExists -> InputPath i -> Action (Maybe BS.ByteString, Maybe Bool) + runGetFileExists GetFileExists (InputPath file) = fileExistsSlow file fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsSlow file = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 6c0cb875b0..31d6a918e1 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore( @@ -42,6 +43,7 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Orphans () import Development.IDE.Graph +import Development.IDE.Graph.Internal.RuleInput import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location @@ -69,6 +71,7 @@ import Language.LSP.VFS import System.FilePath import System.IO.Error import System.IO.Unsafe +import Development.IDE.Core.InputPath (InputPath (unInputPath), partitionInputs, PartitionedInputs (projectFiles, dependencyFiles)) data Log @@ -88,31 +91,35 @@ instance Pretty Log where <+> pretty (fmap (fmap show) reverseDepPaths) LogShake msg -> pretty msg -addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +addWatchedFileRule :: HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> (InputPath i -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f - isWp <- isWorkspaceFile f + isWp <- isWorkspaceFile $ unInputPath f if isAlreadyWatched then pure (Just True) else if not isWp then pure (Just False) else do ShakeExtras{lspEnv} <- getShakeExtras case lspEnv of Just env -> fmap Just $ liftIO $ LSP.runLspT env $ - registerFileWatches [fromNormalizedFilePath f] + registerFileWatches [fromNormalizedFilePath (unInputPath f)] Nothing -> pure $ Just False -getModificationTimeRule :: Recorder (WithPriority Log) -> Rules () -getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> - getModificationTimeImpl missingFileDiags file +getModificationTimeRule :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Rules () +getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule runGetModificationTimeImpl + where + runGetModificationTimeImpl :: GetModificationTime -> InputPath i -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) + runGetModificationTimeImpl (GetModificationTime_ missingFileDiags) file = + getModificationTimeImpl missingFileDiags file getModificationTimeImpl - :: Bool - -> NormalizedFilePath + :: HasInput i AllHaskellFiles + => Bool + -> InputPath i -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) getModificationTimeImpl missingFileDiags file = do - let file' = fromNormalizedFilePath file + let file' = fromNormalizedFilePath $ unInputPath file let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) - mbVf <- getVirtualFile file + mbVf <- getVirtualFile $ unInputPath file case mbVf of Just (virtualFileVersion -> ver) -> do alwaysRerun @@ -124,7 +131,7 @@ getModificationTimeImpl missingFileDiags file = do -- but also need a dependency on IsFileOfInterest to reinstall -- alwaysRerun when the file becomes VFS void (use_ IsFileOfInterest file) - else if isInterface file + else if isInterface (unInputPath file) then -- interface files are tracked specially using the closed world assumption pure () else -- in all other cases we will need to freshly check the file system @@ -134,7 +141,7 @@ getModificationTimeImpl missingFileDiags file = do `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) + diag = ideErrorText (unInputPath file) (T.pack err) if isDoesNotExistError e && not missingFileDiags then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) @@ -170,23 +177,27 @@ modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: Recorder (WithPriority Log) -> Rules () -getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file +getFileContentsRule :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> Rules () +getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) runGetFileContentsImpl + where + runGetFileContentsImpl :: GetFileContents -> InputPath i -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) + runGetFileContentsImpl GetFileContents file = getFileContentsImpl file getFileContentsImpl - :: NormalizedFilePath + :: HasInput i AllHaskellFiles + => InputPath i -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff time <- use_ GetModificationTime file res <- do - mbVirtual <- getVirtualFile file + mbVirtual <- getVirtualFile $ unInputPath file pure $ virtualFileText <$> mbVirtual pure ([], Just (time, res)) -- | Returns the modification time and the contents. -- For VFS paths, the modification time is the current time. -getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) +getFileContents :: HasInput i AllHaskellFiles => InputPath i -> Action (UTCTime, Maybe T.Text) getFileContents f = do (fv, txt) <- use_ GetFileContents f modTime <- case modificationTime fv of @@ -196,14 +207,14 @@ getFileContents f = do liftIO $ case foi of IsFOI Modified{} -> getCurrentTime _ -> do - posix <- getModTime $ fromNormalizedFilePath f + posix <- getModTime $ fromNormalizedFilePath $ unInputPath f pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules :: forall i. HasInput i AllHaskellFiles => Recorder (WithPriority Log) -> (InputPath i -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do - getModificationTimeRule recorder - getFileContentsRule recorder + getModificationTimeRule @i recorder + getFileContentsRule @i recorder addWatchedFileRule recorder isWatched -- | Note that some buffer for a specific file has been modified but not @@ -239,7 +250,9 @@ typecheckParentsAction recorder nfp = do Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs - void $ uses GetModIface rs + let partitionedInputs = partitionInputs rs + void $ uses GetModIface (projectFiles partitionedInputs) + void $ uses GetModIface (dependencyFiles partitionedInputs) -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that diff --git a/ghcide/src/Development/IDE/Core/InputPath.hs b/ghcide/src/Development/IDE/Core/InputPath.hs new file mode 100644 index 0000000000..9bb7cdc861 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/InputPath.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Core.InputPath where + +import Control.DeepSeq +import Data.Hashable +import Data.List (isInfixOf) +import Data.Typeable +import Development.IDE.Types.Location (emptyFilePath) +import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) +import System.FilePath (splitDirectories) + +data InputClass + = ProjectHaskellFiles + | AllHaskellFiles + +newtype InputPath (i :: InputClass) = + InputPath { unInputPath :: NormalizedFilePath } + deriving newtype (Eq, Hashable, NFData, Typeable, Show) + +class HasNormalizedFilePath input where + getNormalizedFilePath :: input -> NormalizedFilePath + +instance HasNormalizedFilePath (InputPath ProjectHaskellFiles) where + getNormalizedFilePath (InputPath nfp) = nfp + +instance HasNormalizedFilePath (InputPath AllHaskellFiles) where + getNormalizedFilePath (InputPath nfp) = nfp + +instance HasNormalizedFilePath () where + getNormalizedFilePath _ = emptyFilePath + +-- All Haskell files are valid, and we assume all +-- files are Haskell files (for now) so there is +-- no need to filter out any FilePaths. +classifyAllHaskellInputs :: [NormalizedFilePath] -> [InputPath ProjectHaskellFiles] +classifyAllHaskellInputs = map InputPath + +-- Dependency files should not be considered +-- ProjectHaskellFiles, so we filter them out +-- before classifying all other files as +-- ProjectHaskellFiles. +classifyProjectHaskellInputs :: [NormalizedFilePath] -> [InputPath ProjectHaskellFiles] +classifyProjectHaskellInputs = foldr classifyInputPath [] + where + classifyInputPath :: NormalizedFilePath -> [InputPath ProjectHaskellFiles] -> [InputPath ProjectHaskellFiles] + classifyInputPath nfp projectInputs = + case dependencyDirectory `isInfixOf` rawInput of + -- The input is a dependency, so don't include + -- it in the project inputs. + True -> projectInputs + -- The input is not a depencency, so include it + -- in the project inputs + False -> InputPath nfp : projectInputs + where + dependencyDirectory :: [FilePath] + dependencyDirectory = [".hls", "dependencies"] + rawInput :: [FilePath] + rawInput = splitDirectories (fromNormalizedFilePath nfp) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 3d60669f5c..8d9f9d6e4f 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -23,6 +23,7 @@ import Data.Hashable import qualified Data.Map as M import Data.Time.Clock.POSIX import Data.Typeable +import Development.IDE.Core.InputPath import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Compat.Util @@ -65,21 +66,26 @@ encodeLinkableType (Just ObjectLinkable) = "2" -- | The parse tree for the file using GetFileContents type instance RuleResult GetParsedModule = ParsedModule +type instance RuleInput GetParsedModule = InputPath AllHaskellFiles -- | The parse tree for the file using GetFileContents, -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule +type instance RuleInput GetParsedModuleWithComments = InputPath AllHaskellFiles type instance RuleResult GetModuleGraph = DependencyInformation +type instance RuleInput GetModuleGraph = () data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets instance NFData GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets +type instance RuleInput GetKnownTargets = () -- | Convert to Core, requires TypeCheck* type instance RuleResult GenerateCore = ModGuts +type instance RuleInput GenerateCore = InputPath ProjectHaskellFiles data GenerateCore = GenerateCore deriving (Eq, Show, Typeable, Generic) @@ -87,6 +93,7 @@ instance Hashable GenerateCore instance NFData GenerateCore type instance RuleResult GetLinkable = LinkableResult +type instance RuleInput GetLinkable = InputPath ProjectHaskellFiles data LinkableResult = LinkableResult @@ -112,6 +119,7 @@ instance Hashable GetImportMap instance NFData GetImportMap type instance RuleResult GetImportMap = ImportMap +type instance RuleInput GetImportMap = InputPath ProjectHaskellFiles newtype ImportMap = ImportMap { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? } deriving stock Show @@ -232,12 +240,15 @@ instance Show HieAstResult where -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult +type instance RuleInput TypeCheck = InputPath ProjectHaskellFiles -- | The uncompressed HieAST type instance RuleResult GetHieAst = HieAstResult +type instance RuleInput GetHieAst = InputPath AllHaskellFiles -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings +type instance RuleInput GetBindings = InputPath ProjectHaskellFiles data DocAndTyThingMap = DKMap {getDocMap :: !DocMap, getTyThingMap :: !TyThingMap} instance NFData DocAndTyThingMap where @@ -247,39 +258,50 @@ instance Show DocAndTyThingMap where show = const "docmap" type instance RuleResult GetDocMap = DocAndTyThingMap +type instance RuleInput GetDocMap = InputPath ProjectHaskellFiles -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq +type instance RuleInput GhcSession = InputPath ProjectHaskellFiles -- | A GHC session preloaded with all the dependencies -- This rule is also responsible for calling ReportImportCycles for the direct dependencies type instance RuleResult GhcSessionDeps = HscEnvEq +type instance RuleInput GhcSessionDeps = InputPath ProjectHaskellFiles -- | Resolve the imports in a module to the file path of a module in the same package type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] +type instance RuleInput GetLocatedImports = InputPath ProjectHaskellFiles -- | This rule is used to report import cycles. It depends on GetModuleGraph. -- We cannot report the cycles directly from GetModuleGraph since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () +type instance RuleInput ReportImportCycles = InputPath ProjectHaskellFiles -- | Read the module interface file from disk. Throws an error for VFS files. -- This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDisk = HiFileResult +type instance RuleInput GetModIfaceFromDisk = InputPath ProjectHaskellFiles -- | GetModIfaceFromDisk and index the `.hie` file into the database. -- This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult +type instance RuleInput GetModIfaceFromDiskAndIndex = InputPath ProjectHaskellFiles -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult +type instance RuleInput GetModIface = InputPath AllHaskellFiles -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. type instance RuleResult GetFileContents = (FileVersion, Maybe Text) +type instance RuleInput GetFileContents = InputPath AllHaskellFiles type instance RuleResult GetFileExists = Bool +type instance RuleInput GetFileExists = InputPath AllHaskellFiles type instance RuleResult AddWatchedFile = Bool +type instance RuleInput AddWatchedFile = InputPath AllHaskellFiles -- The Shake key type for getModificationTime queries @@ -309,6 +331,7 @@ pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +type instance RuleInput GetModificationTime = InputPath AllHaskellFiles -- | Either the mtime from disk or an LSP version -- LSP versions always compare as greater than on disk versions @@ -351,6 +374,7 @@ instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult +type instance RuleInput IsFileOfInterest = InputPath AllHaskellFiles data ModSummaryResult = ModSummaryResult { msrModSummary :: !ModSummary @@ -373,9 +397,11 @@ instance NFData ModSummaryResult where -- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. -- without needing to parse the entire source type instance RuleResult GetModSummary = ModSummaryResult +type instance RuleInput GetModSummary = InputPath AllHaskellFiles -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleInput GetModSummaryWithoutTimestamps = InputPath AllHaskellFiles data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) @@ -394,6 +420,7 @@ instance NFData GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Maybe LinkableType +type instance RuleInput NeedsCompilation = InputPath ProjectHaskellFiles data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Typeable, Generic) @@ -487,6 +514,7 @@ instance Hashable GetClientSettings instance NFData GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) +type instance RuleInput GetClientSettings = () data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) instance Hashable AddWatchedFile @@ -497,6 +525,7 @@ instance NFData AddWatchedFile -- thread killed exception issues, so we lift it to a full rule. -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547 type instance RuleResult GhcSessionIO = IdeGhcSession +type instance RuleInput GhcSessionIO = InputPath ProjectHaskellFiles data IdeGhcSession = IdeGhcSession { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index b0d61579cc..c285ca7f19 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -101,6 +101,7 @@ import Development.IDE.Core.FileExists hiding (Log, import Development.IDE.Core.FileStore (getFileContents, getModTime) import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.InputPath import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.PositionMapping @@ -125,6 +126,7 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph +import Development.IDE.Graph.Internal.RuleInput import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint as AtPoint @@ -226,12 +228,14 @@ getSourceFileSource nfp = do Just source -> pure $ T.encodeUtf8 source -- | Parse the contents of a haskell file. -getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModule :: IdeRule GetParsedModule i is ParsedModule + => InputPath i -> Action (Maybe ParsedModule) getParsedModule = use GetParsedModule -- | Parse the contents of a haskell file, -- ensuring comments are preserved in annotations -getParsedModuleWithComments :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModuleWithComments :: IdeRule GetParsedModuleWithComments i is ParsedModule + => InputPath i -> Action (Maybe ParsedModule) getParsedModuleWithComments = use GetParsedModuleWithComments ------------------------------------------------------------ @@ -259,7 +263,7 @@ getParsedModuleRule recorder = -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information -- but we no longer need to parse with and without Haddocks separately for above GHC90. - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt (unInputPath file) (withOptHaddock ms) withOptHaddock :: ModSummary -> ModSummary withOptHaddock = withOption Opt_Haddock @@ -286,7 +290,7 @@ getParsedModuleWithCommentsRule recorder = let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms'' + liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt (unInputPath file) ms'' getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do @@ -367,7 +371,9 @@ execRawDepM act = -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) +rawDependencyInformation :: forall i is + . IdeRule GetModSummaryWithoutTimestamps i is ModSummaryResult + => [InputPath i] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss @@ -377,15 +383,15 @@ rawDependencyInformation fs = do mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff zipWithM go ff mss - go :: NormalizedFilePath -- ^ Current module being processed + go :: InputPath i -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module -> RawDepM FilePathId go f mbModSum = do -- First check to see if we have already processed the FilePath -- If we have, just return its Id but don't update any of the state. -- Otherwise, we need to process its imports. - checkAlreadyProcessed f $ do - let al = modSummaryToArtifactsLocation f mbModSum + checkAlreadyProcessed (unInputPath f) $ do + let al = modSummaryToArtifactsLocation (unInputPath f) mbModSum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Record this module and its location @@ -412,7 +418,7 @@ rawDependencyInformation fs = do (mns, ls) = unzip with_file -- Recursively process all the imports we just learnt about -- and get back a list of their FilePathIds - fids <- goPlural $ map artifactFilePath ls + fids <- goPlural $ map (InputPath @i . artifactFilePath) ls -- Associate together the ModuleName with the FilePathId let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids) -- Insert into the map the information about this modules @@ -468,7 +474,7 @@ reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do DependencyInformation{..} <- useNoFile_ GetModuleGraph - case pathToId depPathIdMap file of + case pathToId depPathIdMap (unInputPath file) of -- The header of the file does not parse, so it can't be part of any import cycles. Nothing -> pure [] Just fileId -> @@ -479,7 +485,7 @@ reportImportCyclesRule recorder = -- Convert cycles of files into cycles of module names forM cycles $ \(imp, files) -> do modNames <- forM files $ - getModuleName . idToPath depPathIdMap + getModuleName . InputPath . idToPath depPathIdMap pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) @@ -521,7 +527,8 @@ persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybe del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) -getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) +getHieAstRuleDefinition :: IdeRule IsFileOfInterest i is IsFileOfInterestResult + => InputPath i -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do (diags, masts) <- liftIO $ generateHieAsts hsc tmr se <- getShakeExtras @@ -531,13 +538,13 @@ getHieAstRuleDefinition f hsc tmr = do IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath f + toJSON $ fromNormalizedFilePath $ unInputPath f pure [] _ | Just asts <- masts -> do - source <- getSourceFileSource f + source <- getSourceFileSource $ unInputPath f let exports = tcg_exports $ tmrTypechecked tmr modSummary = tmrModSummary tmr - liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source + liftIO $ writeAndIndexHieFile hsc se modSummary (unInputPath f) exports asts source _ -> pure [] let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts @@ -605,7 +612,7 @@ typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck fi -- Keeping typechecked modules in memory for other files is -- very expensive. when (foi == NotFOI) $ - logWith recorder Logger.Warning $ LogTypecheckedFOI file + logWith recorder Logger.Warning $ LogTypecheckedFOI $ unInputPath file typeCheckRuleDefinition hsc pm knownFilesRule :: Recorder (WithPriority Log) -> Rules () @@ -617,13 +624,15 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - dependencyInfoForFiles (HashSet.toList fs) + dependencyInfoForFiles (map (InputPath @ProjectHaskellFile) $ HashSet.toList fs) -dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) +dependencyInfoForFiles :: forall i is + . IdeRule GetModSummaryWithoutTimestamps i is ModSummaryResult + => [InputPath i] -> Action (BS.ByteString, DependencyInformation) dependencyInfoForFiles fs = do (rawDepInfo, bm) <- rawDependencyInformation fs let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo - msrs <- uses GetModSummaryWithoutTimestamps all_fs + msrs <- uses GetModSummaryWithoutTimestamps $ map (InputPath @i) all_fs let mss = map (fmap msrModSummary) msrs let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss @@ -649,7 +658,7 @@ typeCheckRuleDefinition hsc pm = do unlift <- askUnliftIO let dets = TypecheckHelpers - { getLinkables = unliftIO unlift . uses_ GetLinkable + { getLinkables = unliftIO unlift . uses_ GetLinkable . map InputPath } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -659,7 +668,7 @@ typeCheckRuleDefinition hsc pm = do r@(_, mtc) <- a forM_ mtc $ \tc -> do used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc - void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) + void $ uses_ GetModificationTime (map (InputPath . toNormalizedFilePath') used_files) return r -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. @@ -695,7 +704,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO -- loading is always returning a absolute path now - (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath $ unInputPath file -- add the deps to the Shake graph let addDependency fp = do @@ -703,7 +712,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do - use_ GetModificationTime nfp + use_ GetModificationTime $ InputPath nfp mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) @@ -730,7 +739,7 @@ instance Default GhcSessionDepsConfig where ghcSessionDepsDefinition :: -- | full mod summary Bool -> - GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) + GhcSessionDepsConfig -> HscEnvEq -> InputPath i -> Action (Maybe HscEnvEq) ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do let hsc = hscEnv env @@ -743,8 +752,8 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file - depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps - ifaces <- uses_ GetModIface deps + depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) (map InputPath deps) + ifaces <- uses_ GetModIface $ map InputPath deps let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces mg <- do if fullModuleGraph @@ -755,7 +764,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do -- also points to all the direct descendants of the current module. To get the keys for the descendants -- we must get their `ModSummary`s !final_deps <- do - dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps + dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps (map InputPath deps) return $!! map (NodeKey_Module . msKey) dep_mss let module_graph_nodes = nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) @@ -788,9 +797,9 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco recompInfo = RecompilationInfo { source_version = ver , old_value = m_old - , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} - , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs - , regenerate = regenerateHiFile session f ms + , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} . InputPath + , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface (map InputPath fs) + , regenerate = regenerateHiFile session (unInputPath f) ms } r <- loadInterface (hscEnv session) ms linkableType recompInfo case r of @@ -818,7 +827,7 @@ getModIfaceFromDiskAndIndexRule recorder = let ms = hirModSummary x hie_loc = Compat.ml_hie_file $ ms_location ms fileHash <- liftIO $ Util.getFileHash hie_loc - mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) + mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath $ unInputPath f)) let hie_loc' = HieDb.hieModuleHieFile <$> mrow case mrow of Just row @@ -828,7 +837,7 @@ getModIfaceFromDiskAndIndexRule recorder = -- All good, the db has indexed the file when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath f + toJSON $ fromNormalizedFilePath $ unInputPath f -- Not in db, must re-index _ -> do ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ @@ -838,8 +847,8 @@ getModIfaceFromDiskAndIndexRule recorder = Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err -- can just re-index the file we read from disk Right hf -> liftIO $ do - logWith recorder Logger.Debug $ LogReindexingHieFile f - indexHieFile se ms f fileHash hf + logWith recorder Logger.Debug $ LogReindexingHieFile $ unInputPath f + indexHieFile se ms (unInputPath f) fileHash hf return (Just x) @@ -1089,7 +1098,7 @@ getLinkableRule recorder = return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH -getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) +getLinkableType :: InputPath i -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e37c3741c7..dde9e9c878 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -121,6 +122,7 @@ import Data.Vector (Vector) import qualified Data.Vector as Vector import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) +import Development.IDE.Core.InputPath import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes @@ -180,7 +182,6 @@ import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra import UnliftIO (MonadUnliftIO (withRunInIO)) - data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int @@ -384,7 +385,7 @@ getPluginConfigAction plId = do -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before. -addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () +addPersistentRule :: IdeRule k i v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) @@ -452,8 +453,8 @@ getIdeOptionsIO ide = do -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) -lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do +lastValueIO :: IdeRule k i v => ShakeExtras -> k -> i -> IO (Maybe (v, PositionMapping)) +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k input = do let readPersistent | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests @@ -463,20 +464,20 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do mv <- runMaybeT $ do liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k) f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap - (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file + (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f input MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> atomicallyNamed "lastValueIO 1" $ do - STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state + STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k input) state return Nothing Just (v,del,mbVer) -> do actual_version <- case mbVer of Just ver -> pure (Just $ VFSVersion ver) - Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) + Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath $ getNormalizedFilePath input)) `catch` (\(_ :: IOException) -> pure Nothing) atomicallyNamed "lastValueIO 2" $ do - STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state - Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version + STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k input) state + Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping (getNormalizedFilePath input) actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics @@ -486,19 +487,19 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case + atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k input) state) >>= \case Nothing -> readPersistent Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> - atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping file ver + atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping (getNormalizedFilePath input) ver Stale del ver (fromDynamic -> Just v) -> - atomicallyNamed "lastValueIO 6" $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping file ver + atomicallyNamed "lastValueIO 6" $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping (getNormalizedFilePath input) ver Failed p | not p -> readPersistent _ -> pure Nothing -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) +lastValue :: IdeRule k i v => k -> i -> Action (Maybe (v, PositionMapping)) lastValue key file = do s <- getShakeExtras liftIO $ lastValueIO s key file @@ -513,9 +514,12 @@ mappingForVersion allMappings file (Just (VFSVersion ver)) = do return $ maybe zeroMapping snd $ EM.lookup ver =<< mapping mappingForVersion _ _ _ = pure zeroMapping -type IdeRule k v = - ( Shake.RuleResult k ~ v +type IdeRule k i v = + ( Shake.RuleInput k ~ i + , Shake.RuleResult k ~ v , Shake.ShakeValue k + , Shake.ShakeValue i + , HasNormalizedFilePath i , Show v , Typeable v , NFData v @@ -581,15 +585,15 @@ shakeDatabaseProfileIO mbProfileDir = do shakeProfileDatabase shakeDb $ dir file return (dir file) -setValues :: IdeRule k v +setValues :: IdeRule k i v => Values -> k - -> NormalizedFilePath + -> i -> Value v -> Vector FileDiagnostic -> STM () -setValues state key file val diags = - STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state +setValues state key input val diags = + STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key input) state -- | Delete the value stored for a given ide build key @@ -607,14 +611,14 @@ deleteValue ShakeExtras{state} key file = do -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: - forall k v. - IdeRule k v => + forall k i v. + IdeRule k i v => Values -> k -> - NormalizedFilePath -> + i -> STM (Maybe (Value v, Vector FileDiagnostic)) -getValues state key file = do - STM.lookup (toKey key file) state >>= \case +getValues state key input = do + STM.lookup (toKey key input) state >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let !r = seqValue $ fmap (fromJust . fromDynamic @v) v @@ -1010,23 +1014,23 @@ preservedKeys checkParents = HSet.fromList $ -- | Define a new Rule without early cutoff define - :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () + :: IdeRule k i v + => Recorder (WithPriority Log) -> (k -> i -> Action (IdeResult v)) -> Rules () define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v defineNoDiagnostics - :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () + :: IdeRule k i v + => Recorder (WithPriority Log) -> (k -> i -> Action (Maybe v)) -> Rules () defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available -use :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe v) -use key file = runIdentity <$> uses key (Identity file) +use :: IdeRule k i v + => k -> i -> Action (Maybe v) +use key input = runIdentity <$> uses key (Identity input) -- | Request a Rule result, it not available return the last computed result, if any, which may be stale -useWithStale :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) +useWithStale :: IdeRule k i v + => k -> i -> Action (Maybe (v, PositionMapping)) useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- |Request a Rule result, it not available return the last computed result @@ -1036,9 +1040,9 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file) -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. -useWithStale_ :: IdeRule k v - => k -> NormalizedFilePath -> Action (v, PositionMapping) -useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) +useWithStale_ :: IdeRule k i v + => k -> i -> Action (v, PositionMapping) +useWithStale_ key input = runIdentity <$> usesWithStale_ key (Identity input) -- |Plural version of 'useWithStale_' -- @@ -1046,9 +1050,9 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) -- none available. -- -- WARNING: Not suitable for PluginHandlers. -usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) -usesWithStale_ key files = do - res <- usesWithStale key files +usesWithStale_ :: (Traversable f, IdeRule k i v) => k -> f i -> Action (f (v, PositionMapping)) +usesWithStale_ key inputs = do + res <- usesWithStale key inputs case sequence res of Nothing -> liftIO $ throwIO $ BadDependency (show key) Just v -> return v @@ -1077,27 +1081,27 @@ data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: -- | Lookup value in the database and return with the stale value immediately -- Will queue an action to refresh the value. -- Might block the first time the rule runs, but never blocks after that. -useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping)) -useWithStaleFast key file = stale <$> useWithStaleFast' key file +useWithStaleFast :: IdeRule k i v => k -> i -> IdeAction (Maybe (v, PositionMapping)) +useWithStaleFast key input = stale <$> useWithStaleFast' key input -- | Same as useWithStaleFast but lets you wait for an up to date result -useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v) -useWithStaleFast' key file = do +useWithStaleFast' :: IdeRule k i v => k -> i -> IdeAction (FastResult v) +useWithStaleFast' key input = do -- This lookup directly looks up the key in the shake database and -- returns the last value that was computed for this key without -- checking freshness. -- Async trigger the key to be built anyway because we want to -- keep updating the value in the key. - waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file + waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath (getNormalizedFilePath input)) Debug $ use key input s@ShakeExtras{state} <- askShake - r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file + r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key input liftIO $ case r of -- block for the result if we haven't computed before Nothing -> do -- Check if we can get a stale value from disk - res <- lastValueIO s key file + res <- lastValueIO s key input case res of Nothing -> do a <- waitValue @@ -1105,11 +1109,11 @@ useWithStaleFast' key file = do Just _ -> pure $ FastResult res waitValue -- Otherwise, use the computed value even if it's out of date. Just _ -> do - res <- lastValueIO s key file + res <- lastValueIO s key input pure $ FastResult res waitValue -useNoFile :: IdeRule k v => k -> Action (Maybe v) -useNoFile key = use key emptyFilePath +useNoFile :: forall k is v. IdeRule k () v => k -> Action (Maybe v) +useNoFile key = use key () -- Requests a rule if available. -- @@ -1117,11 +1121,11 @@ useNoFile key = use key emptyFilePath -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `useE` instead. -use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v -use_ key file = runIdentity <$> uses_ key (Identity file) +use_ :: IdeRule k i v => k -> i -> Action v +use_ key input = runIdentity <$> uses_ key (Identity input) -useNoFile_ :: IdeRule k v => k -> Action v -useNoFile_ key = use_ key emptyFilePath +useNoFile_ :: forall k is v. IdeRule k () v => k -> Action v +useNoFile_ key = use_ key () -- |Plural version of `use_` -- @@ -1129,7 +1133,7 @@ useNoFile_ key = use_ key emptyFilePath -- none available. -- -- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. -uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) +uses_ :: (Traversable f, IdeRule k i v) => k -> f i -> Action (f v) uses_ key files = do res <- uses key files case sequence res of @@ -1137,100 +1141,102 @@ uses_ key files = do Just v -> return v -- | Plural version of 'use' -uses :: (Traversable f, IdeRule k v) - => k -> f NormalizedFilePath -> Action (f (Maybe v)) +uses :: (Traversable f, IdeRule k i v) + => k -> f i -> Action (f (Maybe v)) uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files) -- | Return the last computed result which might be stale. -usesWithStale :: (Traversable f, IdeRule k v) - => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping))) -usesWithStale key files = do - _ <- apply (fmap (Q . (key,)) files) +usesWithStale :: (Traversable f, IdeRule k i v) + => k -> f i -> Action (f (Maybe (v, PositionMapping))) +usesWithStale key inputs = do + _ <- apply (fmap (Q . (key,)) inputs) -- We don't look at the result of the 'apply' since 'lastValue' will -- return the most recent successfully computed value regardless of -- whether the rule succeeded or not. - traverse (lastValue key) files + traverse (lastValue key) inputs -useWithoutDependency :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe v) -useWithoutDependency key file = - (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, file))) +useWithoutDependency :: IdeRule k i v + => k -> i -> Action (Maybe v) +useWithoutDependency key input = + (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, input))) -data RuleBody k v - = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) - | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) +data RuleBody k i v + = Rule (k -> i -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleNoDiagnostics (k -> i -> Action (Maybe BS.ByteString, Maybe v)) | RuleWithCustomNewnessCheck { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool - , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) + , build :: k -> i -> Action (Maybe BS.ByteString, Maybe v) } - | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleWithOldValue (k -> i -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) -- | Define a new Rule with early cutoff defineEarlyCutoff - :: IdeRule k v + :: forall k i v + . IdeRule k i v => Recorder (WithPriority Log) - -> RuleBody k v + -> RuleBody k i v -> Rules () -defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do +defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, input)) (old :: Maybe BS.ByteString) mode -> otTracedAction key (getNormalizedFilePath input) mode traceA $ \traceDiagnostics -> do extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags - defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file -defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + updateFileDiagnostics recorder (getNormalizedFilePath input) ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key input old mode $ const $ op key input +defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, input)) (old :: Maybe BS.ByteString) mode -> otTracedAction key (getNormalizedFilePath input) mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do traceDiagnostics diags mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags - defineEarlyCutoff' diagnostics (==) key file old mode $ const $ second (mempty,) <$> op key file + defineEarlyCutoff' diagnostics (==) key input old mode $ const $ second (mempty,) <$> op key input defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = - addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> - otTracedAction key file mode traceA $ \ traceDiagnostics -> do + addRule $ \(Q (key, input)) (old :: Maybe BS.ByteString) mode -> + otTracedAction key (getNormalizedFilePath input) mode traceA $ \ traceDiagnostics -> do let diagnostics _ver diags = do traceDiagnostics diags mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags - defineEarlyCutoff' diagnostics newnessCheck key file old mode $ - const $ second (mempty,) <$> build key file -defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do + defineEarlyCutoff' diagnostics newnessCheck key input old mode $ + const $ second (mempty,) <$> build key input +defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, input)) (old :: Maybe BS.ByteString) mode -> otTracedAction key (getNormalizedFilePath input) mode traceA $ \traceDiagnostics -> do extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags - defineEarlyCutoff' diagnostics (==) key file old mode $ op key file + updateFileDiagnostics recorder (getNormalizedFilePath input) ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + defineEarlyCutoff' diagnostics (==) key input old mode $ op key input -defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () -defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do - if file == emptyFilePath then do res <- f k; return (Just res) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" +defineNoFile :: forall k v. IdeRule k () v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () +defineNoFile recorder f = defineNoDiagnostics recorder $ \k _ -> do + res <- f k + return (Just res) -defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do - if file == emptyFilePath then do (hashString, res) <- f k; return (Just hashString, Just res) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" +defineEarlyCutOffNoFile :: forall k v. IdeRule k () v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k _ -> do + (hashString, res) <- f k + return (Just hashString, Just res) defineEarlyCutoff' - :: forall k v. IdeRule k v + :: forall k i v. IdeRule k i v => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k - -> NormalizedFilePath + -> i -> Maybe BS.ByteString -> RunMode -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) -defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do +defineEarlyCutoff' doDiagnostics cmp key input mbOld mode action = do + let rawFile = getNormalizedFilePath input ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions let trans g x = withRunInIO $ \run -> g (run x) - (if optSkipProgress options key then id else trans (inProgress progress file)) $ do + (if optSkipProgress options key then id else trans (inProgress progress rawFile)) $ do val <- case mbOld of Just old | mode == RunDependenciesSame -> do - mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file + mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key input case mbValue of -- No changes in the dependencies and we have -- an existing successful result. Just (v@(Succeeded _ x), diags) -> do - ver <- estimateFileVersionUnsafely key (Just x) file + ver <- estimateFileVersionUnsafely key (Just x) input doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old (A v) $ return () _ -> return Nothing @@ -1241,7 +1247,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do res <- case val of Just res -> return res Nothing -> do - staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case + staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key input <&> \case Nothing -> Failed False Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v @@ -1249,9 +1255,9 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + pure (Nothing, ([ideErrorText rawFile $ T.pack $ show e | not $ isBadDependency e],Nothing)) - ver <- estimateFileVersionUnsafely key mbRes file + ver <- estimateFileVersionUnsafely key mbRes input (bs, res) <- case mbRes of Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) @@ -1269,8 +1275,8 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do (A res) $ do -- this hook needs to be run in the same transaction as the key is marked clean -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - setValues state key file res (Vector.fromList diags) - modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + setValues state key input res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key input) return res where -- Highly unsafe helper to compute the version of a file @@ -1279,10 +1285,10 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do estimateFileVersionUnsafely :: k -> Maybe v - -> NormalizedFilePath + -> i -> Action (Maybe FileVersion) - estimateFileVersionUnsafely _k v fp - | fp == emptyFilePath = pure Nothing + estimateFileVersionUnsafely _k v input + | Just Refl <- eqT @i @() = pure Nothing | Just Refl <- eqT @k @GetModificationTime = pure v -- GetModificationTime depends on these rules, so avoid creating a cycle | Just Refl <- eqT @k @AddWatchedFile = pure Nothing @@ -1292,7 +1298,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do -- For all other rules - compute the version properly without: -- * creating a dependency: If everything depends on GetModificationTime, we lose early cutoff -- * creating bogus "file does not exists" diagnostics - | otherwise = useWithoutDependency (GetModificationTime_ False) fp + | otherwise = useWithoutDependency (GetModificationTime_ False) (InputPath $ getNormalizedFilePath input) -- Note [Housekeeping rule cache and dirty key outside of hls-graph] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1457,9 +1463,10 @@ kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $ toJSON $ map fromNormalizedFilePath files -- | Add kick start/done signal to rule -runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action () -runWithSignal msgStart msgEnd files rule = do +runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k i v) => Proxy s0 -> Proxy s1 -> [i] -> k -> Action () +runWithSignal msgStart msgEnd inputFiles rule = do + let files = map getNormalizedFilePath inputFiles ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras kickSignal testing lspEnv files msgStart - void $ uses rule files + void $ uses rule inputFiles kickSignal testing lspEnv files msgEnd diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 2083625c43..54b2fd8b44 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -22,6 +22,7 @@ import Data.Dynamic import Data.Hashable import Data.Typeable (cast) import Data.Vector (Vector) +import Development.IDE.Core.InputPath import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes (FileVersion) import Development.IDE.Graph (Key, RuleResult, newKey, @@ -76,30 +77,30 @@ isBadDependency x | Just (_ :: BadDependency) <- fromException x = True | otherwise = False -toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key +toKey :: (Shake.ShakeValue i, HasNormalizedFilePath i, Shake.ShakeValue k) => k -> i -> Key toKey = (newKey.) . curry Q -fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) +fromKey :: (Typeable k, Typeable i) => Key -> Maybe (k, i) fromKey (Key k) - | Just (Q (k', f)) <- cast k = Just (k', f) + | Just (Q (k', i)) <- cast k = Just (k', i) | otherwise = Nothing -- | fromKeyType (Q (k,f)) = (typeOf k, f) -fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath) +fromKeyType :: Key -> Maybe (SomeTypeRep, i) fromKeyType (Key k) = case typeOf k of App (Con tc) a | tc == typeRepTyCon (typeRep @Q) -> case unsafeCoerce k of - Q (_ :: (), f) -> Just (SomeTypeRep a, f) + Q (_ :: (), i) -> Just (SomeTypeRep a, i) _ -> Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key -toNoFileKey k = newKey $ Q (k, emptyFilePath) +toNoFileKey k = newKey $ Q (k, ()) -newtype Q k = Q (k, NormalizedFilePath) +newtype Q k i = Q (k, i) deriving newtype (Eq, Hashable, NFData) -instance Show k => Show (Q k) where - show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file +instance (Show k, HasNormalizedFilePath i) => Show (Q k i) where + show (Q (k, input)) = show k ++ "; " ++ fromNormalizedFilePath (getNormalizedFilePath input) -- | Invariant: the 'v' must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database @@ -110,7 +111,7 @@ instance NFData (A v) where rnf (A v) = v `seq` () -- In the Shake database we only store one type of key/result pairs, -- namely Q (question) / A (answer). -type instance RuleResult (Q k) = A (RuleResult k) +type instance RuleResult (Q k i) = A (RuleResult k) toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 81ad3b3dfd..45f473ec93 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -12,7 +12,7 @@ module Development.IDE.Graph( -- * Explicit parallelism parallel, -- * Oracle rules - ShakeValue, RuleResult, + ShakeValue, RuleResult, RuleInput, -- * Special rules alwaysRerun, -- * Actions for inspecting the keys in the database diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs index 9a5f36ca35..00ff8fe641 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -22,6 +22,7 @@ import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@. type family RuleResult key -- = value +type family RuleInput k -- input - (InputPath inputclass) or () action :: Action a -> Rules () action x = do