diff --git a/bench/Main.hs b/bench/Main.hs index d1ac603b18..dc0c88de3d 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -59,13 +59,14 @@ import Development.Benchmark.Rules hiding (parallelism) import Development.Shake (Action, Change (ChangeModtimeAndDigestInput), CmdOption (Cwd, StdinBS), - RuleResult, Rules, + Rules, ShakeOptions (shakeChange, shakeThreads), actionBracket, addOracle, askOracle, command, command_, getDirectoryFiles, liftIO, need, newCache, shakeArgsWith, shakeOptions, versioned, want) +import qualified Development.Shake as Shake import Development.Shake.Classes import Experiments.Types (Example (exampleName), exampleToOptions) @@ -73,7 +74,7 @@ import GHC.Exts (toList) import GHC.Generics (Generic) import HlsPlugins (idePlugins) import qualified Ide.Plugin.Config as Plugin -import Ide.Types hiding (Config) +import Ide.Types hiding (Config, Rules) import Numeric.Natural (Natural) import System.Console.GetOpt import System.Directory @@ -94,8 +95,8 @@ readConfigIO :: FilePath -> IO (Config BuildSystem) readConfigIO = decodeFileThrow instance IsExample Example where getExampleName = exampleName -type instance RuleResult GetExample = Maybe Example -type instance RuleResult GetExamples = [Example] +type instance Shake.RuleResult GetExample = Maybe Example +type instance Shake.RuleResult GetExamples = [Example] shakeOpts :: ShakeOptions shakeOpts = @@ -185,7 +186,7 @@ disableAllPluginsBut pred = def {Plugin.plugins = pluginsMap} where IdePlugins plugins = idePlugins mempty newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show) -type instance RuleResult GetSamples = Natural +type instance Shake.RuleResult GetSamples = Natural -------------------------------------------------------------------------------- diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs index 4edb4b022b..b5cc6bf0a6 100644 --- a/ghcide-test/exe/Main.hs +++ b/ghcide-test/exe/Main.hs @@ -66,6 +66,7 @@ import RootUriTests import SafeTests import SymlinkTests import THTests +import TypedRuleTests import UnitTests import WatchedFileTests @@ -87,6 +88,7 @@ main = do , PluginSimpleTests.tests , PreprocessorTests.tests , THTests.tests + , TypedRuleTests.tests , SymlinkTests.tests , SafeTests.tests , UnitTests.tests diff --git a/ghcide-test/exe/TypedRuleTests.hs b/ghcide-test/exe/TypedRuleTests.hs new file mode 100644 index 0000000000..6cf2aa505a --- /dev/null +++ b/ghcide-test/exe/TypedRuleTests.hs @@ -0,0 +1,113 @@ +module TypedRuleTests (tests) where + +import Config (testWithDummyPluginEmpty') +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.Core.InputPath +import Development.IDE.Plugin.Test (ideResultSuccess) +import Development.IDE.Test (waitForAction, + waitForActionError) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory, ()) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "typed rules" + [ testGroup "InputPath classifiers" + [ testCase "dependency sources are not project Haskell inputs" $ do + let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs" + toProjectHaskellInput dep @?= Nothing + unInputPath (toAllHaskellInput dep) @?= dep + + , testCase "project Haskell inputs can be generalized to all Haskell inputs" $ do + let src = toNormalizedFilePath' "/work/src/Foo.hs" + case toProjectHaskellInput src of + Nothing -> assertFailure "Expected project source to classify" + Just input -> unInputPath (generalizeProjectInput input) @?= src + + , testCase "specific file classifiers reject unrelated paths" $ do + let cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal" + stackYaml = toNormalizedFilePath' "/work/pkg/stack.yaml" + source = toNormalizedFilePath' "/work/pkg/Foo.hs" + (unInputPath <$> toCabalFileInput cabalFile) @?= Just cabalFile + toCabalFileInput source @?= Nothing + (unInputPath <$> toStackYamlInput stackYaml) @?= Just stackYaml + toStackYamlInput source @?= Nothing + + , testCase "bulk classifiers filter invalid paths" $ do + let projectFile = toNormalizedFilePath' "/work/src/Foo.hs" + depFile = toNormalizedFilePath' "/work/.hls/dependencies/pkg/Foo.hs" + cabalFile = toNormalizedFilePath' "/work/pkg/pkg.cabal" + stackYaml = toNormalizedFilePath' "/work/stack.yaml" + files = [projectFile, depFile, cabalFile, stackYaml] + nonDependencyFiles = [projectFile, cabalFile, stackYaml] + fmap unInputPath (classifyProjectHaskellInputs files) @?= + nonDependencyFiles + fmap unInputPath (classifyCabalFileInputs files) @?= [cabalFile] + fmap unInputPath (classifyStackYamlInputs files) @?= [stackYaml] + + , testCase "dependency classifier does not match similar directory names" $ do + let dep = toNormalizedFilePath' "/work/.hls/dependencies/base/Data/Maybe.hs" + dep2 = toNormalizedFilePath' "/work/.hls/dependencies2/base/Data/Maybe.hs" + dep3 = toNormalizedFilePath' "/work/.hls/dependencies-extra/Foo.hs" + toProjectHaskellInput dep @?= Nothing + assertBool "dependencies2 should remain a project file" (toProjectHaskellInput dep2 /= Nothing) + assertBool "dependencies-extra should remain a project file" (toProjectHaskellInput dep3 /= Nothing) + + , testCase "classifiers preserve ordering" $ do + let a = toNormalizedFilePath' "/work/src/A.hs" + b = toNormalizedFilePath' "/work/src/B.hs" + c = toNormalizedFilePath' "/work/src/C.hs" + + fmap unInputPath (classifyProjectHaskellInputs [a,b,c]) @?= [a,b,c] + + , testCase "project source remains project source after generalization round trip" $ do + let src = toNormalizedFilePath' "/work/src/Foo.hs" + + case toProjectHaskellInput src of + Nothing -> assertFailure "Expected project source" + Just input -> unInputPath (generalizeProjectInput input) @?= src + ] + + , testWithDummyPluginEmpty' "project-only rules reject dependency-source inputs" $ \dir -> do + let dependencyFile = dir ".hls" "dependencies" "pkg" "Data" "Maybe.hs" + dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile) + projectOnlyRules = + [ "typecheck" + , "getLocatedImports" + , "getmodsummary" + , "getmodsummarywithouttimestamps" + , "getparsedmodule" + , "ghcsession" + , "ghcsessiondeps" + ] + liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile) + liftIO $ writeFile dependencyFile "module Data.Maybe where\n" + + forM_ projectOnlyRules $ \rule -> do + err <- waitForActionError rule dependencyDoc + liftIO $ assertBool ("Unexpected error for " <> rule <> ": " <> T.unpack err) $ + "dependency file" `T.isInfixOf` err + + -- Dependency source files still support all-Haskell/file-content rules. + fileContents <- waitForAction "getFileContents" dependencyDoc + liftIO $ assertBool "GetFileContents should accept dependency sources" $ + ideResultSuccess fileContents + + , testWithDummyPluginEmpty' "all-haskell rules continue to accept dependency sources" $ \dir -> do + let dependencyFile = dir ".hls" "dependencies" "pkg" "Foo.hs" + dependencyDoc = TextDocumentIdentifier (filePathToUri dependencyFile) + + liftIO $ createDirectoryIfMissing True (takeDirectory dependencyFile) + liftIO $ writeFile dependencyFile "module Foo where\nx = 1\n" + fileContents <- waitForAction "getFileContents" dependencyDoc + liftIO $ assertBool "GetFileContents should succeed" (ideResultSuccess fileContents) + ] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 01b694ccbc..14498e770c 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -132,6 +132,7 @@ library Development.IDE.Core.FileStore Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration + Development.IDE.Core.InputPath Development.IDE.Core.LookupMod Development.IDE.Core.OfInterest Development.IDE.Core.PluginUtils diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..05ae91e649 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -42,6 +42,7 @@ import Data.Maybe import Data.Proxy import qualified Data.Text as T import Data.Version +import Development.IDE.Core.InputPath import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) @@ -906,9 +907,9 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l unless (null new_components_info || not checkProject) $ do cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' + mmt <- uses GetModificationTime $ classifyAllHaskellInputs cfps' let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist + modIfaces <- uses GetModIface $ classifyProjectHaskellInputs cs_exist -- update exports map shakeExtras <- getShakeExtras let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 7b16f1fa4f..94c95a4686 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -24,6 +24,7 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake +import Development.IDE.Core.InputPath import Development.IDE.GHC.Compat (DynFlags (..), ms_hspp_opts) import Development.IDE.Graph @@ -49,13 +50,13 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [ getAtPoint file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - - (hf, mapping) <- useWithStaleFastMT GetHieAst file + input <- MaybeT $ pure $ toProjectHaskellInput file + (hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input shakeExtras <- lift askShake - env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file - modSummary <- fst <$> useWithStaleFastMT GetModSummary file - dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession input + modSummary <- fst <$> useWithStaleFastMT GetModSummary input + dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap input) let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary)) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) @@ -84,7 +85,7 @@ toCurrentLocation mapping file (Location uri range) = else do otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri - useWithStaleFastMT GetHieAst otherLocationFile + useWithStaleFastMT GetHieAst $ toAllHaskellInput otherLocationFile pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) where nUri :: NormalizedUri @@ -95,8 +96,9 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useWithStaleFastMT GetHieAst file - (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file + input <- MaybeT $ pure $ toProjectHaskellInput file + (hf, mapping) <- useWithStaleFastMT GetHieAst $ generalizeProjectInput input + (ImportMap imports, _) <- useWithStaleFastMT GetImportMap input !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' mapMaybeM (\(location, identifier) -> do @@ -109,7 +111,7 @@ getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Locati getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useWithStaleFastMT GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' mapMaybeM (\(location, identifier) -> do @@ -121,14 +123,14 @@ getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Mayb getImplementationDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useWithStaleFastMT GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos' traverse (MaybeT . toCurrentLocation mapping file) locs highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file + (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' @@ -138,7 +140,7 @@ refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] refsAtPoint file pos = do ShakeExtras{withHieDb} <- getShakeExtras fs <- HM.keys <$> getFilesOfInterestUntracked - asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst (classifyAllHaskellInputs fs) AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 280cd14028..2391eb06b2 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -19,6 +19,7 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe +import Development.IDE.Core.InputPath import Development.IDE.Core.FileStore hiding (Log, LogShake) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration @@ -133,7 +134,7 @@ fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- -- | Returns True if the file exists -getFileExists :: NormalizedFilePath -> Action Bool +getFileExists :: InputPath AllHaskellFiles -> Action Bool getFileExists fp = use_ GetFileExists fp {- Note [Which files should we watch?] @@ -197,7 +198,8 @@ fileExistsRules recorder lspEnv = do -- 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 recorder isWatched = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists input -> do + let file = unInputPath input isWF <- isWatched file if isWF then fileExistsFast file @@ -238,7 +240,8 @@ summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules () fileExistsRulesSlow recorder = - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists input -> + fileExistsSlow (unInputPath input) 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 7d253131d6..fa739265ae 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -41,6 +41,7 @@ import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) +import Development.IDE.Core.InputPath import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake @@ -96,7 +97,8 @@ instance Pretty Log where LogShake msg -> pretty msg addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () -addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do +addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile input -> do + let f = unInputPath input isAlreadyWatched <- isWatched f isWp <- isWorkspaceFile f if isAlreadyWatched then pure (Just True) else @@ -114,9 +116,10 @@ getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco getModificationTimeImpl :: Bool - -> NormalizedFilePath + -> InputPath AllHaskellFiles -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) -getModificationTimeImpl missingFileDiags file = do +getModificationTimeImpl missingFileDiags input = do + let file = unInputPath input let file' = fromNormalizedFilePath file let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) mbVf <- getVirtualFile file @@ -125,12 +128,12 @@ getModificationTimeImpl missingFileDiags file = do alwaysRerun pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver)) Nothing -> do - isWF <- use_ AddWatchedFile file + isWF <- use_ AddWatchedFile input if isWF then -- the file is watched so we can rely on FileWatched notifications, -- but also need a dependency on IsFileOfInterest to reinstall -- alwaysRerun when the file becomes VFS - void (use_ IsFileOfInterest file) + void (use_ IsFileOfInterest input) else if isInterface file then -- interface files are tracked specially using the closed world assumption pure () @@ -152,9 +155,10 @@ getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogSh getPhysicalModificationTimeImpl file getPhysicalModificationTimeImpl - :: NormalizedFilePath + :: InputPath AllHaskellFiles -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) -getPhysicalModificationTimeImpl file = do +getPhysicalModificationTimeImpl input = do + let file = unInputPath input let file' = fromNormalizedFilePath file let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) @@ -208,11 +212,12 @@ getFileContentsRule :: Recorder (WithPriority Log) -> Rules () getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file getFileContentsImpl - :: NormalizedFilePath + :: InputPath AllHaskellFiles -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) -getFileContentsImpl file = do +getFileContentsImpl input = do + let file = unInputPath input -- need to depend on modification time to introduce a dependency with Cutoff - time <- use_ GetModificationTime file + time <- use_ GetModificationTime input res <- do mbVirtual <- getVirtualFile file pure $ _file_text <$> mbVirtual @@ -220,7 +225,7 @@ getFileContentsImpl file = do -- | Returns the modification time and the contents. -- For VFS paths, the modification time is the current time. -getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope) +getFileModTimeContents :: InputPath AllHaskellFiles -> Action (UTCTime, Maybe Rope) getFileModTimeContents f = do (fv, contents) <- use_ GetFileContents f modTime <- case modificationTime fv of @@ -230,16 +235,16 @@ getFileModTimeContents f = do liftIO $ case foi of IsFOI Modified{} -> getCurrentTime _ -> do - posix <- getModTime $ fromNormalizedFilePath f + posix <- getModTime $ fromNormalizedFilePath $ unInputPath f pure $ posixSecondsToUTCTime posix return (modTime, contents) -getFileContents :: NormalizedFilePath -> Action (Maybe Rope) +getFileContents :: InputPath AllHaskellFiles -> Action (Maybe Rope) getFileContents f = snd <$> use_ GetFileContents f getUriContents :: NormalizedUri -> Action (Maybe Rope) getUriContents uri = - join <$> traverse getFileContents (uriToNormalizedFilePath uri) + join <$> traverse (getFileContents . toAllHaskellInput) (uriToNormalizedFilePath uri) -- | Given a text document identifier, annotate it with the latest version. -- @@ -291,12 +296,15 @@ typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) pa typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do - revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp - case revs of + case toProjectHaskellInput nfp of Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp - Just rs -> do - logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs - void $ uses GetModIface rs + Just input -> do + revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph input + case revs of + Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp + Just rs -> do + logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs + void $ uses GetModIface (classifyProjectHaskellInputs rs) -- | 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..d61ac4793f --- /dev/null +++ b/ghcide/src/Development/IDE/Core/InputPath.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Development.IDE.Core.InputPath + ( InputPath + , unInputPath + , unsafeMkInputPath + , toAllHaskellInput + , toCabalFileInput + , toNoFileInput + , toProjectHaskellInput + , toStackYamlInput + , classifyAllHaskellInputs + , classifyCabalFileInputs + , classifyProjectHaskellInputs + , classifyStackYamlInputs + , generalizeProjectInput + , isDependencyInputPath + ) where + +import Control.DeepSeq +import Data.Hashable +import Data.List.Extra (isInfixOf) +import Data.Maybe (mapMaybe) +import Development.IDE.Graph (InputClass (..)) +import Development.IDE.Types.Location +import System.FilePath (splitDirectories, takeExtension, + takeFileName) + +-- | A NormalizedFilePath tagged with the class of rules it may be passed to. +-- +-- The constructor is intentionally not exported. Callers must go through the +-- smart constructors/classifiers in this module, otherwise they could stamp a +-- dependency file as a ProjectHaskellFiles input and bypass the type-level +-- safety we are building. +newtype InputPath (i :: InputClass) = + InputPath { unInputPath :: NormalizedFilePath } + deriving newtype (Eq, Hashable, NFData, Show) + +-- | Construct an InputPath without checking whether the path belongs to the +-- requested input class. +-- +-- This is only for trusted internals that are rehydrating already-typed rule +-- keys from the Shake database. Normal call sites should use the smart +-- constructors below. +unsafeMkInputPath :: NormalizedFilePath -> InputPath i +unsafeMkInputPath = InputPath + +-- | Any Haskell source path HLS may inspect. +-- +-- This includes generated dependency source files. Rules accepting +-- AllHaskellFiles must not assume the file belongs to the project build graph. +toAllHaskellInput :: NormalizedFilePath -> InputPath AllHaskellFiles +toAllHaskellInput = InputPath + +-- | Classify a Cabal package description file. +toCabalFileInput :: NormalizedFilePath -> Maybe (InputPath CabalFile) +toCabalFileInput nfp + | takeExtension (fromNormalizedFilePath nfp) == ".cabal" = Just (InputPath nfp) + | otherwise = Nothing + +-- | Classify a Stack project configuration file. +toStackYamlInput :: NormalizedFilePath -> Maybe (InputPath StackYaml) +toStackYamlInput nfp + | takeFileName (fromNormalizedFilePath nfp) == "stack.yaml" = Just (InputPath nfp) + | otherwise = Nothing + +-- | The sentinel input for rules that do not operate on a real file. +toNoFileInput :: InputPath NoFile +toNoFileInput = InputPath emptyFilePath + +-- | Classify a path as a project Haskell file, if it is safe to do so. +-- +-- Generated dependency files are deliberately rejected here. This is the key +-- boundary that prevents dependency files from reaching project-only rules such +-- as TypeCheck, GenerateCore, GhcSessionDeps, GetModSummary, and completions. +toProjectHaskellInput :: NormalizedFilePath -> Maybe (InputPath ProjectHaskellFiles) +toProjectHaskellInput nfp + | isDependencyInputPath nfp = Nothing + | otherwise = Just (InputPath nfp) + +-- | Classify many files as all-Haskell inputs. +classifyAllHaskellInputs :: [NormalizedFilePath] -> [InputPath AllHaskellFiles] +classifyAllHaskellInputs = map toAllHaskellInput + +-- | Keep only Cabal package description files. +classifyCabalFileInputs :: [NormalizedFilePath] -> [InputPath CabalFile] +classifyCabalFileInputs = mapMaybe toCabalFileInput + +-- | Keep only paths that are safe to pass to project-only rules. +classifyProjectHaskellInputs :: [NormalizedFilePath] -> [InputPath ProjectHaskellFiles] +classifyProjectHaskellInputs = mapMaybe toProjectHaskellInput + +-- | Keep only Stack project configuration files. +classifyStackYamlInputs :: [NormalizedFilePath] -> [InputPath StackYaml] +classifyStackYamlInputs = mapMaybe toStackYamlInput + +-- | A project file can always be used where an all-Haskell file is expected. +-- +-- The opposite direction is intentionally not provided. To go from +-- AllHaskellFiles to ProjectHaskellFiles, callers must classify the raw path +-- through toProjectHaskellInput. +generalizeProjectInput :: InputPath ProjectHaskellFiles -> InputPath AllHaskellFiles +generalizeProjectInput = InputPath . unInputPath + +-- | Detect generated dependency source files. +-- +-- Matches the layout used by the goto-dependency implementation: +-- generated dependency sources live under .hls/dependencies. + +isDependencyInputPath :: NormalizedFilePath -> Bool +isDependencyInputPath nfp = + dependencyDirectory `isInfixOf` splitDirectories (fromNormalizedFilePath nfp) + where + dependencyDirectory :: [FilePath] + dependencyDirectory = [".hls", "dependencies"] diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 19e0f40e24..751b84858b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -31,6 +31,7 @@ import Control.Concurrent.STM.Stats (atomically, import Data.Aeson (toJSON) import qualified Data.ByteString as BS import Data.Maybe (catMaybes) +import Development.IDE.Core.InputPath import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) @@ -66,9 +67,10 @@ ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest input -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked + let f = unInputPath input let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest fp = summarize foi res = (Just fp, Just foi) @@ -132,23 +134,29 @@ scheduleGarbageCollection state = do -- Could be improved kick :: Action () kick = do - files <- HashMap.keys <$> getFilesOfInterestUntracked + filesOfInterestMap <- getFilesOfInterestUntracked ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras let signal :: KnownSymbol s => Proxy s -> Action () signal msg = when testing $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ toJSON $ map fromNormalizedFilePath files + files :: [NormalizedFilePath] + files = HashMap.keys filesOfInterestMap + projectFiles :: [InputPath ProjectHaskellFiles] + projectFiles = classifyProjectHaskellInputs files + haskellFiles :: [InputPath AllHaskellFiles] + haskellFiles = classifyAllHaskellInputs files signal (Proxy @"kick/start") liftIO $ progressUpdate progress ProgressNewStarted -- Update the exports map - results <- uses GenerateCore files - <* uses GetHieAst files + results <- uses GenerateCore projectFiles + <* uses GetHieAst haskellFiles -- needed to have non local completions on the first edit -- when the first edit breaks the module header - <* uses NonLocalCompletions files + <* uses NonLocalCompletions projectFiles let mguts = catMaybes results void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 2b5caf8ff0..cae3e3b8e7 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Development.IDE.Core.PluginUtils (-- * Wrapped Action functions runActionE @@ -42,6 +46,7 @@ import Control.Monad.Trans.Maybe import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore +import Development.IDE.Core.InputPath import Development.IDE.Core.PositionMapping import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (IdeAction, IdeRule, @@ -81,31 +86,32 @@ runActionMT herald ide act = join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) -- |ExceptT version of `use` that throws a PluginRuleFailed upon failure -useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v +useE :: (IdeRule k i v, ToInputArg i a) => k -> a -> ExceptT PluginError Action v useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k -- |MaybeT version of `use` -useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v -useMT k = MaybeT . Shake.use k +useMT :: (IdeRule k i v, ToInputArg i a) => k -> a -> MaybeT Action v +useMT k = MaybeT . maybe (pure Nothing) (Shake.use k) . toInputArg -- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure -usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v) +usesE :: (Traversable f, IdeRule k i v, ToInputArg i a) => k -> f a -> ExceptT PluginError Action (f v) usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k -- |MaybeT version of `uses` -usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v) -usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs +usesMT :: (Traversable f, IdeRule k i v, ToInputArg i a) => k -> f a -> MaybeT Action (f v) +usesMT k xs = MaybeT $ traverse toInputArg xs & maybe (pure Nothing) (fmap sequence . Shake.uses k) -- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon -- failure -useWithStaleE :: IdeRule k v - => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) +useWithStaleE :: (IdeRule k i v, ToInputArg i a) + => k -> a -> ExceptT PluginError Action (v, PositionMapping) useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key -- |MaybeT version of `useWithStale` -useWithStaleMT :: IdeRule k v - => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) -useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) +useWithStaleMT :: (IdeRule k i v, ToInputArg i a) + => k -> a -> MaybeT Action (v, PositionMapping) +useWithStaleMT key file = + MaybeT $ maybe (pure Nothing) (fmap runIdentity . Shake.usesWithStale key . Identity) (toInputArg file) -- ---------------------------------------------------------------------------- -- IdeAction wrappers @@ -121,12 +127,30 @@ runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ -- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon -- failure -useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) +useWithStaleFastE :: (IdeRule k i v, ToInputArg i a) => k -> a -> ExceptT PluginError IdeAction (v, PositionMapping) useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k -- |MaybeT version of `useWithStaleFast` -useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k +useWithStaleFastMT :: (IdeRule k i v, ToInputArg i a) => k -> a -> MaybeT IdeAction (v, PositionMapping) +useWithStaleFastMT k = MaybeT . maybe (pure Nothing) (Shake.useWithStaleFast k) . toInputArg + +class ToInputArg (i :: InputClass) a where + toInputArg :: a -> Maybe (InputPath i) + +instance ToInputArg i (InputPath i) where + toInputArg = Just + +instance ToInputArg ProjectHaskellFiles NormalizedFilePath where + toInputArg = toProjectHaskellInput + +instance ToInputArg AllHaskellFiles NormalizedFilePath where + toInputArg = Just . toAllHaskellInput + +instance ToInputArg CabalFile NormalizedFilePath where + toInputArg = toCabalFileInput + +instance ToInputArg StackYaml NormalizedFilePath where + toInputArg = toStackYamlInput -- ---------------------------------------------------------------------------- -- Location wrappers @@ -252,7 +276,7 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m provider m ide _pid params | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do - contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp + contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents $ toAllHaskellInput nfp case contentsMaybe of Just contents -> do let (typ, mtoken) = case m of diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e10c26e953..ef5fbcb955 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -69,28 +69,41 @@ encodeLinkableType (Just ObjectLinkable) = "2" -- Foo* means Foo for me and Foo+ -- | The parse tree for the file using GetFileContents +-- +-- Project-only for now because parinsg goes through GetModSummary / GhcSession +-- Dependency files should use GetHieAst from dist, not project parsing type instance RuleResult GetParsedModule = ParsedModule +type instance RuleInput GetParsedModule = ProjectHaskellFiles -- | The parse tree for the file using GetFileContents, -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule +type instance RuleInput GetParsedModuleWithComments = ProjectHaskellFiles type instance RuleResult GetModuleGraph = DependencyInformation +type instance RuleInput GetModuleGraph = NoFile -- | it only compute the fingerprint of the module graph for a file and its dependencies -- we need this to trigger recompilation when the sub module graph for a file changes type instance RuleResult GetModuleGraphTransDepsFingerprints = Fingerprint +type instance RuleInput GetModuleGraphTransDepsFingerprints = ProjectHaskellFiles + type instance RuleResult GetModuleGraphTransReverseDepsFingerprints = Fingerprint +type instance RuleInput GetModuleGraphTransReverseDepsFingerprints = ProjectHaskellFiles + type instance RuleResult GetModuleGraphImmediateReverseDepsFingerprints = Fingerprint +type instance RuleInput GetModuleGraphImmediateReverseDepsFingerprints = ProjectHaskellFiles data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets instance NFData GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets +type instance RuleInput GetKnownTargets = NoFile -- | Convert to Core, requires TypeCheck* type instance RuleResult GenerateCore = ModGuts +type instance RuleInput GenerateCore = ProjectHaskellFiles data GenerateCore = GenerateCore deriving (Eq, Show, Generic) @@ -98,6 +111,7 @@ instance Hashable GenerateCore instance NFData GenerateCore type instance RuleResult GetLinkable = LinkableResult +type instance RuleInput GetLinkable = ProjectHaskellFiles data LinkableResult = LinkableResult @@ -123,6 +137,8 @@ instance Hashable GetImportMap instance NFData GetImportMap type instance RuleResult GetImportMap = ImportMap +type instance RuleInput GetImportMap = ProjectHaskellFiles + newtype ImportMap = ImportMap { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? } deriving stock Show @@ -245,12 +261,19 @@ instance Show HieAstResult where -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult +type instance RuleInput TypeCheck = ProjectHaskellFiles -- | The uncompressed HieAST +-- +-- This is intentionally broader than TypeCheck. For project files it may be +-- generated from a fresh typecheck, For dependecy files it should be loaded +-- from indexed .hie data type instance RuleResult GetHieAst = HieAstResult +type instance RuleInput GetHieAst = AllHaskellFiles -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings +type instance RuleInput GetBindings = ProjectHaskellFiles data DocAndTyThingMap = DKMap { getDocMap :: !DocMap @@ -266,42 +289,56 @@ instance Show DocAndTyThingMap where show = const "docmap" type instance RuleResult GetDocMap = DocAndTyThingMap +type instance RuleInput GetDocMap = ProjectHaskellFiles -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq +type instance RuleInput GhcSession = 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 = 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 = 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 = 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 = 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 = ProjectHaskellFiles -- | Get a module interface details, either from an interface file or a typechecked module +-- +-- Project-only. Dependency navigation should not regenerate or load project +-- interface state via this rule; it should use GetHieAst/hiedb data type instance RuleResult GetModIface = HiFileResult +type instance RuleInput GetModIface = ProjectHaskellFiles -- | 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 Rope) +type instance RuleInput GetFileContents = AllHaskellFiles type instance RuleResult GetFileExists = Bool +type instance RuleInput GetFileExists = AllHaskellFiles type instance RuleResult GetFileHash = Fingerprint +type instance RuleInput GetFileHash = AllHaskellFiles type instance RuleResult AddWatchedFile = Bool - +type instance RuleInput AddWatchedFile = AllHaskellFiles -- The Shake key type for getModificationTime queries newtype GetModificationTime = GetModificationTime_ @@ -331,12 +368,14 @@ data GetPhysicalModificationTime = GetPhysicalModificationTime -- | Get the modification time of a file on disk, ignoring any version in the VFS. type instance RuleResult GetPhysicalModificationTime = FileVersion +type instance RuleInput GetPhysicalModificationTime = AllHaskellFiles pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +type instance RuleInput GetModificationTime = AllHaskellFiles -- | Either the mtime from disk or an LSP version -- LSP versions always compare as greater than on disk versions @@ -385,6 +424,7 @@ instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult +type instance RuleInput IsFileOfInterest = AllHaskellFiles data ModSummaryResult = ModSummaryResult { msrModSummary :: !ModSummary @@ -406,10 +446,15 @@ 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 +-- +-- Project-only because this depends on GhcSession and should not be used to +-- pull dependency source files into the project build graph type instance RuleResult GetModSummary = ModSummaryResult +type instance RuleInput GetModSummary = ProjectHaskellFiles -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleInput GetModSummaryWithoutTimestamps = ProjectHaskellFiles data GetParsedModule = GetParsedModule deriving (Eq, Show, Generic) @@ -428,6 +473,7 @@ instance NFData GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Maybe LinkableType +type instance RuleInput NeedsCompilation = ProjectHaskellFiles data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Generic) @@ -536,6 +582,7 @@ instance Hashable GetClientSettings instance NFData GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) +type instance RuleInput GetClientSettings = NoFile data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile @@ -546,6 +593,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 = NoFile 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 24de344bfa..4251bdb8af 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -103,6 +103,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 @@ -231,18 +232,18 @@ toIdeResult = either (, Nothing) (([],) . Just) -- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do - msource <- getFileContents nfp + msource <- getFileContents (toAllHaskellInput nfp) case msource of Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) Just source -> pure $ T.encodeUtf8 $ Rope.toText source -- | Parse the contents of a haskell file. -getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModule :: InputPath ProjectHaskellFiles -> 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 :: InputPath ProjectHaskellFiles -> Action (Maybe ParsedModule) getParsedModuleWithComments = use GetParsedModuleWithComments ------------------------------------------------------------ @@ -268,7 +269,7 @@ getParsedModuleRule recorder = let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file ms + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt (unInputPath file) ms withoutOptHaddock :: ModSummary -> ModSummary withoutOptHaddock = withoutOption Opt_Haddock @@ -295,7 +296,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 @@ -335,15 +336,15 @@ getLocatedImportsRule recorder = let getTargetFor modName nfp | Just (TargetFile nfp') <- HM.lookupKey (TargetFile nfp) targets = do -- reuse the existing NormalizedFilePath in order to maximize sharing - itExists <- getFileExists nfp' + itExists <- getFileExists $ toAllHaskellInput nfp' return $ if itExists then Just nfp' else Nothing | Just tt <- HM.lookup (TargetModule modName) targets = do -- reuse the existing NormalizedFilePath in order to maximize sharing let nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt - itExists <- getFileExists nfp' + itExists <- getFileExists $ toAllHaskellInput nfp' return $ if itExists then Just nfp' else Nothing | otherwise = do - itExists <- getFileExists nfp + itExists <- getFileExists $ toAllHaskellInput nfp return $ if itExists then Just nfp else Nothing #if MIN_VERSION_ghc(9,13,0) (diags, imports') <- fmap unzip $ forM imports $ \(isSource, _lvl, mbPkgName, modName) -> do @@ -384,7 +385,7 @@ execRawDepM act = -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) +rawDependencyInformation :: [InputPath ProjectHaskellFiles] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss @@ -394,15 +395,16 @@ rawDependencyInformation fs = do mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff zipWithM go ff mss - go :: NormalizedFilePath -- ^ Current module being processed + go :: InputPath ProjectHaskellFiles -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module -> RawDepM FilePathId go f mbModSum = do + let rawFile = unInputPath f -- 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 rawFile $ do + let al = modSummaryToArtifactsLocation rawFile mbModSum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Record this module and its location @@ -429,7 +431,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 $ classifyProjectHaskellInputs $ map 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 @@ -485,7 +487,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{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file - 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 -> @@ -507,16 +509,23 @@ reportImportCyclesRule recorder = where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do - ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file - pure (moduleNameString . moduleName . ms_mod $ ms) + case toProjectHaskellInput file of + Nothing -> pure $ fromNormalizedFilePath file + Just input -> do + ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps input + pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) getHieAstsRule :: Recorder (WithPriority Log) -> Rules () getHieAstsRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do - tmr <- use_ TypeCheck f - hsc <- hscEnv <$> use_ GhcSessionDeps f - getHieAstRuleDefinition f hsc tmr + define (cmapWithPrio LogShake recorder) $ \GetHieAst input -> do + let f = unInputPath input + case toProjectHaskellInput f of + Nothing -> pure ([], Nothing) + Just projectInput -> do + tmr <- use_ TypeCheck projectInput + hsc <- hscEnv <$> use_ GhcSessionDeps projectInput + getHieAstRuleDefinition projectInput hsc tmr persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do @@ -530,8 +539,9 @@ 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 f hsc tmr = do +getHieAstRuleDefinition :: InputPath ProjectHaskellFiles -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) +getHieAstRuleDefinition input hsc tmr = do + let f = unInputPath input (diags, masts') <- liftIO $ generateHieAsts hsc tmr #if MIN_VERSION_ghc(9,11,0) let masts = fst <$> masts' @@ -540,7 +550,7 @@ getHieAstRuleDefinition f hsc tmr = do #endif se <- getShakeExtras - isFoi <- use_ IsFileOfInterest f + isFoi <- use_ IsFileOfInterest $ generalizeProjectInput input diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ @@ -571,7 +581,7 @@ persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (Im getBindingsRule :: Recorder (WithPriority Log) -> Rules () getBindingsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetBindings f -> do - HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f + HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst $ generalizeProjectInput f case kind of HieFresh -> pure ([], Just $ bindings rm) HieFromDisk _ -> pure ([], Nothing) @@ -583,7 +593,7 @@ getDocMapRule recorder = -- but we never generated a DocMap for it (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file - (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file + (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst $ generalizeProjectInput file cfg <- getClientConfigAction dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets { linkSource = linkSourceTo cfg @@ -617,12 +627,12 @@ typeCheckRule :: Recorder (WithPriority Log) -> Rules () typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do pm <- use_ GetParsedModule file hsc <- hscEnv <$> use_ GhcSessionDeps file - foi <- use_ IsFileOfInterest file + foi <- use_ IsFileOfInterest $ generalizeProjectInput file -- We should only call the typecheck rule for files of interest. -- 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 file knownFilesRule :: Recorder (WithPriority Log) -> Rules () @@ -634,14 +644,14 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde getFileHashRule :: Recorder (WithPriority Log) -> Rules () getFileHashRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash file -> do - void $ use_ GetModificationTime file - fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath file) + void $ use_ GetModificationTime $ toAllHaskellInput $ unInputPath file + fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath $ unInputPath file) return (Just (fingerprintToBS fileHash), ([], Just fileHash)) getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - dependencyInfoForFiles (HashSet.toList fs) + dependencyInfoForFiles (classifyProjectHaskellInputs $ HashSet.toList fs) #if MIN_VERSION_ghc(9,13,0) -- | Build level-aware module graph edges from a ModSummary and a list of dependency NodeKeys. @@ -659,11 +669,11 @@ mkLevelEdges ms dep_node_keys = concatMap (\nk -> map (\lvl -> mkModuleEdge lvl _ -> [NormalLevel] #endif -dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) +dependencyInfoForFiles :: [InputPath ProjectHaskellFiles] -> 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 $ classifyProjectHaskellInputs 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 @@ -694,15 +704,15 @@ dependencyInfoForFiles fs = do typeCheckRuleDefinition :: HscEnv -> ParsedModule - -> NormalizedFilePath + -> InputPath ProjectHaskellFiles -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm fp = do +typeCheckRuleDefinition hsc pm input = do IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO let dets = TypecheckHelpers - { getLinkables = unliftIO unlift . uses_ GetLinkable - , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp + { getLinkables = unliftIO unlift . uses_ GetLinkable . classifyProjectHaskellInputs + , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph input } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -712,7 +722,7 @@ typeCheckRuleDefinition hsc pm fp = 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 (toAllHaskellInput . toNormalizedFilePath') used_files) return r -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. @@ -748,15 +758,15 @@ 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 -- VSCode uses absolute paths in its filewatch notifications let nfp = toNormalizedFilePath' fp - itExists <- getFileExists nfp + itExists <- getFileExists $ toAllHaskellInput nfp when itExists $ void $ do - use_ GetPhysicalModificationTime nfp + use_ GetPhysicalModificationTime $ toAllHaskellInput nfp mapM_ addDependency deps @@ -784,7 +794,7 @@ instance Default GhcSessionDepsConfig where ghcSessionDepsDefinition :: -- | full mod summary Bool -> - GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) + GhcSessionDepsConfig -> HscEnvEq -> InputPath ProjectHaskellFiles -> Action (Maybe HscEnvEq) ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = do mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file case mbdeps of @@ -799,8 +809,9 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = -- This `HscEnv` has its plugins initialized in `parsePragmasIntoHscEnv` -- Fixes the bug in #4631 env = msrHscEnv msr - depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps - ifaces <- uses_ GetModIface deps + let depInputs = classifyProjectHaskellInputs deps + depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) depInputs + ifaces <- uses_ GetModIface depInputs -- Load .hs-boot before .hs: the HPT is keyed by module name, and -- GHC's addHomeModInfoToHpt overwrites, so the non-boot must be last. let inLoadOrder = sortOn (not . isBootHmi) @@ -818,7 +829,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = -- 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 depInputs return $!! map (NodeKey_Module . msKey) dep_mss #if MIN_VERSION_ghc(9,13,0) let final_dep_edges = mkLevelEdges ms final_deps @@ -849,7 +860,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco Nothing -> return (Nothing, ([], Nothing)) Just session -> do linkableType <- getLinkableType f - ver <- use_ GetModificationTime f + ver <- use_ GetModificationTime $ generalizeProjectInput f let m_old = case old of Shake.Succeeded (Just old_version) v -> Just (v, old_version) Shake.Stale _ (Just old_version) v -> Just (v, old_version) @@ -857,8 +868,8 @@ 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 + , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} . toAllHaskellInput + , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface (classifyProjectHaskellInputs fs) , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f , regenerate = regenerateHiFile session f ms } @@ -889,7 +900,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 @@ -899,7 +910,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 $ @@ -909,8 +920,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) @@ -932,8 +943,8 @@ getModSummaryRule displayTHWarning recorder = do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000 - mFileContent <- getFileContents f - let fp = fromNormalizedFilePath f + mFileContent <- getFileContents $ generalizeProjectInput f + let fp = fromNormalizedFilePath $ unInputPath f modS <- liftIO $ runExceptT $ getModSummaryFromImports session fp (textToStringBuffer . Rope.toText <$> mFileContent) case modS of @@ -959,7 +970,7 @@ getModSummaryRule displayTHWarning recorder = do return (Just fp, Just res{msrModSummary = ms}) Nothing -> return (Nothing, Nothing) -generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) +generateCore :: RunSimplifier -> InputPath ProjectHaskellFiles -> Action (IdeResult ModGuts) generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file hsc' <- setFileCacheHook packageState @@ -972,7 +983,7 @@ generateCoreRule recorder = getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do - fileOfInterest <- use_ IsFileOfInterest f + fileOfInterest <- use_ IsFileOfInterest $ generalizeProjectInput f res <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest @@ -1015,7 +1026,7 @@ setFileCacheHook :: HscEnv -> Action HscEnv setFileCacheHook old_hsc_env = do #if MIN_VERSION_ghc(9,11,0) unlift <- askUnliftIO - return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toNormalizedFilePath' } } + return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toAllHaskellInput . toNormalizedFilePath' } } #else return old_hsc_env #endif @@ -1023,10 +1034,11 @@ setFileCacheHook old_hsc_env = do -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written -regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) -regenerateHiFile sess f ms compNeeded = do +regenerateHiFile :: HscEnvEq -> InputPath ProjectHaskellFiles -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess input ms compNeeded = do hsc <- setFileCacheHook (hscEnv sess) opt <- getIdeOptions + let f = unInputPath input -- By default, we parse with `-haddock` unless 'OptHaddockParse' is overwritten. (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms @@ -1035,7 +1047,7 @@ regenerateHiFile sess f ms compNeeded = do Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm f + (diags', mtmr) <- typeCheckRuleDefinition hsc pm input case mtmr of Nothing -> pure (diags', Nothing) Just tmr -> do @@ -1132,11 +1144,11 @@ getLinkableRule recorder = dotO = DotO #endif case hirCoreFp of - Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f + Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show (unInputPath f) Just (bin_core, fileHash) -> do session <- use_ GhcSessionDeps f linkableType <- getLinkableType f >>= \case - Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show f + Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show (unInputPath f) Just t -> pure t -- Can't use `GetModificationTime` rule because the core file was possibly written in this -- very session, so the results aren't reliable @@ -1185,21 +1197,21 @@ 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 ProjectHaskellFiles -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule :: InputPath ProjectHaskellFiles -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) needsCompilationRule file - | "boot" `isSuffixOf` fromNormalizedFilePath file = + | "boot" `isSuffixOf` fromNormalizedFilePath (unInputPath file) = pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file res <- case graph of -- Treat as False if some reverse dependency header fails to parse Nothing -> pure Nothing - Just depinfo -> case immediateReverseDependencies file depinfo of + Just depinfo -> case immediateReverseDependencies (unInputPath file) depinfo of -- If we fail to get immediate reverse dependencies, fail with an error message - Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show file + Nothing -> fail $ "Failed to get the immediate reverse dependencies of " ++ show (unInputPath file) Just revdeps -> do -- It's important to use stale data here to avoid wasted work. -- if NeedsCompilation fails for a module M its result will be under-approximated @@ -1210,9 +1222,10 @@ needsCompilationRule file = do -- that we just threw away, and thus have to recompile all dependencies once -- again, this time keeping the object code. -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled + let revdepInputs = classifyProjectHaskellInputs revdeps (modsums,needsComps) <- liftA2 - (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) - (uses NeedsCompilation revdeps) + (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdepInputs) + (uses NeedsCompilation revdepInputs) pure $ computeLinkableType modsums (map join needsComps) pure (Just $ encodeLinkableType res, Just res) where @@ -1307,26 +1320,26 @@ mainRule recorder RulesConfig{..} = do getLinkableRule recorder defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransDepsFingerprints file -> do di <- useNoFile_ GetModuleGraph - let finger = lookupFingerprint file di (depTransDepsFingerprints di) + let finger = lookupFingerprint (unInputPath file) di (depTransDepsFingerprints di) return (fingerprintToBS <$> finger, ([], finger)) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransReverseDepsFingerprints file -> do di <- useNoFile_ GetModuleGraph - let finger = lookupFingerprint file di (depTransReverseDepsFingerprints di) + let finger = lookupFingerprint (unInputPath file) di (depTransReverseDepsFingerprints di) return (fingerprintToBS <$> finger, ([], finger)) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphImmediateReverseDepsFingerprints file -> do di <- useNoFile_ GetModuleGraph - let finger = lookupFingerprint file di (depImmediateReverseDepsFingerprints di) + let finger = lookupFingerprint (unInputPath file) di (depImmediateReverseDepsFingerprints di) return (fingerprintToBS <$> finger, ([], finger)) -- | Get HieFile for haskell file on NormalizedFilePath -getHieFile :: NormalizedFilePath -> Action (Maybe HieFile) -getHieFile nfp = runMaybeT $ do - HAR {hieAst} <- MaybeT $ use GetHieAst nfp - tmr <- MaybeT $ use TypeCheck nfp - ghc <- MaybeT $ use GhcSession nfp - msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp - source <- lift $ getSourceFileSource nfp +getHieFile :: InputPath ProjectHaskellFiles -> Action (Maybe HieFile) +getHieFile input = runMaybeT $ do + HAR {hieAst} <- MaybeT $ use GetHieAst $ generalizeProjectInput input + tmr <- MaybeT $ use TypeCheck input + ghc <- MaybeT $ use GhcSession input + msr <- MaybeT $ use GetModSummaryWithoutTimestamps input + source <- lift $ getSourceFileSource $ unInputPath input let exports = tcg_exports $ tmrTypechecked tmr typedAst <- MaybeT $ pure $ cast hieAst liftIO $ runHsc (hscEnv ghc) $ mkHieFile' (msrModSummary msr) exports typedAst source diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9334a13ad3..da3c52d316 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -185,7 +185,7 @@ import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra import UnliftIO (MonadUnliftIO (withRunInIO)) - +import Development.IDE.Core.InputPath data Log = LogCreateHieDbExportsMapStart @@ -395,7 +395,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) @@ -466,10 +466,10 @@ 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 - - let readPersistent +lastValueIO :: IdeRule k i v => ShakeExtras -> k -> InputPath i -> IO (Maybe (v, PositionMapping)) +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k input = do + let file = unInputPath input + readPersistent | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests , testing = pure Nothing | otherwise = do @@ -512,10 +512,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- | 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 key file = do +lastValue :: IdeRule k i v => k -> InputPath i -> Action (Maybe (v, PositionMapping)) +lastValue key input = do s <- getShakeExtras - liftIO $ lastValueIO s key file + liftIO $ lastValueIO s key input mappingForVersion :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping)) @@ -527,8 +527,9 @@ 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 , Show v , Typeable v @@ -595,15 +596,15 @@ shakeDatabaseProfileIO mbProfileDir = do shakeProfileDatabase shakeDb $ dir file return (dir file) -setValues :: IdeRule k v +setValues :: IdeRule k i v => Values -> k - -> NormalizedFilePath + -> InputPath 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 (unInputPath input)) state -- | Delete the value stored for a given ide build key @@ -621,14 +622,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 -> + InputPath 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 (unInputPath input)) state >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let !r = seqValue $ fmap (fromJust . fromDynamic @v) v @@ -1029,24 +1030,24 @@ preservedKeys checkParents = HSet.fromList $ -- | Define a new Rule without early cutoff define - :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () -define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v + :: IdeRule k i v + => Recorder (WithPriority Log) -> (k -> InputPath i -> Action (IdeResult v)) -> Rules () +define recorder op = defineEarlyCutoff recorder $ Rule $ \k input -> (Nothing,) <$> op k input defineNoDiagnostics - :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () -defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v + :: IdeRule k i v + => Recorder (WithPriority Log) -> (k -> InputPath i -> Action (Maybe v)) -> Rules () +defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k input -> (Nothing,) <$> op k input -- | 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 -> InputPath 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 key file = runIdentity <$> usesWithStale key (Identity file) +useWithStale :: IdeRule k i v + => k -> InputPath i -> Action (Maybe (v, PositionMapping)) +useWithStale key input = runIdentity <$> usesWithStale key (Identity input) -- |Request a Rule result, it not available return the last computed result -- which may be stale. @@ -1055,9 +1056,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 -> InputPath i -> Action (v, PositionMapping) +useWithStale_ key input = runIdentity <$> usesWithStale_ key (Identity input) -- |Plural version of 'useWithStale_' -- @@ -1065,9 +1066,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 (InputPath 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 @@ -1096,27 +1097,28 @@ 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 -> InputPath 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 -> InputPath i -> IdeAction (FastResult v) +useWithStaleFast' key input = do + let file = unInputPath input -- 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 file) 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 @@ -1124,11 +1126,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 :: IdeRule k NoFile v => k -> Action (Maybe v) +useNoFile key = use key toNoFileInput -- Requests a rule if available. -- @@ -1136,11 +1138,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 -> InputPath i -> Action v +use_ key input = runIdentity <$> uses_ key (Identity input) -useNoFile_ :: IdeRule k v => k -> Action v -useNoFile_ key = use_ key emptyFilePath +useNoFile_ :: IdeRule k NoFile v => k -> Action v +useNoFile_ key = use_ key toNoFileInput -- |Plural version of `use_` -- @@ -1148,125 +1150,130 @@ 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_ key files = do - res <- uses key files +uses_ :: (Traversable f, IdeRule k i v) => k -> f (InputPath i) -> Action (f v) +uses_ key inputs = do + res <- uses key inputs case sequence res of Nothing -> liftIO $ throwIO $ BadDependency (show key) Just v -> return v -- | Plural version of 'use' -uses :: (Traversable f, IdeRule k v) - => k -> f NormalizedFilePath -> Action (f (Maybe v)) -uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files) +uses :: (Traversable f, IdeRule k i v) + => k -> f (InputPath i) -> Action (f (Maybe v)) +uses key inputs = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,) . unInputPath) inputs) -- | 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 (InputPath i) -> Action (f (Maybe (v, PositionMapping))) +usesWithStale key inputs = do + _ <- apply (fmap (Q . (key,) . unInputPath) 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 -- we use separate fingerprint rules to trigger the rebuild of the rule useWithSeparateFingerprintRule - :: (IdeRule k v, IdeRule k1 Fingerprint) - => k1 -> k -> NormalizedFilePath -> Action (Maybe v) -useWithSeparateFingerprintRule fingerKey key file = do - _ <- use fingerKey file - useWithoutDependency key emptyFilePath + :: (IdeRule k NoFile v, IdeRule k1 i Fingerprint) + => k1 -> k -> InputPath i -> Action (Maybe v) +useWithSeparateFingerprintRule fingerKey key input = do + _ <- use fingerKey input + useWithoutDependency key toNoFileInput -- we use separate fingerprint rules to trigger the rebuild of the rule useWithSeparateFingerprintRule_ - :: (IdeRule k v, IdeRule k1 Fingerprint) - => k1 -> k -> NormalizedFilePath -> Action v -useWithSeparateFingerprintRule_ fingerKey key file = do - useWithSeparateFingerprintRule fingerKey key file >>= \case + :: (IdeRule k NoFile v, IdeRule k1 i Fingerprint) + => k1 -> k -> InputPath i -> Action v +useWithSeparateFingerprintRule_ fingerKey key input = do + useWithSeparateFingerprintRule fingerKey key input >>= \case Just v -> return v Nothing -> liftIO $ throwIO $ BadDependency (show key) -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 -> InputPath i -> Action (Maybe v) +useWithoutDependency key input = + (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q (key, unInputPath 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 -> InputPath i -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleNoDiagnostics (k -> InputPath 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 -> InputPath i -> Action (Maybe BS.ByteString, Maybe v) } - | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleWithOldValue (k -> InputPath 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 extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags updateFileDiagnostics recorder file ver (newKey key) extras diags - defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file + input = unsafeMkInputPath file + defineEarlyCutoff' diagnostics (==) key input old mode $ const $ op key input defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file 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 + input = unsafeMkInputPath 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 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 + input = unsafeMkInputPath file + defineEarlyCutoff' diagnostics newnessCheck key input old mode $ + const $ second (mempty,) <$> build key input defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags updateFileDiagnostics recorder file ver (newKey key) extras diags - defineEarlyCutoff' diagnostics (==) key file old mode $ op key file + input = unsafeMkInputPath file + 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 :: IdeRule k NoFile v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () +defineNoFile recorder f = defineNoDiagnostics recorder $ \k _input -> 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 :: IdeRule k NoFile v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k _input -> 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 + -> InputPath 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 file = unInputPath 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 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 @@ -1277,7 +1284,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 @@ -1287,7 +1294,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ 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) @@ -1305,7 +1312,7 @@ 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) + setValues state key input res (Vector.fromList diags) modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where @@ -1315,10 +1322,10 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do estimateFileVersionUnsafely :: k -> Maybe v - -> NormalizedFilePath + -> InputPath i -> Action (Maybe FileVersion) - estimateFileVersionUnsafely _k v fp - | fp == emptyFilePath = pure Nothing + estimateFileVersionUnsafely _k v input + | unInputPath input == emptyFilePath = 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 @@ -1328,7 +1335,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) (toAllHaskellInput $ unInputPath input) -- Note [Housekeeping rule cache and dirty key outside of hls-graph] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1495,9 +1502,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 -> [InputPath i] -> k -> Action () +runWithSignal msgStart msgEnd inputs rule = do + let files = map unInputPath inputs ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras kickSignal testing lspEnv files msgStart - void $ uses rule files + void $ uses rule inputs kickSignal testing lspEnv files msgEnd diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index 498ea44bee..51801249fc 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/ghcide/src/Development/IDE/Core/UseStale.hs @@ -28,10 +28,10 @@ import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import Data.String (fromString) import Development.IDE (Action, IdeRule, - NormalizedFilePath, Range, rangeToRealSrcSpan, realSrcSpanToRange) +import Development.IDE.Core.InputPath (InputPath) import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.Shake as IDE import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) @@ -143,8 +143,8 @@ unsafeCopyAge _ = coerce -- | 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 (TrackedStale v)) +useWithStale :: IdeRule k i v + => k -> InputPath i -> Action (Maybe (TrackedStale v)) useWithStale key file = do x <- IDE.useWithStale key file pure $ x <&> \(v, pm) -> @@ -152,9 +152,8 @@ useWithStale key file = do -- | Request a Rule result, it not available return the last computed result which may be stale. -- Errors out if none available. -useWithStale_ :: IdeRule k v - => k -> NormalizedFilePath -> Action (TrackedStale v) +useWithStale_ :: IdeRule k i v + => k -> InputPath i -> Action (TrackedStale v) useWithStale_ key file = do (v, pm) <- IDE.useWithStale_ key file pure $ TrackedStale (coerce v) (coerce pm) - diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index cec445601c..df589032fc 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -14,6 +14,7 @@ import Data.Functor import Data.Generics hiding (Prefix) import Data.List.NonEmpty (nonEmpty) import Data.Maybe +import Development.IDE.Core.InputPath import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat @@ -36,7 +37,10 @@ moduleOutline moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do - mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) + mb_decls <- case toProjectHaskellInput fp of + Nothing -> pure Nothing + Just input -> + fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule input) pure $ case mb_decls of Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } @@ -265,5 +269,3 @@ hsConDeclsBinders cons -> [LFieldOcc GhcPs] get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) #endif - - diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index aad5fba3c2..6261ac3404 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -39,6 +39,8 @@ import Development.IDE.Core.FileStore (isWatchSupported, import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), modifyClientSettings, registerIdeConfiguration) +import Development.IDE.Core.InputPath (classifyProjectHaskellInputs, + toAllHaskellInput) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick, setFilesOfInterest) @@ -435,9 +437,11 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles - results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles) + let projectInputs = classifyProjectHaskellInputs $ map toNormalizedFilePath' absoluteFiles + haskellInputs = map (toAllHaskellInput . toNormalizedFilePath') absoluteFiles + results <- runAction "User TypeCheck" ide $ uses TypeCheck projectInputs + _results <- runAction "GetHie" ide $ uses GetHieAst haskellInputs + _results <- runAction "GenerateCore" ide $ uses GenerateCore projectInputs let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 3f55037399..3661b04e81 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -20,6 +20,9 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Compile import Development.IDE.Core.FileStore (getUriContents) +import Development.IDE.Core.InputPath (generalizeProjectInput, + toProjectHaskellInput, + unInputPath) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes @@ -84,7 +87,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) produceCompletions :: Recorder (WithPriority Log) -> Rules () produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do - let uri = fromNormalizedUri $ normalizedFilePathToUri file + let uri = fromNormalizedUri $ normalizedFilePathToUri $ unInputPath file mbPm <- useWithStale GetParsedModule file case mbPm of Just (pm, _) -> do @@ -106,7 +109,7 @@ produceCompletions recorder = do case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do visibleMods <- liftIO $ fmap (fromMaybe []) $ envVisibleModuleNames sess - let uri = fromNormalizedUri $ normalizedFilePathToUri file + let uri = fromNormalizedUri $ normalizedFilePathToUri $ unInputPath file let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports return ([], Just cdata) (_diag, _) -> @@ -127,12 +130,13 @@ resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_Compl resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = do file <- getNormalizedFilePathE uri + input <- handleMaybe PluginStaleResolve $ toProjectHaskellInput file (sess,_) <- withExceptT (const PluginStaleResolve) $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) - $ useWithStaleFastE GhcSessionDeps file + $ useWithStaleFastE GhcSessionDeps input let nc = ideNc $ shakeExtras ide name <- liftIO $ lookupNameCache nc mod occ - mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file + mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap input let (dm,km) = case mdkm of Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap) Nothing -> (mempty, mempty) @@ -170,49 +174,52 @@ getCompletionsLSP ide plId fmap Right $ case (contentsMaybe, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do - opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide - localCompls <- useWithStaleFast LocalCompletions npath - nonLocalCompls <- useWithStaleFast NonLocalCompletions npath - pm <- useWithStaleFast GetParsedModule npath - binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets - let localModules = maybe [] (Map.keys . targetMap) knownTargets - let lModules = mempty{importableModules = map toModueNameText localModules} - -- set up the exports map including both package and project-level identifiers - packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath - packageExportsMap <- mapM liftIO packageExportsMapIO - projectExportsMap <- liftIO $ readTVarIO (exportsMap $ shakeExtras ide) - let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap + case toProjectHaskellInput npath of + Nothing -> return (InL []) + Just input -> do + (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + localCompls <- useWithStaleFast LocalCompletions input + nonLocalCompls <- useWithStaleFast NonLocalCompletions input + pm <- useWithStaleFast GetParsedModule input + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings input + knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets + let localModules = maybe [] (Map.keys . targetMap) knownTargets + let lModules = mempty{importableModules = map toModueNameText localModules} + -- set up the exports map including both package and project-level identifiers + packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession input + packageExportsMap <- mapM liftIO packageExportsMapIO + projectExportsMap <- liftIO $ readTVarIO (exportsMap $ shakeExtras ide) + let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap - let moduleExports = getModuleExportsMap exportsMap - exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . nonDetOccEnvElts . getExportsMap $ exportsMap - exportsCompls = mempty{anyQualCompls = exportsCompItems} - let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules + let moduleExports = getModuleExportsMap exportsMap + exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . nonDetOccEnvElts . getExportsMap $ exportsMap + exportsCompls = mempty{anyQualCompls = exportsCompItems} + let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules - -- get HieAst if OverloadedRecordDot is enabled - let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags - ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath - astres <- case ms of - Just ms' | uses_overloaded_record_dot ms' - -> useWithStaleFast GetHieAst npath - _ -> return Nothing + -- get HieAst if OverloadedRecordDot is enabled + let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags + ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps input + astres <- case ms of + Just ms' | uses_overloaded_record_dot ms' + -> useWithStaleFast GetHieAst $ generalizeProjectInput input + _ -> return Nothing - pure (opts, fmap (,pm,binds) compls, moduleExports, astres) - case compls of - Just (cci', parsedMod, bindMap) -> do - let pfix = getCompletionPrefixFromRope position cnts - case (pfix, completionContext) of - (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) - -> return (InL []) - (_, _) -> do - let clientCaps = clientCapabilities $ shakeExtras ide - plugins = idePlugins $ shakeExtras ide - config <- liftIO $ runAction "" ide $ getCompletionsConfig plId + pure (opts, fmap (,pm,binds) compls, moduleExports, astres) + case compls of + Just (cci', parsedMod, bindMap) -> do + let pfix = getCompletionPrefixFromRope position cnts + case (pfix, completionContext) of + (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) + -> return (InL []) + (_, _) -> do + let clientCaps = clientCapabilities $ shakeExtras ide + plugins = idePlugins $ shakeExtras ide + config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri - pure $ InL (orderedCompletions allCompletions) - _ -> return (InL []) + let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri + pure $ InL (orderedCompletions allCompletions) + _ -> return (InL []) _ -> return (InL []) getCompletionsConfig :: PluginId -> Action CompletionsConfig diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 698003786c..a86c3597c5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -21,7 +21,8 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.String (IsString (..)) import Data.Text (Text) import Development.IDE.GHC.Compat -import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph (InputClass (ProjectHaskellFiles), + RuleInput, RuleResult) import Development.IDE.Spans.Common () import GHC.Generics (Generic) import qualified GHC.Types.Name.Occurrence as Occ @@ -31,7 +32,9 @@ import qualified Language.LSP.Protocol.Types as J -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleInput LocalCompletions = ProjectHaskellFiles type instance RuleResult NonLocalCompletions = CachedCompletions +type instance RuleInput NonLocalCompletions = ProjectHaskellFiles data LocalCompletions = LocalCompletions deriving (Eq, Show, Generic) diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 0047b97e23..8f25892a19 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PackageImports #-} -- | A plugin that adds custom messages for use in tests @@ -29,12 +30,14 @@ import Data.Maybe (isJust) import Data.Proxy import Data.String import Data.Text (Text, pack) +import Development.IDE.Core.InputPath import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Compat -import Development.IDE.Graph (Action) +import Development.IDE.Graph (Action, + InputClass (ProjectHaskellFiles)) import qualified Development.IDE.Graph as Graph import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildEdges, @@ -103,9 +106,13 @@ testRequestHandler _ (BlockSeconds secs) = do return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file - sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp - let hiPath = hiDir $ hsc_dflags $ hscEnv sess - return $ Right (toJSON hiPath) + case toProjectHaskellInput nfp of + Nothing -> + return $ Left $ PluginInvalidParams "GetInterfaceFilesDir is not valid for dependency files" + Just input -> do + sess <- runAction "Test - GhcSession" s $ use_ GhcSession input + let hiPath = hiDir $ hsc_dflags $ hscEnv sess + return $ Right (toJSON hiPath) testRequestHandler s GetShakeSessionQueueCount = liftIO $ do n <- atomically $ countQueue $ actionQueue $ shakeExtras s return $ Right (toJSON n) @@ -164,29 +171,41 @@ getDatabaseKeys field db = do return [ k | (k, res) <- keys, field res == Step step] parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) -parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp -parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp -parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp -parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp -parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp -parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp -parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp -parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp -parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp +parseAction "typecheck" fp = projectRule TypeCheck fp +parseAction "getLocatedImports" fp = projectRule GetLocatedImports fp +parseAction "getmodsummary" fp = projectRule GetModSummary fp +parseAction "getmodsummarywithouttimestamps" fp = projectRule GetModSummaryWithoutTimestamps fp +parseAction "getparsedmodule" fp = projectRule GetParsedModule fp +parseAction "ghcsession" fp = projectRule GhcSession fp +parseAction "ghcsessiondeps" fp = projectRule GhcSessionDeps fp +parseAction "gethieast" fp = Right . isJust <$> use GetHieAst (toAllHaskellInput fp) +parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents (toAllHaskellInput fp) parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) parseActions :: CI String -> [NormalizedFilePath] -> Action (Either Text [Bool]) -parseActions "typecheck" fps = Right . fmap isJust <$> uses TypeCheck fps -parseActions "getLocatedImports" fps = Right . fmap isJust <$> uses GetLocatedImports fps -parseActions "getmodsummary" fps = Right . fmap isJust <$> uses GetModSummary fps -parseActions "getmodsummarywithouttimestamps" fps = Right . fmap isJust <$> uses GetModSummaryWithoutTimestamps fps -parseActions "getparsedmodule" fps = Right . fmap isJust <$> uses GetParsedModule fps -parseActions "ghcsession" fps = Right . fmap isJust <$> uses GhcSession fps -parseActions "ghcsessiondeps" fps = Right . fmap isJust <$> uses GhcSessionDeps fps -parseActions "gethieast" fps = Right . fmap isJust <$> uses GetHieAst fps -parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents fps +parseActions "typecheck" fps = projectRules TypeCheck fps +parseActions "getLocatedImports" fps = projectRules GetLocatedImports fps +parseActions "getmodsummary" fps = projectRules GetModSummary fps +parseActions "getmodsummarywithouttimestamps" fps = projectRules GetModSummaryWithoutTimestamps fps +parseActions "getparsedmodule" fps = projectRules GetParsedModule fps +parseActions "ghcsession" fps = projectRules GhcSession fps +parseActions "ghcsessiondeps" fps = projectRules GhcSessionDeps fps +parseActions "gethieast" fps = Right . fmap isJust <$> uses GetHieAst (map toAllHaskellInput fps) +parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents (map toAllHaskellInput fps) parseActions other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) +projectRule :: IdeRule k ProjectHaskellFiles v => k -> NormalizedFilePath -> Action (Either Text Bool) +projectRule k fp = + case toProjectHaskellInput fp of + Nothing -> pure $ Left $ "Rule is not valid for dependency file: " <> pack (show fp) + Just input -> Right . isJust <$> use k input + +projectRules :: IdeRule k ProjectHaskellFiles v => k -> [NormalizedFilePath] -> Action (Either Text [Bool]) +projectRules k fps = + case traverse toProjectHaskellInput fps of + Nothing -> pure $ Left "Rule is not valid for one or more dependency files" + Just inputs -> Right . fmap isJust <$> uses k inputs + -- | a command that blocks forever. Used for testing blockCommandId :: Text blockCommandId = "ghcide.command.block" diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index cad7fdc65a..2e1a184ca6 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -38,6 +38,7 @@ import Development.IDE (FileDiagnostic (..), srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentRange, @@ -54,6 +55,8 @@ import Development.IDE.GHC.Compat.Error (_TcRnMessage, msgEnvelopeErrorL) import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes +import Development.IDE.Graph (InputClass (ProjectHaskellFiles), + RuleInput) import Development.IDE.Types.Location (Position (Position, _line), Range (Range, _end, _start)) import GHC.Core.TyCo.Tidy (tidyOpenType) @@ -156,16 +159,19 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif then do -- In this mode we get the global bindings from the -- GlobalBindingTypeSigs rule. - (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- - runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - $ useWithStaleE GetGlobalBindingTypeSigs nfp - -- Depending on whether we only want exported or not we filter our list - -- of signatures to get what we want - let relevantGlobalSigs = - if mode == Exported - then filter gbExported gblSigs - else gblSigs - pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp + case toProjectHaskellInput nfp of + Nothing -> pure $ InL [] + Just input -> do + (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs input + -- Depending on whether we only want exported or not we filter our list + -- of signatures to get what we want + let relevantGlobalSigs = + if mode == Exported + then filter gbExported gblSigs + else gblSigs + pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp else do -- For this mode we exclusively use diagnostics to create the lenses. -- However we will still use the GlobalBindingTypeSigs to resolve them. @@ -177,9 +183,10 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do nfp <- getNormalizedFilePathE uri + input <- handleMaybe PluginStaleResolve $ toProjectHaskellInput nfp (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - $ useWithStaleE GetGlobalBindingTypeSigs nfp + $ useWithStaleE GetGlobalBindingTypeSigs input -- regardless of how the original lens was generated, we want to get the range -- that the global bindings rule would expect here, hence the need to reverse -- position map the range, regardless of whether it was position mapped in the @@ -310,6 +317,7 @@ instance NFData GlobalBindingTypeSigsResult where rnf = rwhnf type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult +type instance RuleInput GetGlobalBindingTypeSigs = ProjectHaskellFiles rules :: Recorder (WithPriority Log) -> Rules () rules recorder = do diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 96766c4e7c..6548b1c707 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -18,12 +18,15 @@ import qualified Data.Text as Text import Data.Text.Utf16.Rope.Mixed (Rope) import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) +import Development.IDE.Core.InputPath (generalizeProjectInput, + toProjectHaskellInput) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util import qualified Language.LSP.Protocol.Types as LSP import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) -import Ide.Plugin.Error (PluginError) +import Ide.Plugin.Error (PluginError (..), + handleMaybe) import Ide.Types (PluginId(..)) import qualified Data.Text as T import Development.IDE.Core.PluginUtils @@ -52,8 +55,9 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo getFirstPragma (PluginId pId) state nfp = do - (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp - fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput nfp + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession input + fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents $ generalizeProjectInput input pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c942e707c8..3f19a5329c 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2183,6 +2183,7 @@ test-suite ghcide-tests SafeTests SymlinkTests THTests + TypedRuleTests UnitTests WatchedFileTests diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 81ad3b3dfd..a287dfefa7 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, InputClass(..), -- * 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..3ffe6475f5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs @@ -23,6 +23,16 @@ import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@. type family RuleResult key -- = value +-- | The broad class of input paths a rule is allowed to run on +data InputClass + = ProjectHaskellFiles + | AllHaskellFiles + | CabalFile + | StackYaml + | NoFile + +-- | Type mapping between a rule as key and the class of file input it accepts as value +type family RuleInput key :: InputClass action :: Action a -> Rules () action x = do ref <- Rules $ asks rulesActions diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 63e9d7ea65..bf4e9c3f7f 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -39,6 +39,7 @@ module Ide.Types , PluginNotificationHandler(..), mkPluginNotificationHandler , PluginNotificationHandlers(..) , PluginRequestMethod(..) +, InputClass(..), RuleInput, RuleResult, Rules, Key, alwaysRerun , getProcessID, getPid , getVirtualFileFromVFS , installSigUsr1Handler @@ -67,7 +68,8 @@ import Control.Monad (void) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Data.Aeson hiding (Null, defaultOptions) +import Data.Aeson hiding (Key, Null, + defaultOptions) import qualified Data.Aeson.Types as A import Data.Default import Data.Dependent.Map (DMap) diff --git a/hls-test-utils/src/Development/IDE/Test.hs b/hls-test-utils/src/Development/IDE/Test.hs index a1bd2dec0e..fe3edbaad7 100644 --- a/hls-test-utils/src/Development/IDE/Test.hs +++ b/hls-test-utils/src/Development/IDE/Test.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Development.IDE.Test ( Cursor @@ -24,6 +25,7 @@ module Development.IDE.Test , standardizeQuotes , flushMessages , waitForAction + , waitForActionError , getInterfaceFilesDir , garbageCollectDirtyKeys , getFilesOfInterest @@ -215,6 +217,14 @@ waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResul waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) +waitForActionError :: String -> TextDocumentIdentifier -> Session Text +waitForActionError key TextDocumentIdentifier{_uri} = do + res <- tryCallTestPlugin @WaitForIdeRuleResult (WaitForIdeRule key _uri) + case res of + Left (TResponseError _ err _) -> pure err + Right _ -> liftIO $ assertFailure $ + "Expected rule " <> key <> " to fail for " <> show _uri + getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) @@ -261,4 +271,3 @@ referenceReady pred = satisfyMaybe $ \case , symbolVal p == "ghcide/reference/ready" -> Just fp _ -> Nothing - 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 048fe2a6d1..68f53dbcce 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 @@ -53,6 +53,7 @@ instance Hashable CollectLiterals instance NFData CollectLiterals type instance RuleResult CollectLiterals = CollectLiteralsResult +type instance RuleInput CollectLiterals = ProjectHaskellFiles data CollectLiteralsResult = CLR { literals :: RangeMap Literal diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index dadc5503fc..1935cf54f2 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -18,9 +18,9 @@ import qualified Data.Text () import qualified Data.Text as T import Development.IDE as D import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.InputPath (toCabalFileInput) import Development.IDE.Core.PluginUtils import Development.IDE.Core.Shake (restartShakeSession) -import Development.IDE.Graph (Key) import Development.IDE.LSP.HoverDefinition (foundHover) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import Development.IDE.Types.Shake (toKey) @@ -220,14 +220,19 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif Just (fileContents, path) -> do -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. -- In case it fails, we still will get some completion results instead of an error. - mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ toNormalizedFilePath path - case mFields of + let cabalInput = toCabalFileInput $ toNormalizedFilePath path + case cabalInput of Nothing -> pure $ InL [] - Just (cabalFields, _) -> do - let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags - results <- forM fields (getSuggestion fileContents path cabalFields) - pure $ InL $ map InR $ concat results + Just input -> do + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields input + case mFields of + Nothing -> + pure $ InL [] + Just (cabalFields, _) -> do + let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags + results <- forM fields (getSuggestion fileContents path cabalFields) + pure $ InL $ map InR $ concat results where getSuggestion fileContents fp cabalFields (fieldName, Diagnostic{_range = _range@(Range (Position lineNr col) _)}) = do let @@ -252,12 +257,14 @@ cabalAddDependencyCodeAction _ state plId (CodeActionParams _ _ (TextDocumentIde case mbCabalFile of Nothing -> pure $ InL [] Just cabalFilePath -> do + let cabalFile = toNormalizedFilePath cabalFilePath + cabalInput <- handleMaybe (PluginInvalidParams "Expected cabal file") $ toCabalFileInput cabalFile verTxtDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $ lift $ getVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath) - mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile cabalInput case mbGPD of Nothing -> pure $ InL [] Just (gpd, _) -> do @@ -307,12 +314,13 @@ If the cursor is hovering on a dependency, add a documentation link to that depe hover :: PluginMethodHandler IdeState LSP.Method_TextDocumentHover hover ide _ msgParam = do nfp <- getNormalizedFilePathE uri - cabalFields <- runActionE "cabal.cabal-hover" ide $ useE ParseCabalFields nfp + cabalInput <- handleMaybe (PluginInvalidParams "Expected cabal file") $ toCabalFileInput nfp + cabalFields <- runActionE "cabal.cabal-hover" ide $ useE ParseCabalFields cabalInput case CabalFields.findTextWord cursor cabalFields of Nothing -> pure $ InR Null Just cursorText -> do - gpd <- runActionE "cabal.GPD" ide $ useE ParseCabalFile nfp + gpd <- runActionE "cabal.GPD" ide $ useE ParseCabalFile cabalInput let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd case filterVersion cursorText of Nothing -> pure $ InR Null @@ -361,17 +369,22 @@ completion recorder ide _ complParams = do Just (cnts, path) -> do -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. -- In case it fails, we still will get some completion results instead of an error. - mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ toNormalizedFilePath path - case mFields of + let cabalInput = toCabalFileInput $ toNormalizedFilePath path + case cabalInput of Nothing -> pure . InR $ InR Null - Just (fields, _) -> do - let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts - cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo - res = computeCompletionsAt recorder ide cabalPrefInfo path fields $ - CompleterTypes.Matcher $ - Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults - liftIO $ fmap InL res + Just input -> do + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields input + case mFields of + Nothing -> + pure . InR $ InR Null + Just (fields, _) -> do + let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts + cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo + res = computeCompletionsAt recorder ide cabalPrefInfo path fields $ + CompleterTypes.Matcher $ + Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults + liftIO $ fmap InL res Nothing -> pure . InR $ InR Null computeCompletionsAt @@ -383,6 +396,7 @@ computeCompletionsAt -> CompleterTypes.Matcher T.Text -> IO [CompletionItem] computeCompletionsAt recorder ide prefInfo fp fields matcher = do + let cabalInput = toCabalFileInput $ toNormalizedFilePath fp runMaybeT (context fields) >>= \case Nothing -> pure [] Just ctx -> do @@ -394,9 +408,14 @@ computeCompletionsAt recorder ide prefInfo fp fields matcher = do -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, -- thus, a quick response gives us the desired result most of the time. -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. - mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp - pure $ fmap fst mGPD - , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp + case cabalInput of + Nothing -> pure Nothing + Just input -> do + mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile input + pure $ fmap fst mGPD + , getCabalCommonSections = case cabalInput of + Nothing -> pure Nothing + Just input -> runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections input , cabalPrefixInfo = prefInfo , stanzaName = case fst ctx of diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs index 83554c6a82..d4a9960269 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd/Command.hs @@ -29,6 +29,8 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Encoding as T import Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore (getFileContents) +import Development.IDE.Core.InputPath (toAllHaskellInput, + toCabalFileInput) import Development.IDE.Core.Rules (IdeState) import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (useWithStale) @@ -187,10 +189,12 @@ mkCabalAddConfig :: ExceptT PluginError m WorkspaceEdit mkCabalAddConfig recorder env cabalFilePath mkConfig = do let (state, caps, verTxtDocId) = env + cabalFile = toNormalizedFilePath cabalFilePath + cabalInput <- maybe (throwE $ PluginInvalidParams "Expected cabal file") pure $ toCabalFileInput cabalFile (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do - contents <- getFileContents $ toNormalizedFilePath cabalFilePath - inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath - inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + contents <- getFileContents $ toAllHaskellInput cabalFile + inFields <- useWithStale ParseCabalFields cabalInput + inPackDescr <- useWithStale ParseCabalFile cabalInput let mbCnfOrigContents = case contents of (Just txt) -> Just $ encodeUtf8 $ Rope.toText txt _ -> Nothing diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs index 59796afe2b..d0fc50b3fb 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -9,6 +10,8 @@ import Control.Lens ((^.)) import Data.Hashable import qualified Data.Text as T import Development.IDE as D +import Ide.Types (InputClass (CabalFile), + RuleInput) import qualified Distribution.Fields as Syntax import qualified Distribution.PackageDescription as PD import qualified Distribution.Parsec.Position as Syntax @@ -41,6 +44,7 @@ instance Pretty Log where LogCompletionContext ctx -> "Completion context is:" <+> pretty ctx type instance RuleResult ParseCabalFile = PD.GenericPackageDescription +type instance RuleInput ParseCabalFile = CabalFile data ParseCabalFile = ParseCabalFile deriving (Eq, Show, Generic) @@ -50,6 +54,7 @@ instance Hashable ParseCabalFile instance NFData ParseCabalFile type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position] +type instance RuleInput ParseCabalFields = CabalFile data ParseCabalFields = ParseCabalFields deriving (Eq, Show, Generic) @@ -59,6 +64,7 @@ instance Hashable ParseCabalFields instance NFData ParseCabalFields type instance RuleResult ParseCabalCommonSections = [Syntax.Field Syntax.Position] +type instance RuleInput ParseCabalCommonSections = CabalFile data ParseCabalCommonSections = ParseCabalCommonSections deriving (Eq, Show, Generic) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs index 5137af2b08..d9ee80b5ec 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs @@ -13,6 +13,7 @@ import Data.List (find) import qualified Data.Maybe as Maybe import qualified Data.Text as T import Development.IDE as D +import Development.IDE.Core.InputPath (toCabalFileInput) import Development.IDE.Core.PluginUtils import qualified Distribution.Fields as Syntax import Distribution.PackageDescription (Benchmark (..), @@ -55,15 +56,16 @@ import System.FilePath (joinPath, gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition gotoDefinition ide _ msgParam = do nfp <- getNormalizedFilePathE uri - cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields nfp + cabalInput <- handleMaybe (PluginInvalidParams "Expected cabal file") $ toCabalFileInput nfp + cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields cabalInput -- Trim the AST tree, so multiple passes in subfunctions won't hurt the performance. let fieldsOfInterest = maybe cabalFields (:[] ) $ CabalFields.findFieldSection cursor cabalFields - commonSections <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalCommonSections nfp + commonSections <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalCommonSections cabalInput let mCommonSectionsDef = gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest mModuleDef <- do - mGPD <- liftIO $ runAction "cabal.GPD" ide $ useWithStale ParseCabalFile nfp + mGPD <- liftIO $ runAction "cabal.GPD" ide $ useWithStale ParseCabalFile cabalInput case mGPD of Nothing -> pure Nothing Just (gpd, _) -> liftIO $ gotoModulesDefinition nfp gpd cursor fieldsOfInterest diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs index 67cf97ccee..e5b29c3dba 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs @@ -16,12 +16,15 @@ import qualified Data.HashMap.Strict as HashMap import Data.Proxy import qualified Data.Text () import Development.IDE as D +import Development.IDE.Core.InputPath (classifyCabalFileInputs, + unInputPath) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (Key, alwaysRerun) import Development.IDE.Types.Shake (toKey) import GHC.Generics import qualified Ide.Plugin.Cabal.Completion.Types as Types import Ide.Plugin.Cabal.Orphans () +import Ide.Types (InputClass (CabalFile), + Key, RuleInput, alwaysRerun) data Log = LogShake Shake.Log @@ -55,6 +58,7 @@ instance Hashable IsCabalFileOfInterest instance NFData IsCabalFileOfInterest type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult +type instance RuleInput IsCabalFileOfInterest = CabalFile data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus deriving (Eq, Show, Generic) @@ -71,7 +75,7 @@ ofInterestRules recorder = do Shake.defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsCabalFileOfInterest f -> do alwaysRerun filesOfInterest <- getCabalFilesOfInterestUntracked - let foi = maybe NotCabalFOI IsCabalFOI $ f `HashMap.lookup` filesOfInterest + let foi = maybe NotCabalFOI IsCabalFOI $ unInputPath f `HashMap.lookup` filesOfInterest fp = summarize foi res = (Just fp, Just foi) return res @@ -119,4 +123,4 @@ function invocation. kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile + Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") (classifyCabalFileInputs files) Types.ParseCabalFile diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs index 40f348f88c..5704472785 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs @@ -11,6 +11,7 @@ import Control.Monad.IO.Class import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) +import Development.IDE.Core.InputPath (toCabalFileInput) import Development.IDE.Core.Rules import Development.IDE.Core.Shake (IdeState (shakeExtras), runIdeAction, @@ -33,11 +34,14 @@ moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ LSP.DocumentSymbolParams {_textDocument = LSP.TextDocumentIdentifier uri} = case LSP.uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do - mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ideState) (useWithStaleFast ParseCabalFields fp) - case fmap fst mFields of - Just fieldPositions -> pure $ LSP.InR (LSP.InL allSymbols) - where - allSymbols = mapMaybe documentSymbolForField fieldPositions + case toCabalFileInput fp of + Just input -> do + mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ideState) (useWithStaleFast ParseCabalFields input) + case fmap fst mFields of + Just fieldPositions -> pure $ LSP.InR (LSP.InL allSymbols) + where + allSymbols = mapMaybe documentSymbolForField fieldPositions + Nothing -> pure $ LSP.InL [] Nothing -> pure $ LSP.InL [] Nothing -> pure $ LSP.InL [] diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs index de7bb9a5fd..a022f40bd2 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Rules.hs @@ -16,6 +16,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE as D +import Development.IDE.Core.InputPath (toAllHaskellInput, + unInputPath) import qualified Development.IDE.Core.Shake as Shake import qualified Distribution.CabalSpecVersion as Cabal import qualified Distribution.Fields as Syntax @@ -59,15 +61,15 @@ cabalRules recorder plId = do else do -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), -- we rerun this rule because this rule *depends* on GetModificationTime. - (t, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t + (t, mCabalSource) <- use_ GetFileContents $ toAllHaskellInput $ unInputPath file + log' Debug $ LogModificationTime (unInputPath file) t contents <- case mCabalSource of Just sources -> pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> do - liftIO $ BS.readFile $ fromNormalizedFilePath file + liftIO $ BS.readFile $ fromNormalizedFilePath $ unInputPath file - case Parse.readCabalFields file contents of + case Parse.readCabalFields (unInputPath file) contents of Left _ -> pure ([], Nothing) Right fields -> @@ -91,20 +93,20 @@ cabalRules recorder plId = do else do -- whenever this key is marked as dirty (e.g., when a user writes stuff to it), -- we rerun this rule because this rule *depends* on GetModificationTime. - (t, mCabalSource) <- use_ GetFileContents file - log' Debug $ LogModificationTime file t + (t, mCabalSource) <- use_ GetFileContents $ toAllHaskellInput $ unInputPath file + log' Debug $ LogModificationTime (unInputPath file) t contents <- case mCabalSource of Just sources -> pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> do - liftIO $ BS.readFile $ fromNormalizedFilePath file + liftIO $ BS.readFile $ fromNormalizedFilePath $ unInputPath file -- Instead of fully reparsing the sources to get a 'GenericPackageDescription', -- we would much rather re-use the already parsed results of 'ParseCabalFields'. -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription'' -- which allows us to resume the parsing pipeline with '[Field Position]'. let (pWarnings, pm) = Parse.parseCabalFileContents contents - let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings + let warningDiags = fmap (Diagnostics.warningDiagnostic (unInputPath file)) pWarnings case pm of Left (_cabalVersion, pErrorNE) -> do let regexUnknownCabalBefore310 :: T.Text @@ -136,14 +138,14 @@ cabalRules recorder plId = do ] then Diagnostics.warningDiagnostic - file + (unInputPath file) ( Syntax.PWarning Syntax.PWTOther pos $ unlines [ text , unsupportedCabalHelpText ] ) - else Diagnostics.errorDiagnostic file pe + else Diagnostics.errorDiagnostic (unInputPath file) pe ) pErrorNE allDiags = errorDiags <> warningDiags diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index b897fa5abb..2c84c7ae3b 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -21,6 +21,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Tuple.Extra import Development.IDE +import Development.IDE.Core.InputPath import Development.IDE.Core.Shake import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint @@ -51,7 +52,7 @@ prepareCallHierarchy state _ param = do pure $ InL items prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] -prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case +prepareCallHierarchyItem nfp pos = use GetHieAst (toAllHaskellInput nfp) <&> \case Nothing -> mempty Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp @@ -273,7 +274,7 @@ queryCalls item queryFunc makeFunc merge Nothing -> getSymbolFromAst nfp pos -- Fallback if xdata lost, some editor(VSCode) will drop it getSymbolFromAst :: NormalizedFilePath -> Position -> Action (Maybe Symbol) - getSymbolFromAst nfp pos_ = use GetHieAst nfp <&> \case + getSymbolFromAst nfp pos_ = use GetHieAst (toAllHaskellInput nfp) <&> \case Nothing -> Nothing Just (HAR _ hf _ _ _) -> do case listToMaybe $ pointCommand hf pos_ extract of diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index a64e87e69e..ef4d0869a6 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -21,7 +21,9 @@ import Development.IDE import Development.IDE.Core.PluginUtils (useMT) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) +#if !MIN_VERSION_ghc(9,11,0) import Development.IDE.GHC.Compat.Util (bagToList) +#endif import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils @@ -76,6 +78,7 @@ instance NFData ClassInstancesResult where rnf = rwhnf type instance RuleResult GetClassInstances = ClassInstancesResult +type instance RuleInput GetClassInstances = ProjectHaskellFiles -- |The necessary data to execute our code lens data InstanceBindLensCommand = InstanceBindLensCommand @@ -115,6 +118,7 @@ instance NFData InstanceBindLensResult where rnf = rwhnf type instance RuleResult GetInstanceBindLens = InstanceBindLensResult +type instance RuleInput GetInstanceBindLens = ProjectHaskellFiles data Log = LogImplementedMethods DynFlags Class ClassMinimalDef diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 7a6127f931..4c225c86d5 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Except import Data.Char (isAlpha) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.InputPath import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util (fsLit) @@ -49,7 +50,7 @@ insertPragmaIfNotPresent state nfp pragma = do (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state $ useWithStaleE GhcSession nfp fileContents <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state - $ getFileContents nfp + $ getFileContents $ toAllHaskellInput nfp (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state $ useWithStaleE GetParsedModuleWithComments nfp let exts = getExtensions pm diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 2391a35e1a..261843009e 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -37,9 +38,13 @@ import qualified Data.Map.Strict as Map import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE +import Development.IDE.Core.InputPath (generalizeProjectInput, + unInputPath) import Development.IDE.Core.Rules (toIdeResult) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat.Util +import Ide.Types (InputClass (ProjectHaskellFiles), + RuleInput) import GHC.Generics (Generic) import GHC.Iface.Ext.Types (HieAST (..), HieASTs (..)) import GHC.Iface.Ext.Utils (RefMap) @@ -162,15 +167,16 @@ instance Hashable GetCodeRange instance NFData GetCodeRange type instance RuleResult GetCodeRange = CodeRange +type instance RuleInput GetCodeRange = ProjectHaskellFiles codeRangeRule :: Recorder (WithPriority Log) -> Rules () codeRangeRule recorder = define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords). -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations - HAR{hieAst, refMap} <- lift $ use_ GetHieAst file + HAR{hieAst, refMap} <- lift $ use_ GetHieAst $ generalizeProjectInput file ast <- maybeToExceptT LogNoAST . MaybeT . pure $ - getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath . unInputPath) file let (codeRange, warnings) = runWriter (buildCodeRange ast refMap) traverse_ (logWith recorder Warning) warnings diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs index 2b2321ced3..2e47a67ce8 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -41,6 +41,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) +import Development.IDE.Core.InputPath (classifyProjectHaskellInputs, + toProjectHaskellInput) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) @@ -255,19 +257,20 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- The interactive context and interactive dynamic flags are also set appropiately. initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv initialiseSessionForEval needs_quickcheck st nfp = do + input <- maybe (fail $ "initialiseSessionForEval: expected a project Haskell file: " ++ show nfp) pure $ toProjectHaskellInput nfp (ms, env1) <- runAction "runEvalCmd" st $ do - ms <- msrModSummary <$> use_ GetModSummary nfp - deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + ms <- msrModSummary <$> use_ GetModSummary input + deps_hsc <- hscEnv <$> use_ GhcSessionDeps input - linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph nfp <*> pure nfp - linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) + linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph input <*> pure nfp + linkables <- uses_ GetLinkable $ classifyProjectHaskellInputs (nfp : maybe [] transitiveModuleDeps linkables_needed) -- We unset the global rdr env in mi_globals when we generate interfaces -- See Note [Clearing mi_globals after generating an iface] -- However, the eval plugin (setContext specifically) requires the rdr_env -- for the current module - so get it from the Typechecked Module and add -- it back to the iface for the current module. - tm <- tmrTypechecked <$> use_ TypeCheck nfp + tm <- tmrTypechecked <$> use_ TypeCheck input let rdr_env = tcg_rdr_env tm addRdrEnv hmi | iface <- hm_iface hmi diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index d01ddbc55c..459afe8472 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -25,6 +25,7 @@ import Development.IDE (GetParsedModuleWithCommen realSrcSpanToRange, useWithStale_, use_) import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.InputPath (unInputPath) import Development.IDE.Core.Rules (needsCompilationRule) import Development.IDE.Core.Shake (IsIdeGlobal, RuleBody (RuleWithCustomNewnessCheck), @@ -82,10 +83,11 @@ pattern RealSrcSpanAlready x = x evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp + let file = unInputPath nfp let comments = foldMap (\case L (RealSrcSpanAlready real) bdy | FastString.unpackFS (srcSpanFile real) == - fromNormalizedFilePath nfp + fromNormalizedFilePath file , let ran0 = realSrcSpanToRange real , Just curRan <- toCurrentRange posMap ran0 -> @@ -110,7 +112,7 @@ isEvaluatingRule :: Recorder (WithPriority Log) -> Rules () isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do alwaysRerun EvaluatingVar var <- getIdeGlobalAction - b <- liftIO $ (f `Set.member`) <$> readIORef var + b <- liftIO $ (unInputPath f `Set.member`) <$> readIORef var return (Just (if b then BS.singleton 1 else BS.empty), Just b) -- Redefine the NeedsCompilation rule to set the linkable type to Just _ @@ -127,4 +129,3 @@ redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake re pure (Just fp, Just (Just linkableType)) else needsCompilationRule f - diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 7d83419f40..4d039414a1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -49,6 +49,8 @@ import qualified Development.IDE.GHC.Compat.Core as Core import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Logger +import Ide.Types (InputClass (ProjectHaskellFiles), + RuleInput) import Ide.Plugin.Eval.GHC (showDynFlags) import Ide.Plugin.Eval.Util import Language.LSP.Protocol.Types (TextDocumentIdentifier, @@ -175,6 +177,7 @@ instance Hashable IsEvaluating instance NFData IsEvaluating type instance RuleResult IsEvaluating = Bool +type instance RuleInput IsEvaluating = ProjectHaskellFiles data GetEvalComments = GetEvalComments deriving (Eq, Show, Generic) @@ -182,6 +185,7 @@ instance Hashable GetEvalComments instance NFData GetEvalComments type instance RuleResult GetEvalComments = Comments +type instance RuleInput GetEvalComments = ProjectHaskellFiles data Comments = Comments { lineComments :: Map Range RawLineComment , blockComments :: Map Range RawBlockComment diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs index af17f47096..7a8abf5a03 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -18,6 +18,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Development.IDE hiding (pluginHandlers, pluginRules) +import Development.IDE.Core.InputPath (generalizeProjectInput) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Shake (addPersistentRule) @@ -92,6 +93,7 @@ instance Hashable GetFixity instance NFData GetFixity type instance RuleResult GetFixity = FixityMap +type instance RuleInput GetFixity = ProjectHaskellFiles -- | Convert a HieAST to FixityTree with fixity info gathered lookupFixities :: MonadIO m => HscEnv -> TcGblEnv -> S.Set Name -> m (M.Map Name Fixity) @@ -113,7 +115,7 @@ lookupFixities hscEnv tcGblEnv names fixityRule :: Recorder (WithPriority Log) -> Rules () fixityRule recorder = do define (cmapWithPrio LogShake recorder) $ \GetFixity nfp -> do - HAR{refMap} <- use_ GetHieAst nfp + HAR{refMap} <- use_ GetHieAst $ generalizeProjectInput nfp env <- hscEnv <$> use_ GhcSessionDeps nfp -- deps necessary so that we can consult already loaded in ifaces instead of loading in duplicates tcGblEnv <- tmrTypechecked <$> use_ TypeCheck nfp fs <- lookupFixities env tcGblEnv (S.mapMonotonic (\(Right n) -> n) $ S.filter isRight $ M.keysSet refMap) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 17634491fe..b10fcc4958 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -41,6 +41,7 @@ import qualified Data.Unique as U (hashUnique, newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake @@ -319,6 +320,7 @@ instance Hashable ImportActions instance NFData ImportActions type instance RuleResult ImportActions = ImportActionsResult +type instance RuleInput ImportActions = ProjectHaskellFiles data ResultType = ExplicitImport | RefineImport deriving Eq @@ -379,9 +381,11 @@ minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogSha ImportMap currIm <- MaybeT $ use GetImportMap nfp for currIm $ \path -> do -- second layer is from the imports of first layer to their imports - ImportMap importIm <- MaybeT $ use GetImportMap path + input <- MaybeT $ pure $ toProjectHaskellInput path + ImportMap importIm <- MaybeT $ use GetImportMap input for importIm $ \imp_path -> do - imp_hir <- MaybeT $ use GetModIface imp_path + imp_input <- MaybeT $ pure $ toProjectHaskellInput imp_path + imp_hir <- MaybeT $ use GetModIface imp_input return $ mi_exports $ hirModIface imp_hir -- Use the GHC api to extract the "minimal" imports 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 1c1286819d..8dd4523c56 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 @@ -91,7 +91,6 @@ import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns import Development.IDE.GHC.Util (getExtensions, printOutputable, stripOccNamePrefix) -import Development.IDE.Graph (RuleResult) import Development.IDE.Graph.Classes (Hashable, NFData) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, @@ -109,9 +108,11 @@ import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) import Ide.PluginUtils (subRange) -import Ide.Types (PluginDescriptor (..), +import Ide.Types (InputClass (ProjectHaskellFiles), + PluginDescriptor (..), PluginId (..), PluginMethodHandler, + RuleInput, RuleResult, ResolveFunction, defaultPluginDescriptor, mkPluginHandler) @@ -430,6 +431,7 @@ instance Show CollectRecordsResult where show _ = "" type instance RuleResult CollectRecords = CollectRecordsResult +type instance RuleInput CollectRecords = ProjectHaskellFiles data CollectNames = CollectNames deriving (Eq, Show, Generic) @@ -446,6 +448,7 @@ instance Show CollectNamesResult where show _ = "" type instance RuleResult CollectNames = CollectNamesResult +type instance RuleInput CollectNames = ProjectHaskellFiles data Saturated = Saturated | Unsaturated deriving (Generic) diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 23a00372b4..c4b0df8008 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -25,6 +25,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.Core.PluginUtils (mkFormattingHandlers) import Development.IDE.GHC.Compat as Compat hiding (Cpp, Warning, hang, @@ -77,7 +78,7 @@ provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler Id provider recorder plId ideState token typ contents fp fo = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do fileOpts <- maybe [] (convertDynFlags . hsc_dflags . hscEnv) - <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp) + <$> liftIO (runAction "Fourmolu" ideState $ maybe (pure Nothing) (use GhcSession) $ toProjectHaskellInput fp) useCLI <- liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #external plId properties fourmoluExePath <- fmap T.unpack $ liftIO $ runAction "Fourmolu" ideState $ usePropertyAction #path plId properties if useCLI diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 210e9f3910..6f98aa1fb5 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -50,6 +50,12 @@ import Development.IDE hiding getExtensions) import Development.IDE.Core.Compile (sourceParser) import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.InputPath (InputPath, + classifyProjectHaskellInputs, + generalizeProjectInput, + toAllHaskellInput, + toProjectHaskellInput, + unInputPath) import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics) @@ -187,6 +193,7 @@ instance Hashable GetHlintDiagnostics instance NFData GetHlintDiagnostics type instance RuleResult GetHlintDiagnostics = () +type instance RuleInput GetHlintDiagnostics = ProjectHaskellFiles -- | Hlint rules to generate file diagnostics based on hlint hints -- This rule is recomputed when: @@ -201,15 +208,16 @@ rules recorder plugin = do config <- getPluginConfigAction plugin let hlintOn = plcGlobalOn config && plcDiagnosticsOn config ideas <- if hlintOn then getIdeas recorder file else return (Right []) - return (diagnostics file ideas, Just ()) + return (diagnostics (unInputPath file) ideas, Just ()) defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags action $ do - files <- Map.keys <$> getFilesOfInterestUntracked - Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics + filesOfInterest <- getFilesOfInterestUntracked + let files = Map.keys filesOfInterest + Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") (classifyProjectHaskellInputs files) GetHlintDiagnostics where @@ -287,9 +295,9 @@ rules recorder plugin = do } srcSpanToRange (UnhelpfulSpan _) = noRange -getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea]) +getIdeas :: Recorder (WithPriority Log) -> InputPath ProjectHaskellFiles -> Action (Either ParseError [Idea]) getIdeas recorder nfp = do - logWith recorder Debug $ LogGetIdeas nfp + logWith recorder Debug $ LogGetIdeas $ unInputPath nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings let applyHints' (Just (Right modEx)) = Right $ applyHints classify hint [modEx] @@ -306,14 +314,14 @@ getIdeas recorder nfp = do then return Nothing else do flags' <- setExtensions flags - contents <- getFileContents nfp - let fp = fromNormalizedFilePath nfp + contents <- getFileContents $ generalizeProjectInput nfp + let fp = fromNormalizedFilePath $ unInputPath nfp let contents' = T.unpack . Rope.toText <$> contents Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do hlintExts <- getExtensions nfp - logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts) + logWith recorder Debug $ LogUsingExtensions (unInputPath nfp) (fmap show hlintExts) return $ flags { enabledExtensions = hlintExts } -- Gets extensions from ModSummary dynflags for the file. @@ -321,7 +329,7 @@ getIdeas recorder nfp = do -- and the ModSummary dynflags. However using the parsedFlags extensions -- can sometimes interfere with the hlint parsing of the file. -- See https://github.com/haskell/haskell-language-server/issues/1279 -getExtensions :: NormalizedFilePath -> Action [Extension] +getExtensions :: InputPath ProjectHaskellFiles -> Action [Extension] getExtensions nfp = do dflags <- getFlags let hscExts = EnumSet.toList (extensionFlags dflags) @@ -345,6 +353,7 @@ instance Show Hint where show = const "" instance Show ParseFlags where show = const "" type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) +type instance RuleInput GetHlintSettings = NoFile -- --------------------------------------------------------------------- @@ -472,7 +481,7 @@ mkSuppressHintTextEdits dynFlags fileContents hint = ignoreHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit) ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = runExceptT $ do - (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents nfp + (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents $ toAllHaskellInput nfp (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp case fileContents of Just contents -> do @@ -520,14 +529,15 @@ applyHint recorder ide nfp mhint verTxtDocId = let errorHandlers = [ Handler $ \e -> return (Left (show (e :: IOException))) , Handler $ \e -> return (Left (show (e :: ErrorCall))) ] - ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder nfp + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput nfp + ideas <- bimapExceptT (PluginInternalError . T.pack . showParseError) id $ ExceptT $ runAction' $ getIdeas recorder input let ideas' = maybe ideas (`filterIdeas` ideas) mhint let commands = map ideaRefactoring ideas' logWith recorder Debug $ LogGeneratedIdeas nfp commands let fp = fromNormalizedFilePath nfp - mbOldContent <- fmap (fmap Rope.toText) $ liftIO $ runAction' $ getFileContents nfp + mbOldContent <- fmap (fmap Rope.toText) $ liftIO $ runAction' $ getFileContents $ toAllHaskellInput nfp oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent - modsum <- liftIO $ runAction' $ use_ GetModSummary nfp + modsum <- liftIO $ runAction' $ use_ GetModSummary input let dflags = ms_hspp_opts $ msrModSummary modsum -- set Nothing as "position" for "applyRefactorings" because @@ -545,7 +555,7 @@ applyHint recorder ide nfp mhint verTxtDocId = liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do hClose h writeFileUTF8NoNewLineTranslation temp oldContent - exts <- runAction' $ getExtensions nfp + exts <- runAction' $ getExtensions input -- We have to reparse extensions to remove the invalid ones let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs index a73e958913..e7eef7fde4 100644 --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -16,6 +16,7 @@ import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Traversable (for) import Development.IDE hiding (line) +import Development.IDE.Core.InputPath import Development.IDE.Core.PluginUtils (runActionE, useE) import Development.IDE.Core.Shake (toKnownFiles) import qualified Development.IDE.Core.Shake as Shake @@ -46,6 +47,7 @@ data GetNotesInFile = MkGetNotesInFile -- definitions (note name -> position) and a map of note references -- (note name -> [position]). type instance RuleResult GetNotesInFile = (HM.HashMap Text Position, HM.HashMap Text [Position]) +type instance RuleInput GetNotesInFile = ProjectHaskellFiles data GetNotes = MkGetNotes deriving (Show, Generic, Eq, Ord) @@ -53,6 +55,7 @@ data GetNotes = MkGetNotes -- GetNotes collects all note definition across all files in the -- project. It returns a map from note name to pair of (filepath, position). type instance RuleResult GetNotes = HashMap Text (NormalizedFilePath, Position) +type instance RuleInput GetNotes = ProjectHaskellFiles data GetNoteReferences = MkGetNoteReferences deriving (Show, Generic, Eq, Ord) @@ -60,6 +63,7 @@ data GetNoteReferences = MkGetNoteReferences -- GetNoteReferences collects all note references across all files in the -- project. It returns a map from note name to list of (filepath, position). type instance RuleResult GetNoteReferences = HashMap Text [(NormalizedFilePath, Position)] +type instance RuleInput GetNoteReferences = ProjectHaskellFiles instance Pretty Log where pretty = \case @@ -91,14 +95,14 @@ findNotesRules recorder = do defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotes _ -> do targets <- toKnownFiles <$> useNoFile_ GetKnownTargets - definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (nfp,) . fst) <$> use MkGetNotesInFile nfp) (HS.toList targets) + definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (unInputPath nfp,) . fst) <$> use MkGetNotesInFile nfp) (classifyProjectHaskellInputs $ HS.toList targets) pure $ Just $ HM.unions definedNotes defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNoteReferences _ -> do targets <- toKnownFiles <$> useNoFile_ GetKnownTargets - definedReferences <- catMaybes <$> for (HS.toList targets) (\nfp -> do + definedReferences <- catMaybes <$> for (classifyProjectHaskellInputs $ HS.toList targets) (\nfp -> do references <- fmap snd <$> use MkGetNotesInFile nfp - pure $ fmap (HM.map (fmap (nfp,))) references + pure $ fmap (HM.map (fmap (unInputPath nfp,))) references ) pure $ Just $ List.foldl' (HM.unionWith (<>)) HM.empty definedReferences @@ -106,12 +110,14 @@ err :: MonadError PluginError m => Text -> Maybe a -> m a err s = maybe (throwError $ PluginInternalError s) pure getNote :: NormalizedFilePath -> IdeState -> Position -> ExceptT PluginError (HandlerM c) (Maybe Text) -getNote nfp state (Position l c) = do - contents <- - err "Error getting file contents" - =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp)) - line <- err "Line not found in file" (lineAt (fromIntegral l) contents) - pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line +getNote nfp state (Position l c) = + do + contents <- + err "Error getting file contents" + =<< liftIO (runAction "notes.getfileContents" state (getFileContents $ toAllHaskellInput nfp)) + line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst + (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents)) + pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line where atPos c arr = case arr A.! 0 of -- We check if the line we are currently at contains a note @@ -160,20 +166,20 @@ jumpToNote state _ param uriOrig = toNormalizedUri $ param ^. (L.textDocument . L.uri) jumpToNote _ _ _ = throwError $ PluginInternalError "conversion to normalized file path failed" -findNotesInFile :: NormalizedFilePath -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position, HM.HashMap Text [Position])) +findNotesInFile :: InputPath ProjectHaskellFiles -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position, HM.HashMap Text [Position])) findNotesInFile file recorder = do -- GetFileContents only returns a value if the file is open in the editor of -- the user. If not, we need to read it from disk. - contentOpt <- (snd =<<) <$> use GetFileContents file + contentOpt <- (snd =<<) <$> use GetFileContents (generalizeProjectInput file) content <- case contentOpt of Just x -> pure $ Rope.toText x - Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file + Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath $ unInputPath file let noteMatches = (A.! 1) <$> matchAllText noteRegex content notes = toPositions noteMatches content - logWith recorder Debug $ LogNotesFound file (HM.toList notes) + logWith recorder Debug $ LogNotesFound (unInputPath file) (HM.toList notes) let refMatches = (A.! 1) <$> matchAllText noteRefRegex content refs = toPositions refMatches content - logWith recorder Debug $ LogNoteReferencesFound file (HM.toList refs) + logWith recorder Debug $ LogNoteReferencesFound (unInputPath file) (HM.toList refs) pure $ Just (HM.mapMaybe (fmap fst . List.uncons) notes, refs) where uint = fromIntegral . toInteger @@ -284,7 +290,7 @@ hoverNote state _ params Nothing -> pure (InR Null) Just note -> do - mbRope <- liftIO $ runAction "notes.hoverLine" state (getFileContents nfp) + mbRope <- liftIO $ runAction "notes.hoverLine" state (getFileContents $ toAllHaskellInput nfp) -- compute precise hover range for highlighting corresponding Note Reference on Hover let lineText = diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index 54c9d4bd1a..8ce164209a 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -23,6 +23,7 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.Core.PluginUtils (mkFormattingHandlers) import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) import qualified Development.IDE.GHC.Compat as D @@ -67,7 +68,7 @@ provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler Id provider recorder plId ideState token typ contents fp _ = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do fileOpts <- maybe [] (fromDyn . hsc_dflags . hscEnv) - <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp) + <$> liftIO (runAction "Ormolu" ideState $ maybe (pure Nothing) (use GhcSession) $ toProjectHaskellInput fp) useCLI <- liftIO $ runAction "Ormolu" ideState $ usePropertyAction #external plId properties if useCLI diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index f2f71956b8..46715546d9 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -54,7 +54,6 @@ import Development.IDE.GHC.Compat (Extension (OverloadedReco ) 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, @@ -69,9 +68,11 @@ import Ide.Plugin.Error (PluginError (..), import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) -import Ide.Types (PluginDescriptor (..), +import Ide.Types (InputClass (ProjectHaskellFiles), + PluginDescriptor (..), PluginId (..), PluginMethodHandler, + RuleInput, RuleResult, ResolveFunction, defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L @@ -128,6 +129,7 @@ instance Show CollectRecordSelectorsResult where show _ = "" type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult +type instance RuleInput CollectRecordSelectors = ProjectHaskellFiles -- |Where we store our collected record selectors data RecordSelectorExpr = RecordSelectorExpr @@ -327,4 +329,3 @@ collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath collectRecSelResult ideState = runActionE "overloadedRecordDot.collectRecordSelectors" ideState . useE CollectRecordSelectors - diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index c395feba9e..a01f463923 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -29,6 +29,8 @@ import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.InputPath (toAllHaskellInput, + toProjectHaskellInput) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Error (GhcHint (SuggestExtension), @@ -87,11 +89,12 @@ mkCodeActionProvider mkSuggest state _plId (LSP.CodeActionParams _ _ docId@LSP.TextDocumentIdentifier{ _uri = uri } caRange _) = do verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId normalizedFilePath <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput normalizedFilePath -- ghc session to get some dynflags even if module isn't parsed (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- - runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath - fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath - parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath + runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession input + fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents $ toAllHaskellInput normalizedFilePath + parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule input let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents activeDiagnosticsInRange (shakeExtras state) normalizedFilePath caRange >>= \case @@ -104,11 +107,12 @@ mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> Plug mkCodeActionProvider96 mkSuggest state _plId (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do normalizedFilePath <- getNormalizedFilePathE uri + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput normalizedFilePath -- ghc session to get some dynflags even if module isn't parsed (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- - runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath - fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath - parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath + runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession input + fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents $ toAllHaskellInput normalizedFilePath + parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule input let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents pedits = nubOrdOn snd $ concatMap (mkSuggest parsedModuleDynFlags) diags diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs index 6917d0a7a9..a1cc4d05a0 100644 --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -26,6 +26,8 @@ import Data.Text.Utf16.Rope.Mixed (Rope) import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (spanContainsRange) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.InputPath (generalizeProjectInput, + toProjectHaskellInput) import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), GetHieAst (GetHieAst), HieAstResult (HAR, refMap), @@ -58,7 +60,7 @@ import Development.IDE.Types.Location (Position (Position), import GHC.Iface.Ext.Types (ContextInfo (..), Identifier, IdentifierDetails (..), Span) import GHC.Iface.Ext.Utils (RefMap) -import Ide.Plugin.Error (PluginError (PluginRuleFailed), +import Ide.Plugin.Error (PluginError (PluginInvalidParams, PluginRuleFailed), getNormalizedFilePathE, handleMaybe) import Ide.Types (PluginDescriptor (pluginHandlers), @@ -228,11 +230,12 @@ usedIdentifiersToTextEdits range nameToImportedByMap source usedIdentifiers codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId range _) = do normalizedFilePath <- getNormalizedFilePathE (documentId ^. L.uri) - TcModuleResult { tmrParsed, tmrTypechecked } <- runActionE "QualifyImportedNames.TypeCheck" ideState $ useE TypeCheck normalizedFilePath + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput normalizedFilePath + TcModuleResult { tmrParsed, tmrTypechecked } <- runActionE "QualifyImportedNames.TypeCheck" ideState $ useE TypeCheck input if isJust (findLImportDeclAt range tmrParsed) then do - HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst normalizedFilePath) - (_, sourceM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath) + HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst $ generalizeProjectInput input) + (_, sourceM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents $ generalizeProjectInput input) source <- handleMaybe (PluginRuleFailed "GetFileContents") sourceM let globalRdrEnv = tcg_rdr_env tmrTypechecked nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv @@ -240,4 +243,3 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId range _) textEdits = usedIdentifiersToTextEdits range nameToImportedByMap source usedIdentifiers pure $ InL (makeCodeActions (documentId ^. L.uri) textEdits) else pure $ InL [] - diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 076ba03a06..9ae61f4257 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -72,6 +72,9 @@ import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Generics.SYB import Generics.SYB.GHC +import Ide.Types (InputClass (ProjectHaskellFiles), + RuleInput, RuleResult, + Rules) import qualified GHC.Generics as GHC import Ide.Logger (Pretty (pretty), Recorder, @@ -145,6 +148,7 @@ data GetAnnotatedParsedSource = GetAnnotatedParsedSource instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource type instance RuleResult GetAnnotatedParsedSource = ParsedSource +type instance RuleInput GetAnnotatedParsedSource = ProjectHaskellFiles instance Show (HsModule GhcPs) where show _ = "" diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 7a28289abb..334dede43e 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -42,6 +42,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore (getUriContents) +import Development.IDE.Core.InputPath (toAllHaskellInput, + toProjectHaskellInput) import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -138,8 +140,9 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri liftIO $ do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + mbInput = mbFile >>= toProjectHaskellInput allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state - (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile + (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbInput let textContents = fmap Rope.toText contents actions = caRemoveRedundantImports parsedModule textContents allDiags range uri @@ -234,10 +237,11 @@ extendImportHandler' ideState ExtendImport {..} (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do + input <- MaybeT $ pure $ toProjectHaskellInput nfp -- We want accurate edits, so do not use stale data here - msr <- MaybeT $ use GetModSummaryWithoutTimestamps nfp - ps <- MaybeT $ use GetAnnotatedParsedSource nfp - (_, contents) <- MaybeT $ use GetFileContents nfp + msr <- MaybeT $ use GetModSummaryWithoutTimestamps input + ps <- MaybeT $ use GetAnnotatedParsedSource input + (_, contents) <- MaybeT $ use GetFileContents $ toAllHaskellInput nfp return (msr, ps, contents) let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index a4132dd787..325f954bac 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -28,6 +28,9 @@ import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.InputPath (toAllHaskellInput, + generalizeProjectInput, + toProjectHaskellInput) import Development.IDE.Core.PluginUtils (activeDiagnosticsInRange) import Development.IDE.Core.Shake import Development.IDE.GHC.Compat @@ -57,8 +60,12 @@ type GhcideCodeAction = ExceptT PluginError (ReaderT CodeActionArgs IO) GhcideCo runGhcideCodeAction :: IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> HandlerM Config GhcideCodeActionResult runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range _) codeAction | Just nfp <- toNormalizedFilePath' <$> uriToFilePath uri = do - let runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure (Just nfp)) >>= MaybeT . use key - caaGhcSession <- onceIO $ runRule GhcSession + let runProjectRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure $ toProjectHaskellInput nfp) >>= MaybeT . use key + runProjectAsAllRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ do + input <- MaybeT $ pure $ toProjectHaskellInput nfp + MaybeT $ use key $ generalizeProjectInput input + runContentRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure $ Just $ toAllHaskellInput nfp) >>= MaybeT . use key + caaGhcSession <- onceIO $ runProjectRule GhcSession caaExportsMap <- onceIO $ caaGhcSession >>= \case @@ -68,18 +75,18 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra pure $ localExports <> pkgExports _ -> pure mempty caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions - caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments + caaParsedModule <- onceIO $ runProjectRule GetParsedModuleWithComments caaContents <- onceIO $ - runRule GetFileContents <&> \case + runContentRule GetFileContents <&> \case Just (_, mbContents) -> fmap Rope.toText mbContents Nothing -> Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule - caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource - caaTmr <- onceIO $ runRule TypeCheck - caaHar <- onceIO $ runRule GetHieAst - caaBindings <- onceIO $ runRule GetBindings - caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + caaAnnSource <- onceIO $ runProjectRule GetAnnotatedParsedSource + caaTmr <- onceIO $ runProjectRule TypeCheck + caaHar <- onceIO $ runProjectAsAllRule GetHieAst + caaBindings <- onceIO $ runProjectRule GetBindings + caaGblSigs <- onceIO $ runProjectRule GetGlobalBindingTypeSigs diags <- concat . maybeToList <$> activeDiagnosticsInRange (shakeExtras state) nfp _range results <- liftIO $ sequence diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs index 69f3332dc0..deb3622302 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -5,13 +5,15 @@ module Development.IDE.Plugin.CodeAction.RuleTypes import Control.DeepSeq (NFData) import Data.Hashable (Hashable) -import Development.IDE.Graph (RuleResult) import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq) import GHC.Generics (Generic) +import Ide.Types (InputClass (NoFile), RuleInput, + RuleResult) -- Rule type for caching Package Exports type instance RuleResult PackageExports = ExportsMap +type instance RuleInput PackageExports = NoFile newtype PackageExports = PackageExports HscEnvEq deriving (Eq, Show, Generic) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs index 530a8e0d85..7e50b074b6 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs @@ -44,6 +44,8 @@ import Development.IDE (GetParsedModule (GetParse rootDir, runAction, useWithStale, (<+>)) import Development.IDE.Core.FileStore (getFileContents) +import Development.IDE.Core.InputPath (toAllHaskellInput, + toProjectHaskellInput) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), @@ -104,7 +106,7 @@ action recorder state uri = do nfp <- getNormalizedFilePathE uri fp <- uriToFilePathE uri - contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents nfp + contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents $ toAllHaskellInput nfp let emptyModule = maybe True (T.null . T.strip . Rope.toText) contents correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp @@ -166,7 +168,8 @@ pathModuleNames recorder state normFilePath filePath -- | The module name, as stated in the module codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) codeModuleName state nfp = runMaybeT $ do - (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp + input <- MaybeT $ pure $ toProjectHaskellInput nfp + (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule input L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm range <- MaybeT . pure $ toCurrentRange mp (realSrcSpanToRange l) pure (range, T.pack $ moduleNameString m) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 1bbba24df2..958d1268ee 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -37,6 +37,8 @@ import Development.IDE (Action, hieKind) import Development.IDE.Core.PluginUtils (runActionE, useE, useWithStaleE) +import Development.IDE.Core.InputPath (generalizeProjectInput, + unInputPath) import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) import Development.IDE.Core.Shake (ShakeExtras (..), @@ -126,10 +128,11 @@ semanticTokensFullDelta recorder state pid param = do getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules () getSemanticTokensRule recorder = define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do - (HAR {..}) <- withExceptT LogDependencyError $ useE GetHieAst nfp + let file = unInputPath nfp + (HAR {..}) <- withExceptT LogDependencyError $ useE GetHieAst $ generalizeProjectInput nfp (DKMap {getTyThingMap}, _) <- withExceptT LogDependencyError $ useWithStaleE GetDocMap nfp - ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp - virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp + ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) file + virtualFile <- handleMaybeM LogNoVF $ getVirtualFile file let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs index da59c28d29..9bc5b7dd52 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -18,6 +18,8 @@ import Development.IDE.Graph.Classes (Hashable) import GHC.Generics (Generic) import GHC.Iface.Ext.Types (TypeIndex) import Ide.Plugin.Error (PluginError) +import Ide.Types (InputClass (ProjectHaskellFiles), + RuleInput) import Language.Haskell.TH.Syntax (Lift) import Language.LSP.Protocol.Types @@ -130,6 +132,7 @@ showRange :: Range -> String showRange (Range (Position l1 c1) (Position l2 c2)) = show l1 <> ":" <> show c1 <> "-" <> show l2 <> ":" <> show c2 type instance RuleResult GetSemanticTokens = RangeHsSemanticTokenTypes +type instance RuleInput GetSemanticTokens = ProjectHaskellFiles data HieFunMaskKind kind where HieFreshFun :: HieFunMaskKind Type diff --git a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs index e8ac3cac0d..7e148a247c 100644 --- a/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs +++ b/plugins/hls-signature-help-plugin/src/Ide/Plugin/SignatureHelp.hs @@ -27,6 +27,7 @@ import Development.IDE (DocAndTyThingMap (DKMap), import Development.IDE.Core.PluginUtils (runIdeActionE, useWithStaleFastE) import Development.IDE.Core.PositionMapping (fromCurrentPosition) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.GHC.Compat (FastStringCompat, Name, RealSrcSpan, getSourceNodeIds, @@ -52,7 +53,9 @@ import GHC.Iface.Ext.Types (ContextInfo (Use), import GHC.Iface.Ext.Utils (smallestContainingSatisfying) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.SrcLoc (isRealSubspanOf) -import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Plugin.Error (PluginError (PluginInvalidParams), + getNormalizedFilePathE, + handleMaybe) import Ide.Types (PluginDescriptor (pluginHandlers), PluginId, PluginMethodHandler, @@ -127,7 +130,8 @@ signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdent ) (docMap, argDocMap) <- runIdeActionE "signatureHelp.docMap" (shakeExtras ideState) $ do -- see Note [Stale Results in Signature Help] - mResult <- ExceptT $ Right <$> useWithStaleFast GetDocMap nfp + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput nfp + mResult <- ExceptT $ Right <$> useWithStaleFast GetDocMap input case mResult of Just (DKMap docMap _tyThingMap argDocMap, _positionMapping) -> pure (docMap, argDocMap) Nothing -> pure (mempty, mempty) diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 94930665ac..1f3821f296 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -39,6 +39,7 @@ import Data.Maybe (fromMaybe, listToMaybe, import qualified Data.Text as T import Development.IDE import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.InputPath (toProjectHaskellInput) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.ExactPrint @@ -101,8 +102,9 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do reportEditor msgTy msgs = liftIO $ rio $ pluginSendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit expandManually fp = do + input <- maybe (throwError $ PluginInternalError "Splice expansion: expected project Haskell file") pure $ toProjectHaskellInput fp mresl <- - liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp + liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck input (TcModuleResult {..}, _) <- maybe (throwError $ PluginInternalError "Splice expansion: Type-checking information not found in cache.\nYou can once delete or replace the macro with placeholder, convince the type checker and then revert to original (erroneous) macro and expand splice again." @@ -176,10 +178,11 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do res <- liftIO $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri (verTxtDocId ^. J.uri) + input <- MaybeT $ pure $ toProjectHaskellInput fp eedits <- ( lift . runExceptT . withTypeChecked fp =<< MaybeT - (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck input) ) <|> lift (runExceptT $ expandManually fp) @@ -462,9 +465,10 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + input <- MaybeT $ pure $ toProjectHaskellInput fp ParsedModule {..} <- MaybeT . runAction "splice.codeAction.GitHieAst" state $ - use GetParsedModule fp + use GetParsedModule input let spn = rangeToRealSrcSpan fp ran mouterSplice = something' (detectSplice spn) pm_parsed_source mcmds <- forM mouterSplice $ diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 77c9817dba..7b832b77cc 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where @@ -11,12 +12,17 @@ import qualified Data.HashMap.Strict as HM import Data.Maybe (mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.InputPath + (classifyProjectHaskellInputs, + unInputPath) import Development.IDE.Core.Rules (getHieFile) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HieFile (..)) import GHC.Generics (Generic) import Ide.Plugin.Config (PluginConfig (..)) -import Ide.Types (PluginDescriptor (..), PluginId, +import Ide.Types (InputClass (ProjectHaskellFiles), + PluginDescriptor (..), PluginId, + RuleInput, configHasDiagnostics, configInitialGenericConfig, defaultConfigDescriptor, @@ -102,11 +108,13 @@ instance Hashable GetStanDiagnostics instance NFData GetStanDiagnostics type instance RuleResult GetStanDiagnostics = () +type instance RuleInput GetStanDiagnostics = ProjectHaskellFiles rules :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plId = do define (cmapWithPrio LogShake recorder) $ \GetStanDiagnostics file -> do + let nfp = unInputPath file config <- getPluginConfigAction plId if plcGlobalOn config && plcDiagnosticsOn config then do maybeHie <- getHieFile file @@ -141,7 +149,7 @@ rules recorder plId = do -- Note that Stan works in terms of relative paths, but the HIE come in as absolute. Without -- making its path relative, the file name(s) won't line up with the associated Map keys. - relativeHsFilePath <- liftIO $ makeRelativeToCurrentDirectory $ fromNormalizedFilePath file + relativeHsFilePath <- liftIO $ makeRelativeToCurrentDirectory $ fromNormalizedFilePath nfp let hieRelative = hie{hie_hs_file=relativeHsFilePath} (checksMap, ignoredObservations) <- case configTrial of @@ -158,12 +166,13 @@ rules recorder plId = do -- A Map from *relative* file paths (just one, in this case) to language extension info: cabalExtensionsMap <- liftIO $ createCabalExtensionsMap isLoud (stanArgsCabalFilePath stanArgs) [hieRelative] let analysis = runAnalysis cabalExtensionsMap checksMap ignoredObservations [hieRelative] - return (analysisToDiagnostics file analysis, Just ()) + return (analysisToDiagnostics nfp analysis, Just ()) else return ([], Nothing) action $ do - files <- getFilesOfInterestUntracked - void $ uses GetStanDiagnostics $ HM.keys files + filesOfInterest <- getFilesOfInterestUntracked + let files = classifyProjectHaskellInputs $ HM.keys filesOfInterest + void $ uses GetStanDiagnostics $ files where analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic] analysisToDiagnostics file = mapMaybe (observationToDianostic file) . toList . analysisObservations diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 874792784f..66fed70084 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -8,10 +8,12 @@ import Control.Monad import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.Map as Map -import Development.IDE (RuleResult, action, define, - getFilesOfInterestUntracked, +import Development.IDE (action, define, getFilesOfInterestUntracked, getPluginConfigAction, ideErrorText, uses_) +import Development.IDE.Core.InputPath + (classifyProjectHaskellInputs, + unInputPath) import Development.IDE.Test (ExpectedDiagnostic, expectDiagnostics) import GHC.Generics import Ide.Plugin.Config @@ -86,9 +88,9 @@ genericConfigTests = testGroup "generic plugin config" plc <- getPluginConfigAction testPluginId when (plcGlobalOn plc && plcDiagnosticsOn plc) $ do files <- getFilesOfInterestUntracked - void $ uses_ GetTestDiagnostics $ HM.keys files + void $ uses_ GetTestDiagnostics $ classifyProjectHaskellInputs $ HM.keys files define mempty $ \GetTestDiagnostics file -> do - let diags = [ideErrorText file "testplugin"] + let diags = [ideErrorText (unInputPath file) "testplugin"] return (diags,Nothing) } -- A config that disables the plugin initially @@ -105,6 +107,7 @@ data GetTestDiagnostics = GetTestDiagnostics instance Hashable GetTestDiagnostics instance NFData GetTestDiagnostics type instance RuleResult GetTestDiagnostics = () +type instance RuleInput GetTestDiagnostics = ProjectHaskellFiles expectDiagnosticsFail :: HasCallStack