diff --git a/bench/Main.hs b/bench/Main.hs index d1ac603b18..3cd857fd02 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/data/dependency-autogen/Dependency.hs b/ghcide-test/data/dependency-autogen/Dependency.hs new file mode 100644 index 0000000000..0af82a4051 --- /dev/null +++ b/ghcide-test/data/dependency-autogen/Dependency.hs @@ -0,0 +1,7 @@ +module Dependency where + +import Data.Version (Version) +import Paths_minimal_autogen (version) + +v :: Version +v = version diff --git a/ghcide-test/data/dependency-autogen/cabal.project b/ghcide-test/data/dependency-autogen/cabal.project new file mode 100644 index 0000000000..e67826a9db --- /dev/null +++ b/ghcide-test/data/dependency-autogen/cabal.project @@ -0,0 +1,6 @@ +packages: . + minimal-autogen +package * + ghc-options: -fwrite-ide-info +package minimal-autogen + ghc-options: -fwrite-ide-info diff --git a/ghcide-test/data/dependency-autogen/dependency-autogen.cabal b/ghcide-test/data/dependency-autogen/dependency-autogen.cabal new file mode 100644 index 0000000000..b333cff716 --- /dev/null +++ b/ghcide-test/data/dependency-autogen/dependency-autogen.cabal @@ -0,0 +1,10 @@ +name: dependency-autogen +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , minimal-autogen diff --git a/ghcide-test/data/dependency-autogen/hie.yaml b/ghcide-test/data/dependency-autogen/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide-test/data/dependency-autogen/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide-test/data/dependency-autogen/minimal-autogen/MinimalAutogen.hs b/ghcide-test/data/dependency-autogen/minimal-autogen/MinimalAutogen.hs new file mode 100644 index 0000000000..965446c068 --- /dev/null +++ b/ghcide-test/data/dependency-autogen/minimal-autogen/MinimalAutogen.hs @@ -0,0 +1,4 @@ +module MinimalAutogen where + +minimalAutogen :: () +minimalAutogen = () diff --git a/ghcide-test/data/dependency-autogen/minimal-autogen/Paths_minimal_autogen.hs b/ghcide-test/data/dependency-autogen/minimal-autogen/Paths_minimal_autogen.hs new file mode 100644 index 0000000000..eea0935e07 --- /dev/null +++ b/ghcide-test/data/dependency-autogen/minimal-autogen/Paths_minimal_autogen.hs @@ -0,0 +1,6 @@ +module Paths_minimal_autogen where + +import Data.Version (Version, makeVersion) + +version :: Version +version = makeVersion [0, 1, 0, 0] diff --git a/ghcide-test/data/dependency-autogen/minimal-autogen/minimal-autogen.cabal b/ghcide-test/data/dependency-autogen/minimal-autogen/minimal-autogen.cabal new file mode 100644 index 0000000000..c13e4a80f2 --- /dev/null +++ b/ghcide-test/data/dependency-autogen/minimal-autogen/minimal-autogen.cabal @@ -0,0 +1,10 @@ +name: minimal-autogen +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: MinimalAutogen + , Paths_minimal_autogen + default-language: Haskell2010 + build-depends: base diff --git a/ghcide-test/data/dependency-boot/Dependency.hs b/ghcide-test/data/dependency-boot/Dependency.hs new file mode 100644 index 0000000000..c672fce14f --- /dev/null +++ b/ghcide-test/data/dependency-boot/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Data.Set (Set, empty) + +emptySet :: Set Int +emptySet = empty diff --git a/ghcide-test/data/dependency-boot/cabal.project b/ghcide-test/data/dependency-boot/cabal.project new file mode 100644 index 0000000000..aeaa0dc49d --- /dev/null +++ b/ghcide-test/data/dependency-boot/cabal.project @@ -0,0 +1,5 @@ +packages: . +package * + ghc-options: -fwrite-ide-info +package containers + ghc-options: -fwrite-ide-info diff --git a/ghcide-test/data/dependency-boot/dependency-boot.cabal b/ghcide-test/data/dependency-boot/dependency-boot.cabal new file mode 100644 index 0000000000..2ebc45a983 --- /dev/null +++ b/ghcide-test/data/dependency-boot/dependency-boot.cabal @@ -0,0 +1,10 @@ +name: dependency-boot +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , containers diff --git a/ghcide-test/data/dependency-boot/hie.yaml b/ghcide-test/data/dependency-boot/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide-test/data/dependency-boot/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide-test/data/dependency-where/Dependency.hs b/ghcide-test/data/dependency-where/Dependency.hs new file mode 100644 index 0000000000..29f171b7bd --- /dev/null +++ b/ghcide-test/data/dependency-where/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Data.Scientific (Scientific(base10Exponent)) + +b :: Scientific -> Int +b = base10Exponent diff --git a/ghcide-test/data/dependency-where/cabal.project b/ghcide-test/data/dependency-where/cabal.project new file mode 100644 index 0000000000..2ac401b801 --- /dev/null +++ b/ghcide-test/data/dependency-where/cabal.project @@ -0,0 +1,5 @@ +packages: . +package * + ghc-options: -fwrite-ide-info +package scientific + ghc-options: -fwrite-ide-info diff --git a/ghcide-test/data/dependency-where/dependency-where.cabal b/ghcide-test/data/dependency-where/dependency-where.cabal new file mode 100644 index 0000000000..e842dcfacb --- /dev/null +++ b/ghcide-test/data/dependency-where/dependency-where.cabal @@ -0,0 +1,10 @@ +name: dependency +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , scientific >= 0.3.8.1 diff --git a/ghcide-test/data/dependency-where/hie.yaml b/ghcide-test/data/dependency-where/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide-test/data/dependency-where/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide-test/data/dependency/Dependency.hs b/ghcide-test/data/dependency/Dependency.hs new file mode 100644 index 0000000000..aacefa3fbf --- /dev/null +++ b/ghcide-test/data/dependency/Dependency.hs @@ -0,0 +1,6 @@ +module Dependency where + +import Control.Concurrent.Async (AsyncCancelled (..)) + +asyncCancelled :: AsyncCancelled +asyncCancelled = AsyncCancelled diff --git a/ghcide-test/data/dependency/cabal.project b/ghcide-test/data/dependency/cabal.project new file mode 100644 index 0000000000..ce90b99fdb --- /dev/null +++ b/ghcide-test/data/dependency/cabal.project @@ -0,0 +1,7 @@ +packages: . +package * + ghc-options: -fwrite-ide-info +package async + ghc-options: -fwrite-ide-info +package hashable + ghc-options: -fwrite-ide-info diff --git a/ghcide-test/data/dependency/dependency.cabal b/ghcide-test/data/dependency/dependency.cabal new file mode 100644 index 0000000000..11017779ce --- /dev/null +++ b/ghcide-test/data/dependency/dependency.cabal @@ -0,0 +1,10 @@ +name: dependency +version: 0.1.0.0 +cabal-version: 2.0 +build-type: Simple + +library + exposed-modules: Dependency + default-language: Haskell2010 + build-depends: base + , async >= 2.2.6 diff --git a/ghcide-test/data/dependency/hie.yaml b/ghcide-test/data/dependency/hie.yaml new file mode 100644 index 0000000000..04cd24395e --- /dev/null +++ b/ghcide-test/data/dependency/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide-test/exe/Dependency.hs b/ghcide-test/exe/Dependency.hs new file mode 100644 index 0000000000..43baf42992 --- /dev/null +++ b/ghcide-test/exe/Dependency.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +module Dependency where + +import qualified Control.Applicative as Applicative +import Control.Applicative.Combinators (skipManyTill) +import Control.Lens (preview, (^.)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Bool (bool) +import Data.List (isSuffixOf) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text (isPrefixOf) +import Development.IDE.Test (expectNoMoreDiagnostics) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (FromServerMessage' (FromServerMess), + SMethod (SMethod_Progress, SMethod_TextDocumentPublishDiagnostics), + TCustomMessage (NotMess), + TNotificationMessage (..)) +import Language.LSP.Protocol.Types (Definition (..), Diagnostic, + Location (..), Position (..), + ProgressParams (..), + Range (..), + WorkDoneProgressEnd (..), + _workDoneProgressEnd, + type (|?) (InL, InR), + uriToFilePath) +import Language.LSP.Test (Session, anyMessage, + customNotification, + getDefinitions, message, + openDoc, satisfyMaybe) +import System.Exit (ExitCode (..)) +import System.FilePath (splitDirectories, (<.>), + ()) +import System.Process (cwd, proc, + readCreateProcessWithExitCode) +import Test.Hls.Util (GhcVersion (..), + knownBrokenForGhcVersions) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.ExpectedFailure (expectFailBecause) +import Test.Tasty.HUnit (assertBool, assertFailure, + (@?=)) + +import Config (testWithExtraFiles) + +tests :: TestTree +tests = + testGroup "gotoDefinition for dependencies" + [ dependencyTermTest + , dependencyTypeTest + , transitiveDependencyTest + , autogenDependencyTest + , bootDependencyTest + , whereClauseDependencyTest + ] + +fileDoneIndexing :: [String] -> Session FilePath +fileDoneIndexing fpSuffix = + skipManyTill anyMessage indexedFile + where + indexedFile :: Session FilePath + indexedFile = do + NotMess TNotificationMessage{_params} <- + customNotification (Proxy @"ghcide/reference/ready") + case A.fromJSON _params of + A.Success fp -> do + let fpDirs :: [String] + fpDirs = splitDirectories fp + bool Applicative.empty (pure fp) $ + fpSuffix `isSuffixOf` fpDirs + other -> error $ "Failed to parse ghcide/reference/ready file: " <> show other + +waitForDiagnosticsOrDoneIndexing :: Session [Diagnostic] +waitForDiagnosticsOrDoneIndexing = + skipManyTill anyMessage (diagnosticsMessage Applicative.<|> doneIndexing) + where + diagnosticsMessage :: Session [Diagnostic] + diagnosticsMessage = do + diagnosticsNotification <- message SMethod_TextDocumentPublishDiagnostics + let diagnosticss = diagnosticsNotification ^. L.params . L.diagnostics + return diagnosticss + doneIndexing :: Session [Diagnostic] + doneIndexing = satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ (preview _workDoneProgressEnd -> Just params))) -> + case params of + WorkDoneProgressEnd _ (Just message) -> bool Nothing (Just []) $ + "Finished indexing" `isPrefixOf` message + WorkDoneProgressEnd _ Nothing -> Nothing + _ -> Nothing + +prepareDependencyHieFiles :: [String] -> FilePath -> Session () +prepareDependencyHieFiles dependencyTargets dir = liftIO $ do + (exitCode, stdout, stderr) <- + readCreateProcessWithExitCode + (proc "cabal" (["build", "all"] <> dependencyTargets <> ["--ghc-options=-fwrite-ide-info"])) { cwd = Just dir } + "" + case exitCode of + ExitSuccess -> pure () + ExitFailure _ -> assertFailure $ + unlines + [ "Failed to build dependency fixture with HIE files." + , "Fixture directory: " <> dir + , "stdout:" + , stdout + , "stderr:" + , stderr + ] + +waitForProjectReady :: Session () +waitForProjectReady = expectNoMoreDiagnostics 5 + +assertLocationSuffix :: String -> [[String]] -> [String] -> IO () +assertLocationSuffix label expectedSuffixes locationDirectories = + assertBool (label <> " found in an unexpected module: " <> show locationDirectories) $ + any (`isSuffixOf` locationDirectories) expectedSuffixes + +asyncModuleSuffixes :: [[String]] +asyncModuleSuffixes = + [ ["Control", "Concurrent", "Async.hs"] + , ["Control", "Concurrent", "Async", "Internal.hs"] + ] + +-- | Tests that we can go to the definition of a term in a dependency. +-- In this case, we are getting the definition of the data +-- constructor AsyncCancelled. +dependencyTermTest :: TestTree +dependencyTermTest = testWithExtraFiles "gotoDefinition term in async" "dependency" $ + \dir -> do + prepareDependencyHieFiles ["async"] dir + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + defs <- getDefinitions doc (Position 5 20) + let expRange = Range (Position 312 22) (Position 312 36) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertLocationSuffix "AsyncCancelled" asyncModuleSuffixes locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + +-- | Tests that we can go to the definition of a type in a dependency. +-- In this case, we are getting the definition of the type AsyncCancelled. +dependencyTypeTest :: TestTree +dependencyTypeTest = testWithExtraFiles "gotoDefinition type in async" "dependency" $ + \dir -> do + prepareDependencyHieFiles ["async"] dir + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + defs <- getDefinitions doc (Position 4 21) + let expRange = Range (Position 312 0) (Position 317 5) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertLocationSuffix "AsyncCancelled" asyncModuleSuffixes locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + +-- | Tests that we can go to the definition of a dependency, and then +-- from the dependency file we can use gotoDefinition to see a +-- tranisive dependency. +transitiveDependencyTest :: TestTree +transitiveDependencyTest = testWithExtraFiles "goto transitive dependency async -> hashable" "dependency" $ + \dir -> do + prepareDependencyHieFiles ["async", "hashable"] dir + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + asyncDefs <- getDefinitions localDoc (Position 5 20) + asyncHsFile <- case asyncDefs of + InL (Definition (InR [Location uri _actualRange])) -> + liftIO $ do + let fp :: FilePath + fp = fromMaybe "" $ uriToFilePath uri + locationDirectories :: [String] + locationDirectories = splitDirectories fp + assertLocationSuffix "AsyncCancelled" asyncModuleSuffixes locationDirectories + pure fp + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for AsyncCancelled: " + ++ show wrongLocation + asyncDoc <- openDoc asyncHsFile "haskell" + waitForProjectReady + hashableDefs <- getDefinitions asyncDoc (Position 95 9) + -- The location of the definition of Hashable in + -- Data.Hashable.Class + let expRange = Range (Position 197 14) (Position 197 22) + case hashableDefs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "Hashable found in a module that is not Data.Hashable.Class" + $ ["Data", "Hashable", "Class.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for Hashable: " + ++ show wrongLocation + +-- | Testing that we can go to a definition in an autogen module of a +-- dependency. We use the repository https://github.com/nlander/minimal-autogen.git +-- as the dependency. It is a minimal package with an autogen module, +-- allowing us to avoid building a larger dependency in CI just for +-- this test. +autogenDependencyTest :: TestTree +autogenDependencyTest = testWithExtraFiles "goto autogen module in dependency" "dependency-autogen" $ + \dir -> do + prepareDependencyHieFiles ["minimal-autogen"] dir + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + defs <- getDefinitions localDoc (Position 6 5) + -- The location of the definition of version in + -- Paths_minimal_autogen + let expRange = Range (Position 5 0) (Position 5 7) + case defs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "version found in a module that is not Paths_minimal_autogen" + $ ["Paths_minimal_autogen.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for version: " + ++ show wrongLocation + +-- | Tests that we can go to a definition in a boot library, that is, +-- one of the libraries that ships with GHC. In this case we are +-- going to a definition in containers. This does not currently work +-- for available GHC versions but hopefully will for later versions +-- of GHC. +bootDependencyTest :: TestTree +bootDependencyTest = knownBrokenForGhcVersions [GHC96, GHC98, GHC910, GHC912, GHC914] "HIE files are not generated for boot libraries" $ + testWithExtraFiles "gotoDefinition term in boot library containers" "dependency-boot" $ + \dir -> do + prepareDependencyHieFiles ["containers"] dir + doc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + defs <- getDefinitions doc (Position 5 20) + -- The location of the definition of empty in Data.Set.Internal. + -- This will likely need to be updated when there is a GHC for + -- which this test can pass. + let expRange = Range (Position 513 0) (Position 513 11) + case defs of + InL (Definition (InR [Location fp actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath fp + assertBool "empty found in a module that is not Data.Set.Internal" + $ ["Data", "Set", "Internal.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for empty: " + ++ show wrongLocation + +-- | Testing that we can go to a definition in a where clause in a dependency. +-- This currently fails, but it is unclear why. +whereClauseDependencyTest :: TestTree +whereClauseDependencyTest = expectFailBecause "TODO: figure out why where clauses in dependencies are not indexed" $ + testWithExtraFiles "goto where clause definition in dependency" "dependency-where" $ + \dir -> do + prepareDependencyHieFiles ["scientific"] dir + localDoc <- openDoc (dir "Dependency" <.> "hs") "haskell" + waitForProjectReady + scientificDefs <- getDefinitions localDoc (Position 5 5) + scientificFile <- case scientificDefs of + InL (Definition (InR [Location uri _actualRange])) -> + liftIO $ do + let fp :: FilePath + fp = fromMaybe "" $ uriToFilePath uri + locationDirectories :: [String] + locationDirectories = splitDirectories fp + assertBool "base10Exponent found in a module that is not Data.Scientific" + $ ["Data", "Scientific.hs"] + `isSuffixOf` locationDirectories + pure fp + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for base10Exponent: " + ++ show wrongLocation + scientificDoc <- openDoc scientificFile "haskell" + -- Where longDiv is referenced in the function body + -- of unsafeFromRational in Data.Scientific + longDivDefs <- getDefinitions scientificDoc (Position 367 33) + -- The location of the definition of longDiv in + -- the where clause of unsafeFromRational + let expRange = Range (Position 371 4) (Position 376 55) + case longDivDefs of + InL (Definition (InR [Location uri actualRange])) -> + liftIO $ do + let locationDirectories :: [String] + locationDirectories = + maybe [] splitDirectories $ + uriToFilePath uri + assertBool "longDiv found in a module that is not Data.Scientific" + $ ["Data", "Scientific.hs"] + `isSuffixOf` locationDirectories + actualRange @?= expRange + wrongLocation -> + liftIO $ + assertFailure $ "Wrong location for longDiv: " + ++ show wrongLocation diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs index 4edb4b022b..1ff5f1094d 100644 --- a/ghcide-test/exe/Main.hs +++ b/ghcide-test/exe/Main.hs @@ -44,6 +44,7 @@ import ConstructorHoverTests import CPPTests import CradleTests import DependentFileTest +import Dependency import DiagnosticTests import ExceptionTests import FindDefinitionAndHoverTests @@ -95,6 +96,7 @@ main = do , WatchedFileTests.tests , CradleTests.tests , DependentFileTest.tests + , Dependency.tests , NonLspCommandLine.tests , IfaceTests.tests , BootTests.tests diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 6098498701..2fc4aa1072 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -129,9 +129,12 @@ library Development.IDE.Core.Actions Development.IDE.Core.Compile Development.IDE.Core.Debouncer + Development.IDE.Core.Dependencies Development.IDE.Core.FileStore Development.IDE.Core.FileUtils + Development.IDE.Core.HieFile 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..9e725b6084 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) @@ -108,11 +109,12 @@ import Text.ParserCombinators.ReadP (readP_to_S) import Control.Concurrent.STM (STM, TVar) import qualified Control.Monad.STM as STM import Control.Monad.Trans.Reader +import Development.IDE.Core.Dependencies (indexDependencyHieFiles) +import qualified Development.IDE.Core.HieFile as HieFile import qualified Development.IDE.Session.Ghc as Ghc import qualified Development.IDE.Session.OrderedSet as S import qualified Focus import qualified StmContainers.Map as STM - data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -136,6 +138,7 @@ data Log | LogLookupSessionCache !FilePath | LogTime !String | LogSessionGhc Ghc.Log + | LogHieFile HieFile.HieFileLog deriving instance Show Log instance Pretty Log where @@ -207,6 +210,7 @@ instance Pretty Log where "Cradle:" <+> viaShow cradle LogHieBios msg -> pretty msg LogSessionGhc msg -> pretty msg + LogHieFile msg -> pretty msg LogSessionLoadingChanged -> "Session Loading config changed, reloading the full session." @@ -681,6 +685,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , sessionClientConfig = clientConfig , sessionSharedNameCache = ideNc , sessionLoadingOptions = newSessionLoadingOptions + , sessionShakeExtras = extras } writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) @@ -743,6 +748,7 @@ data SessionEnv = SessionEnv , sessionClientConfig :: Config , sessionSharedNameCache :: NameCache , sessionLoadingOptions :: SessionLoadingOptions + , sessionShakeExtras :: ShakeExtras } type SessionM = ReaderT SessionEnv IO @@ -887,7 +893,9 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l -- HscEnv but set the active component accordingly hscEnv <- initEmptyHscEnv ideOptions <- asks sessionIdeOptions - let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv + extras <- asks sessionShakeExtras + let indexDependencies env = indexDependencyHieFiles (cmapWithPrio LogHieFile recorder) extras env + new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) indexDependencies (optExtensions ideOptions) cfp hscEnv all_target_details <- liftIO $ new_cache old_components_info new_components_info (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp -- The VFS doesn't change on cradle edits, re-use the old one. @@ -906,9 +914,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/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index 3b659a6bee..2f01b80feb 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -58,7 +58,6 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State - #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) #endif @@ -144,13 +143,14 @@ addUnit unit_str = liftEwM $ do -- session on GHC 9.4+ newComponentCache :: Recorder (WithPriority Log) + -> (HscEnv -> IO ()) -> [String] -- ^ File extensions to consider -> NormalizedFilePath -- ^ Path to file that caused the creation of this component -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components -> IO [ [TargetDetails] ] -newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do +newComponentCache recorder indexDependencies exts _cfp hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, -- prefer the new one over the old. @@ -205,7 +205,7 @@ newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do -- above. -- We just need to set the current unit here pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' - henv <- newHscEnvEq thisEnv + henv <- newHscEnvEq indexDependencies thisEnv let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 7b16f1fa4f..a3d06be6ac 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 @@ -50,18 +51,27 @@ getAtPoint file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useWithStaleFastMT GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file 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) - let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary)) + -- The HscEnv and DKMap are not strictly necessary for hover + -- to work, so we only calculate them for project files, not + -- for dependency files. They provide information that will + -- not be displayed in dependency files. See the atPoint + -- function in ghcide/src/Development/IDE/Spans/AtPoint.hs + -- for the specifics of how they are used. + (mEnv, mDkMap, mEnabledExtensions) <- case toProjectHaskellInput file of + Nothing -> pure (Nothing, Nothing, Nothing) + Just input -> do + 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)) + pure (Just env, Just dkMap, Just enabledExtensions) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> - AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions + AtPoint.atPoint opts shakeExtras hf mDkMap mEnv pos' mEnabledExtensions -- | Converts locations in the source code to their current positions, -- taking into account changes that may have occurred due to edits. @@ -84,7 +94,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 +105,10 @@ 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 + (hf, mapping) <- useWithStaleFastMT GetHieAst $ toAllHaskellInput file + (ImportMap imports, _) <- case toProjectHaskellInput file of + Just input -> useWithStaleFastMT GetImportMap input + Nothing -> pure( ImportMap mempty, PositionMapping idDelta) !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' mapMaybeM (\(location, identifier) -> do @@ -109,7 +121,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 +133,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 +150,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/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 6ce05b5236..7d7c550911 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -932,22 +932,22 @@ spliceExpressions Splices{..} = -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we -- can just increment the 'indexCompleted' TVar and exit. -- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () -indexHieFile se mod_summary srcPath !hash hf = do +indexHieFile :: ShakeExtras -> NormalizedFilePath -> HieDb.SourceFile -> Util.Fingerprint -> Compat.HieFile -> IO () +indexHieFile se hiePath sourceFile !hash hf = do atomically $ do pending <- readTVar indexPending - case HashMap.lookup srcPath pending of + case HashMap.lookup hiePath pending of Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled _ -> do -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around let !hf' = hf{hie_hs_src = mempty} - modifyTVar' indexPending $ HashMap.insert srcPath hash + modifyTVar' indexPending $ HashMap.insert hiePath hash writeTaskQueue indexQueue $ \withHieDb -> do -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do pendingOps <- readTVar indexPending - pure $ case HashMap.lookup srcPath pendingOps of + pure $ case HashMap.lookup hiePath pendingOps of Nothing -> False -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash @@ -955,10 +955,8 @@ indexHieFile se mod_summary srcPath !hash hf = do -- Using bracket, so even if an exception happen during withHieDb call, -- the `post` (which clean the progress indicator) will still be called. bracket_ pre post $ - withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') + withHieDb (\db -> HieDb.addRefsFromLoaded db ( fromNormalizedFilePath hiePath) sourceFile hash hf') where - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location HieDbWriter{..} = hiedbWriter se pre = progressUpdate indexProgressReporting ProgressStarted @@ -967,7 +965,7 @@ indexHieFile se mod_summary srcPath !hash hf = do mdone <- atomically $ do -- Remove current element from pending pending <- stateTVar indexPending $ - dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath + dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) hiePath modifyTVar' indexCompleted (+1) -- If we are done, report and reset completed whenMaybe (HashMap.null pending) $ @@ -975,7 +973,9 @@ indexHieFile se mod_summary srcPath !hash hf = do whenJust (lspEnv se) $ \env -> LSP.runLspT env $ when (coerce $ ideTesting se) $ LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath srcPath + toJSON $ case sourceFile of + HieDb.RealFile sourceFilePath -> sourceFilePath + HieDb.FakeFile _ -> fromNormalizedFilePath hiePath whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted writeAndIndexHieFile @@ -992,7 +992,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = GHC.mkHieFile' mod_summary exports ast source atomicFileWrite se targetPath $ flip GHC.writeHieFile hf hash <- Util.getFileHash targetPath - indexHieFile se mod_summary srcPath hash hf + indexHieFile se (toNormalizedFilePath' targetPath) (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf where dflags = hsc_dflags hscEnv mod_location = ms_location mod_summary diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs new file mode 100644 index 0000000000..4d7fe7f2be --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} + +module Development.IDE.Core.Dependencies + ( indexDependencyHieFiles + ) where +import Control.Concurrent.STM (atomically) +import Control.Monad (unless, void) +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (isNothing) +import Data.Set (Set) +import qualified Data.Set as Set +import Development.IDE.Core.Compile (indexHieFile) +import Development.IDE.Core.HieFile (HieFileCheck (..), HieFileLog, + checkHieFile) +import Development.IDE.Core.Shake (HieDbWriter (indexQueue), + ShakeExtras (hiedbWriter, lspEnv, withHieDb)) +import Development.IDE.Core.WorkerThread (writeTaskQueue) +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat as Ghc +import Development.IDE.Types.Location (NormalizedFilePath, + toNormalizedFilePath') +import GHC.Data.ShortText (unpack) +#if MIN_VERSION_ghc(9,7,0) +import GHC.Types.Unique.Map (nonDetEltsUniqMap) +#endif +import qualified GHC.Unit.Info as GHC +import HieDb (SourceFile (FakeFile), + lookupPackage, + removeDependencySrcFiles) +import Ide.Logger (Recorder, WithPriority) +import Ide.Types (hlsDirectory) +import Language.LSP.Server (LanguageContextEnv (resRootPath)) +import System.Directory (doesDirectoryExist) +import System.FilePath ((<.>), ()) + +{- Note [Going to definitions in dependencies] + - There are two main components of the functionality that enables gotoDefinition for + - third party dependencies: + - + the changes to the lookupMod function in ghcide/src/Development/IDE/Core/Actions.hs, + - which are triggered on calls to gotoDefinition. + - + the code that indexes dependencies in the hiedb, which can be found in this module. + - This gets run asynchronously, triggering every time newHscEnvEqWithImportPaths gets called. + - + - The gotoDefinition code was originally written in such a way that it was + - expecting that we would eventually be able to go to dependency definitions. + - Before the funtionality was implemented, lookupMod was a no-op stub intended to + - be where functionality would eventually go for dependencies. You can see the + - code that eventually ends up calling lookupMod in the function nameToLocation in + - ghcide/src/Development/IDE/Spans/AtPoint.hs. To summarize, gotoDefinition will look + - for a file in the project, and look in the hiedb if it can't find it. In this sense, + - the name lookupMod might be a little misleading, because by the time it gets called, + - the HIE file has already been looked up in the database and we have the FilePath + - of its location. A more appropriate name might be something like loadModule, + - since what it does is load the module source code from an HIE file and write it out to + - .hls/dependencies. The way nameToLocation works, if we have already opened a + - dependency file once, lookupMod won't get called. In addition to loading the + - dependency source and writing it out, lookupMod handles indexing the source file + - that we wrote out, which can't happen in the initial indexing since the + - source file doesn't exist at that point. To summarize, for gotoDefinition to work + - for a dependency we need to have already indexed the HIE file for that dependency module. + - + - The indexing process gets the packages and modules for dependencies from the HscEnv. + - It filters them for packages we know are direct or transitive dependencies, using the + - function calculateTransitiveDependencies. indexDependencyHieFiles attempts to load an + - HIE file for each module, checking for it in the extra-compilation-artifacts directory, + - found in the package lib directory. This fails for the packages that ship with GHC, + - because it doesn't yet generate HIE files. If it is able to load the HIE file, + - it indexes it in hiedb using indexHieFile, which is the same function used to + - index project HIE files. + -} + +-- | We make this newtype only so that we can have an Ord +-- instance. This gives us the convenience of being able +-- to use a Package as the key in the Map packagesWithModules, +-- and process the packages and their modules using the +-- Map.traverseWithKey function. +newtype Package = Package GHC.UnitInfo deriving Eq + +instance Ord Package where + compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) + +-- | indexDependencyHieFiles gets all of the direct and transitive dependencies +-- from the HscEnv and indexes their HIE files in the HieDb +indexDependencyHieFiles :: Recorder (WithPriority HieFileLog) -> ShakeExtras -> GHC.HscEnv -> IO () +indexDependencyHieFiles recorder se hscEnv = do + -- Check whether the .hls directory exists + dotHlsDirExists <- maybe (pure False) doesDirectoryExist mHlsDir + -- If the .hls directory does not exists, it may have been deleted + -- In this case, delete the indexed source file for all + -- dependencies that are already indexed. + unless dotHlsDirExists deleteMissingDependencySources + void $ Map.traverseWithKey indexPackageHieFiles packagesWithModules + where + mHlsDir :: Maybe FilePath + mHlsDir = do + projectDir <- resRootPath =<< lspEnv se + pure $ projectDir hlsDirectory + -- Add the deletion of dependency source files from the + -- HieDb database to the database write queue + deleteMissingDependencySources :: IO () + deleteMissingDependencySources = + atomically $ writeTaskQueue (indexQueue $ hiedbWriter se) $ + \withHieDb -> + withHieDb $ \db -> + removeDependencySrcFiles db + -- Index all of the modules in a package (a Unit). + indexPackageHieFiles :: Package -> [GHC.Module] -> IO() + indexPackageHieFiles (Package package) modules = do + let pkgLibDir :: FilePath + pkgLibDir = case GHC.unitLibraryDirs package of + [] -> "" + (libraryDir : _) -> unpack libraryDir + -- Cabal puts the HIE files for a package in the + -- extra-compilation-artifacts directory, provided + -- it is compiled with the -fwrite-ide-info ghc option. + hieDir :: FilePath + hieDir = pkgLibDir "extra-compilation-artifacts" "hie" + unit :: GHC.Unit + unit = Ghc.RealUnit $ GHC.Definite $ GHC.unitId package + -- Check if we have already indexed this package + moduleRows <- withHieDb se $ \db -> + lookupPackage db unit + case moduleRows of + -- There are no modules from this package in the database, + -- so go ahead and index all of the modules + [] -> traverse_ (indexModuleHieFile hieDir) modules + -- There are modules from this package in the database, + -- so assume all the modules have already been indexed + -- and do nothing + _ -> return () + + indexModuleHieFile :: FilePath -> GHC.Module -> IO() + indexModuleHieFile hieDir m = do + let hiePath :: NormalizedFilePath + hiePath = toNormalizedFilePath' $ + hieDir GHC.moduleNameSlashes (GHC.moduleName m) <.> "hie" + -- Check that the module HIE file has correctly loaded if there + -- was some problem loading it, or if it has already been indexed + -- (which shouldn't happen because we check whether each package + -- has been indexed), then do nothing. Otherwise, call the + -- indexHieFile function from Core.Compile. + hieCheck <- checkHieFile recorder se "IndexDependencyHieFiles" hiePath + case hieCheck of + HieFileMissing -> return () + HieAlreadyIndexed -> return () + CouldNotLoadHie _e -> return () + DoIndexing hash hie -> + -- At this point there is no source file for the Hie file, + -- so the Hiedb.sourceFile we give is FakeFile Nothing. + indexHieFile se hiePath (FakeFile Nothing) hash hie + packagesWithModules :: Map.Map Package [GHC.Module] + packagesWithModules = Map.fromSet getModulesForPackage packages + packages :: Set Package + packages = Set.fromList + $ map Package + $ unitInfoEltsIn dependencyIds unitInfoMap + where + unitInfoMap :: GHC.UnitInfoMap + unitInfoMap = GHC.getUnitInfoMap hscEnv + dependencyIds :: Set GHC.UnitId + dependencyIds = + calculateTransitiveDependencies unitInfoMap directDependencyIds directDependencyIds + directDependencyIds :: Set GHC.UnitId + directDependencyIds = Set.fromList + $ map GHC.toUnitId + $ GHC.explicitUnits + $ GHC.unitState hscEnv + +-- | calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap +-- that are dependencies or transitive dependencies. +calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies unitInfoMap allDependencies newDependencies + -- If there are no new dependencies, we have found them all, + -- so return allDependencies + | Set.null newDependencies = allDependencies + -- Otherwise recursively add any dependencies of the newDependencies + -- that are not in allDependencies already + | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew + where + nextAll :: Set GHC.UnitId + nextAll = Set.union allDependencies nextNew + -- Get the dependencies of the newDependencies. Then the nextNew dependencies + -- will be the set difference of the dependencies we have so far (all dependencies), + -- and the dependencies of the newDependencies. + nextNew :: Set GHC.UnitId + nextNew = flip Set.difference allDependencies + $ Set.unions + $ map (Set.fromList . GHC.unitDepends) + $ unitInfoEltsIn newDependencies unitInfoMap + +unitInfoEltsIn :: Set GHC.UnitId -> GHC.UnitInfoMap -> [GHC.UnitInfo] +#if MIN_VERSION_ghc(9,7,0) +unitInfoEltsIn unitIds = + filter ((`Set.member` unitIds) . GHC.unitId) . nonDetEltsUniqMap +#else +unitInfoEltsIn unitIds = + filter ((`Set.member` unitIds) . GHC.unitId) . Map.elems +#endif + +getModulesForPackage :: Package -> [GHC.Module] +getModulesForPackage (Package package) = + map makeModule allModules + where + allModules :: [GHC.ModuleName] + allModules = map fst + -- The modules with a Just value in the tuple + -- are from other packages. These won't have + -- an HIE file in this package, and should be + -- covered by the transitive dependencies. + ( filter (isNothing . snd) + $ GHC.unitExposedModules package + ) + ++ GHC.unitHiddenModules package + makeModule :: GHC.ModuleName + -> GHC.Module + makeModule = GHC.mkModule (GHC.mkUnit package) 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/HieFile.hs b/ghcide/src/Development/IDE/Core/HieFile.hs new file mode 100644 index 0000000000..46c8729e27 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/HieFile.hs @@ -0,0 +1,143 @@ +module Development.IDE.Core.HieFile + ( HieFileCheck(..) + , checkHieFile + , readHieFileFromDisk + , HieFileLog(..) + ) where + +import Control.Exception (SomeException, displayException) +import Control.Monad.Except +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Bool (bool) + +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Util +import qualified HieDb + +import Development.IDE.Core.Compile (loadHieFile) +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat (HieFile) +import Development.IDE.Types.Location +import Ide.Logger +import System.Directory +import Control.Exception.Safe (tryAny) +import Control.Monad.Trans.Except (except) + +data HieFileLog + = LogLoading !NormalizedFilePath + | LogMissing !NormalizedFilePath + | LogLoadingFail !NormalizedFilePath !SomeException + | LogLoadingSuccess !NormalizedFilePath + deriving Show + +instance Pretty HieFileLog where + pretty = \case + LogLoading path -> + "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + LogMissing path -> + "MISSING HIE FILE" <+> pretty (fromNormalizedFilePath path) + LogLoadingFail path e -> + nest 2 $ + vcat + [ "FAILED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path) + , pretty (displayException e) + ] + LogLoadingSuccess path -> + "SUCCEEDED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path) + +-- | The result of checkHieFile, which returns a reason why an +-- HIE file should not be indexed, or the data necessary for +-- indexing in the HieDb database. +data HieFileCheck + = HieFileMissing + | HieAlreadyIndexed + | CouldNotLoadHie SomeException + | DoIndexing Util.Fingerprint HieFile + +-- | checkHieFile verifies that an HIE file exists, that it has not already +-- been indexed, and attempts to load it. This is intended to happen before +-- any indexing of HIE files in the HieDb database. In addition to returning +-- a HieFileCheck, this function also handles logging. +checkHieFile + :: Recorder (WithPriority HieFileLog) + -> ShakeExtras + -> String + -> NormalizedFilePath + -> IO HieFileCheck +checkHieFile recorder se@ShakeExtras{withHieDb} tag hieFileLocation = do + hieFileExists <- doesFileExist $ + fromNormalizedFilePath hieFileLocation + + bool + logHieFileMissing + checkExistingHieFile + hieFileExists + where + + -- Log that the HIE file does not exist where we expect that it should. + logHieFileMissing :: IO HieFileCheck + logHieFileMissing = do + let logMissing :: HieFileLog + logMissing = LogMissing hieFileLocation + + logWith recorder Debug logMissing + pure HieFileMissing + + -- When we know that the HIE file exists, check that it has not already + -- been indexed. If it hasn't, try to load it. + checkExistingHieFile :: IO HieFileCheck + checkExistingHieFile = do + hieFileHash <- Util.getFileHash $ + fromNormalizedFilePath hieFileLocation + + mrow <- withHieDb $ + \hieDb -> HieDb.lookupHieFileFromHash hieDb hieFileHash + + dbHieFileLocation <- + traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow + + bool + (tryLoadingHieFile hieFileHash) + (pure HieAlreadyIndexed) + (Just hieFileLocation == fmap toNormalizedFilePath' dbHieFileLocation) + + -- Attempt to load the HIE file, logging on failure + -- (logging happens in readHieFileFromDisk). + -- If the file loads successfully, return the data necessary + -- for indexing it in the HieDb database. + tryLoadingHieFile :: Util.Fingerprint -> IO HieFileCheck + tryLoadingHieFile hieFileHash = do + ehf <- runIdeAction tag se $ + runExceptT $ + readHieFileFromDisk + recorder + hieFileLocation + + pure $ case ehf of + Left err -> CouldNotLoadHie err + Right hf -> DoIndexing hieFileHash hf + +readHieFileFromDisk + :: Recorder (WithPriority HieFileLog) + -> NormalizedFilePath + -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk recorder hieLoc = do + nc <- asks ideNc + + res <- liftIO $ + tryAny $ + loadHieFile (mkUpdater nc) (fromNormalizedFilePath hieLoc) + + case res of + Left e -> + liftIO $ + logWith recorder Debug $ + LogLoadingFail hieLoc e + + Right _ -> + liftIO $ + logWith recorder Debug $ + LogLoadingSuccess hieLoc + + except res 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/LookupMod.hs b/ghcide/src/Development/IDE/Core/LookupMod.hs index 981773c34b..b009da3245 100644 --- a/ghcide/src/Development/IDE/Core/LookupMod.hs +++ b/ghcide/src/Development/IDE/Core/LookupMod.hs @@ -1,10 +1,35 @@ module Development.IDE.Core.LookupMod (lookupMod, LookupModule) where -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import Development.IDE.Core.Shake (HieDbWriter, IdeAction) -import Development.IDE.GHC.Compat.Core (ModuleName, Unit) -import Development.IDE.Types.Location (Uri) - +import Control.Concurrent (newEmptyMVar, putMVar, + readMVar) +import Control.Concurrent.STM (atomically) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.RWS (asks) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Data.ByteString as BS +import Data.Function ((&)) +import Development.IDE.Core.Compile (loadHieFile) +import Development.IDE.Core.Shake (HieDbWriter (HieDbWriter, indexQueue), + IdeAction, + ShakeExtras (ideNc, lspEnv), + mkUpdater) +import Development.IDE.Core.WorkerThread (writeTaskQueue) +import Development.IDE.GHC.Compat (HieFile (hie_hs_src)) +import Development.IDE.GHC.Compat.Core (ModuleName, Unit, + moduleNameSlashes) +import Development.IDE.Types.Location (Uri, filePathToUri', + toNormalizedFilePath') +import qualified Development.IDE.Types.Location as LSP +import GHC.MVar (MVar) +import qualified HieDb +import Language.LSP.Server (LanguageContextEnv (resRootPath)) +import System.Directory (createDirectoryIfMissing, + doesFileExist, + getPermissions, + setOwnerExecutable, + setOwnerWritable, + setPermissions) +import System.FilePath (takeDirectory, (<.>), ()) -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri @@ -21,4 +46,68 @@ lookupMod :: -- | Is this file a boot file? Bool -> MaybeT IdeAction Uri -lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing +lookupMod HieDbWriter{indexQueue} hieFile moduleName uid _boot = MaybeT $ do + -- We need the project root directory to determine where to put + -- the .hls directory. + mProjectRoot <- (resRootPath =<<) <$> asks lspEnv + case mProjectRoot of + Nothing -> pure Nothing + Just projectRoot -> do + -- Database writes happen asynchronously. We use Mvar to mark + -- completion of the database update + completionToken <- liftIO newEmptyMVar + -- Write out the contents of the dependency source to the + -- .hls/dependencies directory, generate a URI for that + -- location, and update the HieDb database with the source + -- file location + moduleUri <- writeAndIndexHieFile projectRoot completionToken + -- wait for the database update to be completed. + -- Reading the completionToken is blocked until it has + -- a value + liftIO $ readMVar completionToken + pure $ Just moduleUri + where + writeAndIndexHieFile :: FilePath -> MVar () -> IdeAction Uri + writeAndIndexHieFile projectRoot completionToken = do + fileExists <- liftIO $ doesFileExist writeOutPath + -- No need to write out the file if it already exists + if fileExists then pure () else do + nc <- asks ideNc + liftIO $ do + -- Create the directory where we will put the source + createDirectoryIfMissing True $ takeDirectory writeOutPath + -- Load a raw Bytestring of the source from the HIE file + moduleSource <- hie_hs_src <$> loadHieFile (mkUpdater nc) hieFile + -- Write the source into the .hls/dependencies directory + BS.writeFile writeOutPath moduleSource + fileDefaultPermissions <- getPermissions writeOutPath + let filePermissions = fileDefaultPermissions + & setOwnerWritable False + & setOwnerExecutable False + -- Set the source file to readonly permissions. + setPermissions writeOutPath filePermissions + liftIO $ atomically $ + writeTaskQueue indexQueue $ \withHieDb -> do + withHieDb $ \db -> + -- Add a source file to the database row for + -- the HIE file + HieDb.addSrcFile db hieFile writeOutPath False + -- Mark completion of the database update. + putMVar completionToken () + pure moduleUri + + where + writeOutDir :: FilePath + writeOutDir = projectRoot ".hls" "dependencies" show uid + + -- The module name is separated into directories, with the + -- last part of the module name giving the name of the + -- haskell file with a .hs extension + writeOutFile :: FilePath + writeOutFile = moduleNameSlashes moduleName <.> "hs" + + writeOutPath :: FilePath + writeOutPath = writeOutDir writeOutFile + + moduleUri :: Uri + moduleUri = LSP.fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' writeOutPath diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 19e0f40e24..30c800ef6e 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) @@ -78,6 +80,7 @@ ofInterestRules recorder = do summarize (IsFOI OnDisk) = BS.singleton 1 summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 + summarize (IsFOI ReadOnly) = BS.singleton 4 ------------------------------------------------------------ newtype GarbageCollectVar = GarbageCollectVar (Var Bool) @@ -132,23 +135,32 @@ 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 + -- We cannot run all the Rules on ReadOnly dependency files, so + -- we filter those out. + projectFiles :: [InputPath ProjectHaskellFiles] + projectFiles = classifyProjectHaskellInputs $ HashMap.keys + $ HashMap.filter (/= ReadOnly) filesOfInterestMap + 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..21ca004a0a 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -35,8 +35,8 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) import GHC.Iface.Ext.Types (HieASTs, - TypeIndex) -import GHC.Iface.Ext.Utils (RefMap) + TypeIndex, getAsts) +import GHC.Iface.Ext.Utils (RefMap, generateReferencesMap) import Data.ByteString (ByteString) import Data.Text.Utf16.Rope.Mixed (Rope) @@ -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 @@ -229,6 +245,19 @@ data HieAstResult -- ^ Is this hie file loaded from the disk, or freshly computed? } +-- | Make an HieAstResult from loaded HieFile +makeHieAstResult :: HieFile -> HieAstResult +makeHieAstResult hieFile = + HAR + (hie_module hieFile) + hieAst + (generateReferencesMap $ M.elems $ getAsts hieAst) + mempty + (HieFromDisk hieFile) + where + hieAst :: HieASTs TypeIndex + hieAst = hie_asts hieFile + data HieKind a where HieFromDisk :: !HieFile -> HieKind TypeIndex HieFresh :: HieKind Type @@ -245,12 +274,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 +302,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 +381,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 @@ -370,6 +422,7 @@ instance Hashable GetFileHash data FileOfInterestStatus = OnDisk + | ReadOnly | Modified { firstOpen :: !Bool -- ^ was this file just opened } deriving (Eq, Show, Generic) @@ -385,6 +438,7 @@ instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult +type instance RuleInput IsFileOfInterest = AllHaskellFiles data ModSummaryResult = ModSummaryResult { msrModSummary :: !ModSummary @@ -406,10 +460,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 +487,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 +596,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 +607,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..d0d0d10a45 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -74,6 +74,7 @@ import Control.Monad.Trans.Except (ExceptT, except, import Control.Monad.Trans.Maybe import Data.Aeson (toJSON) import qualified Data.Binary as B +import Data.Bool (bool) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce @@ -103,6 +104,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 @@ -141,11 +143,11 @@ import GHC.Iface.Ext.Types (HieASTs (..)) import GHC.Iface.Ext.Utils (generateReferencesMap) import qualified GHC.LanguageExtensions as LangExt #if MIN_VERSION_ghc(9,13,0) -import GHC.Types.PkgQual (PkgQual (NoPkgQual)) import GHC.Types.Basic (ImportLevel (..)) -import GHC.Unit.Types (GenWithIsBoot(..)) +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) import GHC.Unit.Module.Graph (mkModuleEdge) import GHC.Unit.Module.ModNodeKey (mnkModuleName) +import GHC.Unit.Types (GenWithIsBoot (..)) #endif import HIE.Bios.Ghc.Gap (hostIsDynamic) import qualified HieDb @@ -166,7 +168,10 @@ import Ide.Plugin.Properties (HasProperty, useProperty, usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), - PluginId, getVirtualFileFromVFS) + PluginId, + SourceFileOrigin (..), + getSourceFileOrigin, + getVirtualFileFromVFS) import qualified Language.LSP.Protocol.Lens as JL import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import Language.LSP.Protocol.Types (MessageType (MessageType_Info), @@ -175,9 +180,10 @@ import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prelude hiding (mod) -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, + makeAbsolute) import System.Info.Extra (isWindows) - +import qualified Development.IDE.Core.HieFile as HieFile import qualified Data.IntMap as IM import GHC.Fingerprint @@ -188,7 +194,9 @@ data Log | LogLoadingHieFile !NormalizedFilePath | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath + | LogMissingHieFile !NormalizedFilePath | LogTypecheckedFOI !NormalizedFilePath + | LogHieFile HieFile.HieFileLog deriving Show instance Pretty Log where @@ -205,6 +213,8 @@ instance Pretty Log where , pretty (displayException e) ] LogLoadingHieFileSuccess path -> "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path + LogMissingHieFile path -> + "MISSING HIE FILE" <+> pretty (fromNormalizedFilePath path) LogTypecheckedFOI path -> vcat [ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path) , "This can indicate a bug which results in excessive memory usage." @@ -213,6 +223,7 @@ instance Pretty Log where <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" <+> "triggered this warning." ] + LogHieFile msg -> pretty msg templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -231,18 +242,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 +279,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 +306,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 +346,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 +395,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 +405,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 +441,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 +497,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 +519,35 @@ 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 + -- For Dependency source files, get the HieAstResult from + -- the HIE file in the HieDb database + Nothing -> do + se <- getShakeExtras + mHieFile <- liftIO + $ runIdeAction "GetHieAst" se + $ runMaybeT + -- We can look up the HIE file from its source + -- because at this point lookupMod has already been + -- called and has created the source file in + -- the .hls directory and indexed it + $ readHieFileForSrcFromDisk recorder f + pure ([], makeHieAstResult <$> mHieFile) + 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 +561,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 +572,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 +603,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 +615,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 @@ -601,28 +633,19 @@ readHieFileForSrcFromDisk recorder file = do row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file - exceptToMaybeT $ readHieFileFromDisk recorder hie_loc - -readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile -readHieFileFromDisk recorder hie_loc = do - nc <- asks ideNc - res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - case res of - Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e - Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc - except res + exceptToMaybeT $ HieFile.readHieFileFromDisk (cmapWithPrio LogHieFile recorder) (toNormalizedFilePath' hie_loc) -- | Typechecks a module. 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 +657,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 +682,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 +717,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 +735,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 +771,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 +807,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 +822,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 +842,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 +873,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 +881,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 +913,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,18 +923,18 @@ 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 $ - readHieFileFromDisk recorder hie_loc + HieFile.readHieFileFromDisk (cmapWithPrio LogHieFile recorder) (toNormalizedFilePath' hie_loc) case ehf of -- Uh oh, we failed to read the file for some reason, need to regenerate it 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 (toNormalizedFilePath' hie_loc) (HieDb.RealFile $ fromNormalizedFilePath $ unInputPath f) fileHash hf return (Just x) @@ -932,8 +956,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 +983,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 +996,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 +1039,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 +1047,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 +1060,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 +1157,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 +1210,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 +1235,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 +1333,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..2cbbbb95b8 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 @@ -203,6 +203,7 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogUnsafeDependencyRule !NormalizedFilePath !T.Text deriving Show instance Pretty Log where @@ -248,7 +249,12 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) - + LogUnsafeDependencyRule file key -> + vcat + [ "Unsafe rule requested for dependency source file:" + , "File:" <+> pretty (fromNormalizedFilePath file) + , "Rule:" <+> pretty key + ] -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by -- a worker thread. @@ -395,7 +401,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 +472,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 +518,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 +533,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 +602,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 +628,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 +1036,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 +1062,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 +1072,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 +1103,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 +1132,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 +1144,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 +1156,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 - ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras +defineEarlyCutoff' doDiagnostics cmp key input mbOld mode action = do + let file = unInputPath input + ShakeExtras{state, progress, dirtyKeys, shakeRecorder} <- 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,17 +1290,40 @@ 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 Just (Failed b, _) -> Failed b - (mbBs, (diags, mbRes)) <- actionCatch - (do v <- action staleV; liftIO $ evaluate $ force v) $ - \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing)) + let doAction = + actionCatch + (do v <- action staleV; liftIO $ evaluate $ force v) $ + \(e :: SomeException) -> do + pure + ( Nothing + , ( [ ideErrorText file (T.pack $ show (key, file) ++ show e) + | not $ isBadDependency e + ] + , Nothing + ) + ) + + (mbBs, (diags, mbRes)) <- case getSourceFileOrigin file of + FromProject -> + doAction - ver <- estimateFileVersionUnsafely key mbRes file + FromDependency + | isSafeDependencyRule key -> + doAction + + -- If the rule is not safe, Log them + -- For now we still let the Rule trigger. Ideally should not trigger Rule and only log + | otherwise -> do + logWith shakeRecorder Error $ + LogUnsafeDependencyRule file (T.pack $ show key) + doAction + + ver <- estimateFileVersionUnsafely key mbRes input (bs, res) <- case mbRes of Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) @@ -1305,7 +1341,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 +1351,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,8 +1364,25 @@ 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) + + isSafeDependencyRule :: k -> Bool + isSafeDependencyRule _k + -- Dependency files need GetHieAst for hover/definition. + | Just Refl <- eqT @k @GetHieAst = True + + -- Dependency files can still be files of interest. + | Just Refl <- eqT @k @IsFileOfInterest = True + + -- Safe metadata/file watching rules. + | Just Refl <- eqT @k @GetFileContents = True + | Just Refl <- eqT @k @GetFileExists = True + | Just Refl <- eqT @k @GetFileHash = True + | Just Refl <- eqT @k @GetPhysicalModificationTime = True + | Just Refl <- eqT @k @GetModificationTime = True + | Just Refl <- eqT @k @AddWatchedFile = True + | otherwise = False -- Note [Housekeeping rule cache and dirty key outside of hls-graph] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Hls-graph contains its own internal running state for each key in the shakeDatabase. @@ -1495,9 +1548,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/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 4f5475442c..1e992a2bf7 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -69,25 +69,42 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] whenUriFile _uri $ \file -> do + let foiStatus = case getSourceFileOrigin file of + FromProject -> Modified{firstOpen = True} + FromDependency ->ReadOnly -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ - addFileOfInterest ide file Modified{firstOpen=True} + case foiStatus of + ReadOnly -> void $ addFileOfInterest ide file ReadOnly + _ -> setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=True} logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ - addFileOfInterest ide file Modified{firstOpen=False} + let foiStatus = case getSourceFileOrigin file of + FromProject -> Modified{firstOpen=False} + FromDependency -> ReadOnly + + case foiStatus of + ReadOnly -> void $ addFileOfInterest ide file ReadOnly + _ -> setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file foiStatus logWith recorder Debug $ LogModifiedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ - addFileOfInterest ide file OnDisk + let foiStatus = case getSourceFileOrigin file of + FromProject -> OnDisk + FromDependency -> ReadOnly + + case foiStatus of + ReadOnly -> void $ addFileOfInterest ide file ReadOnly + _ -> setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ + addFileOfInterest ide file foiStatus logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index cec445601c..407e9fbfde 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 } } @@ -266,4 +270,3 @@ hsConDeclsBinders cons 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/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 7cd7342446..3018e64dc9 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -258,12 +258,12 @@ atPoint :: IdeOptions -> ShakeExtras -> HieAstResult - -> DocAndTyThingMap - -> HscEnv + -> Maybe DocAndTyThingMap + -> Maybe HscEnv -> Position - -> Util.EnumSet Extension + -> Maybe (Util.EnumSet Extension) -> IO (Maybe (Maybe Range, [T.Text])) -atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos enabledExtensions = +atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) mDkMap mEnv pos mEnabledExtensions = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data @@ -319,11 +319,20 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ let typeSig = case identType dets of Just t -> prettyType (Just n) locationsMap t - Nothing -> case safeTyThingType (Util.member LinearTypes enabledExtensions) =<< lookupNameEnv km n of - Just kind -> prettyTypeFromType (Just n) locationsMap kind - Nothing -> wrapHaskell (printOutputable n) + Nothing -> fromMaybe (wrapHaskell (printOutputable n)) maybeKind + + maybeKind = do + (DKMap _ km _) <- mDkMap + kind <- + safeTyThingType (maybe False (Util.member LinearTypes) mEnabledExtensions) + =<< lookupNameEnv km n + pure $ prettyTypeFromType (Just n) locationsMap kind + definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n)) - docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) + + docs = maybeToList $ do + (DKMap dm _ _ ) <- mDkMap + T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n pure $ T.unlines $ [typeSig] ++ definitionLoc ++ docs where @@ -343,7 +352,9 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ -- the package(with version) this `ModuleName` belongs to. packageNameForImportStatement :: ModuleName -> IO T.Text packageNameForImportStatement mod = do - mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module) + mpkg <- case mEnv of + Just env -> findImportedModule (setNonHomeFCHook env) mod + Nothing -> pure Nothing let moduleName = printOutputable mod case mpkg >>= packageNameWithVersion of Nothing -> pure moduleName @@ -352,12 +363,23 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ -- Return the package name and version of a module. -- For example, given module `Data.List`, it should return something like `base-4.x`. packageNameWithVersion :: Module -> Maybe T.Text - packageNameWithVersion m = do - let pid = moduleUnit m - conf <- lookupUnit env pid - let pkgName = T.pack $ unitPackageNameString conf - version = T.pack $ showVersion (unitPackageVersion conf) - pure $ pkgName <> "-" <> version + packageNameWithVersion m = + let pid = moduleUnit m in + case mEnv of + -- If we have an HscEnv (because this is a project file), + -- we can get the package name from that. + Just env -> do + conf <- lookupUnit env pid + let pkgName = T.pack $ unitPackageNameString conf + version = T.pack $ showVersion (unitPackageVersion conf) + pure $ pkgName <> "-" <> version + -- If we don't have an HscEnv (because this is a dependency file) + -- then we get a similar format for the package name + -- from the UnitId + Nothing -> + let uid = toUnitId pid + pkgStr = takeWhile (/= ':') $ show uid + in Just $ T.pack pkgStr -- Type info for the current node, it may contain several symbols -- for one range, like wildcard 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/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index e288e7b99b..4e0c076cfe 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -47,8 +47,9 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: HscEnv -> IO HscEnvEq -newHscEnvEq hscEnv' = do +newHscEnvEq :: (HscEnv -> IO ()) -> HscEnv -> IO HscEnvEq +newHscEnvEq indexDependencies hscEnv' = do + indexDependencies hscEnv' mod_cache <- newIORef emptyInstalledModuleEnv -- This finder cache is for things which are outside of things which are tracked diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 569225e999..be06fdb03d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2043,6 +2043,7 @@ test-suite ghcide-tests , lsp-types , mtl , network-uri + , process , QuickCheck , random , regex-tdfa ^>=1.3.1 @@ -2078,6 +2079,7 @@ test-suite ghcide-tests CPPTests CradleTests DependentFileTest + Dependency DiagnosticTests ExceptionTests FindDefinitionAndHoverTests 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..b83bafa697 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -39,6 +39,11 @@ module Ide.Types , PluginNotificationHandler(..), mkPluginNotificationHandler , PluginNotificationHandlers(..) , PluginRequestMethod(..) +, InputClass(..), RuleInput, RuleResult, Rules, Key, alwaysRerun +, SourceFileOrigin(..) +, dependenciesDirectory +, hlsDirectory +, getSourceFileOrigin , getProcessID, getPid , getVirtualFileFromVFS , installSigUsr1Handler @@ -67,7 +72,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) @@ -78,7 +84,7 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Kind (Type) -import Data.List.Extra (find, sortOn) +import Data.List.Extra (find, isInfixOf, sortOn) import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe @@ -103,6 +109,7 @@ import Numeric.Natural import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) import Prettyprinter as PP +import System.FilePath (splitDirectories, takeExtension) import System.IO.Unsafe import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) @@ -352,7 +359,26 @@ describePlugin p = pdesc = pluginDescription p in pretty pid <> ":" <> nest 4 (PP.line <> pretty pdesc) +data SourceFileOrigin = FromProject | FromDependency deriving Eq +hlsDirectory :: FilePath +hlsDirectory = ".hls" + +dependenciesDirectory :: FilePath +dependenciesDirectory = "dependencies" + +-- | Dependency files are written to the .hls/dependencies directory +-- under the project root. +-- If a file is not in this directory, we assume that it is a +-- project file. +getSourceFileOrigin :: NormalizedFilePath -> SourceFileOrigin +getSourceFileOrigin f = + case [hlsDirectory, dependenciesDirectory] `isInfixOf` splitDirectories file of + True -> FromDependency + False -> FromProject + where + file :: FilePath + file = fromNormalizedFilePath f -- | An existential wrapper of 'Properties' data CustomConfig = forall r. CustomConfig (Properties r) @@ -442,7 +468,16 @@ pluginSupportsFileType (VFS vfs) msgParams pluginDesc = languageKindM = case mVFE of Just x -> virtualFileEntryLanguageKind x - _ -> Nothing + _ -> dependencyLanguageKind uri + +dependencyLanguageKind :: NormalizedUri -> Maybe J.LanguageKind +dependencyLanguageKind uri = do + fp <- uriToFilePath $ fromNormalizedUri uri + let pathParts = splitDirectories fp + if [hlsDirectory, dependenciesDirectory] `isInfixOf` pathParts + && takeExtension fp `elem` [".hs", ".lhs", ".hs-boot"] + then Just J.LanguageKind_Haskell + else Nothing -- | Methods that can be handled by plugins. -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method 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 2c47ae5446..9ef5917ffe 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) @@ -428,6 +429,7 @@ instance Show CollectRecordsResult where show _ = "" type instance RuleResult CollectRecords = CollectRecordsResult +type instance RuleInput CollectRecords = ProjectHaskellFiles data CollectNames = CollectNames deriving (Eq, Show, Generic) @@ -444,6 +446,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..db43b01eaa 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 $ Map.filter (/= ReadOnly) 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 2f4faf71b8..cb0a2edd9e 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 @@ -45,6 +46,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) @@ -52,6 +54,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) @@ -59,6 +62,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 @@ -90,14 +94,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 @@ -105,13 +109,16 @@ 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" (listToMaybe $ Rope.lines $ fst - (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents)) - pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line +getNote nfp state (Position l c) = + case getSourceFileOrigin nfp of + FromDependency -> pure Nothing + FromProject -> 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 +167,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 +291,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 = @@ -323,62 +330,65 @@ autocomplete state _ params = do pos = params ^. L.position nuri = toNormalizedUri uri - contents <- - liftIO $ - runAction "Notes.GetUriContents" state $ - getUriContents nuri - - fmap InL $ - case contents of - Nothing -> pure [] - - Just rope -> do - let linePrefix = T.toLower $ T.stripEnd $ getLinePrefix rope pos - - -- Suggest NOTE DECLARATION snippit if "note" prefix detected - if T.strip linePrefix == "note" - then - pure [CompletionItem "Note" Nothing (Just CompletionItemKind_Keyword) Nothing - (Just "Note Declaration") Nothing Nothing Nothing Nothing - Nothing (Just noteSnippet) (Just InsertTextFormat_Snippet) Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - ] - - -- Suggest list of all NOTE DECLARATION if "note [" infix detected - else if "note[" `T.isInfixOf` linePrefix || "note [" `T.isInfixOf` linePrefix - then - case uriToNormalizedFilePath nuri of - Nothing -> pure [] - - Just nfp -> do - let typed = - case T.breakOnEnd "[" linePrefix of - (_, "") -> "" - (_, rest)-> T.strip rest - - notesMap <- - runActionE "notes.completion.notes" state $ - useE MkGetNotes nfp - - let allNotes = HM.keys notesMap - matches = - filter - (\n -> T.toLower typed `T.isPrefixOf` T.toLower n) - allNotes - - finalNotes = - if null matches then allNotes else matches - pure $ - map - (\n -> - CompletionItem n Nothing (Just CompletionItemKind_Reference) Nothing (Just "Note reference") - Nothing Nothing (Just True) (Just "0") (Just n) - Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing - ) - finalNotes - else - pure [] + case uriToNormalizedFilePath nuri of + Just nfp | getSourceFileOrigin nfp == FromDependency -> pure $ InL [] + _ -> do + contents <- + liftIO $ + runAction "Notes.GetUriContents" state $ + getUriContents nuri + + fmap InL $ + case contents of + Nothing -> pure [] + + Just rope -> do + let linePrefix = T.toLower $ T.stripEnd $ getLinePrefix rope pos + + -- Suggest NOTE DECLARATION snippit if "note" prefix detected + if T.strip linePrefix == "note" + then + pure [CompletionItem "Note" Nothing (Just CompletionItemKind_Keyword) Nothing + (Just "Note Declaration") Nothing Nothing Nothing Nothing + Nothing (Just noteSnippet) (Just InsertTextFormat_Snippet) Nothing + Nothing Nothing Nothing Nothing Nothing Nothing + ] + + -- Suggest list of all NOTE DECLARATION if "note [" infix detected + else if "note[" `T.isInfixOf` linePrefix || "note [" `T.isInfixOf` linePrefix + then + case uriToNormalizedFilePath nuri of + Nothing -> pure [] + + Just nfp -> do + let typed = + case T.breakOnEnd "[" linePrefix of + (_, "") -> "" + (_, rest)-> T.strip rest + + notesMap <- + runActionE "notes.completion.notes" state $ + useE MkGetNotes nfp + + let allNotes = HM.keys notesMap + matches = + filter + (\n -> T.toLower typed `T.isPrefixOf` T.toLower n) + allNotes + + finalNotes = + if null matches then allNotes else matches + pure $ + map + (\n -> + CompletionItem n Nothing (Just CompletionItemKind_Reference) Nothing (Just "Note reference") + Nothing Nothing (Just True) (Just "0") (Just n) + Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing + ) + finalNotes + else + pure [] noteSnippet :: Text noteSnippet = 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 112dc3a6ca..bf0a04cf40 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -67,10 +67,12 @@ import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, parseType) import Development.IDE.GHC.Compat.ExactPrint -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, @@ -150,6 +152,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 6e57a26a0e..557d75563e 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -43,6 +43,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 @@ -139,8 +141,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 @@ -236,10 +239,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..707a574a5e 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 $ HM.filter (/= ReadOnly) 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