diff --git a/docs/contributing/plugin-tutorial.md b/docs/contributing/plugin-tutorial.md index ac8febef29..7cbbe26443 100644 --- a/docs/contributing/plugin-tutorial.md +++ b/docs/contributing/plugin-tutorial.md @@ -44,6 +44,7 @@ import Ide.Logger import Ide.Plugin.Error import Development.IDE.Core.RuleTypes +import Development.IDE.Core.RuleInput import Development.IDE.Core.Service hiding (Log) import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat @@ -290,13 +291,12 @@ provider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens provider state -- ghcide state, used to retrieve typechecking artifacts pId -- Plugin ID CodeLensParams{_textDocument = TextDocumentIdentifier{_uri}} = do - -- VSCode uses URIs instead of file paths - -- haskell-lsp provides conversion functions - nfp <- getNormalizedFilePathE _uri + -- Classify the URI as a Haskell source file in the project + input <- classifyAsProjectHaskell _uri -- Get the typechecking artifacts from the module - tmr <- runActionE "importLens" state $ useE TypeCheck nfp + tmr <- runActionE "importLens" state $ useE TypeCheck input -- We also need a GHC session with all the dependencies - hsc <- runActionE "importLens" state $ useE GhcSessionDeps nfp + hsc <- runActionE "importLens" state $ useE GhcSessionDeps input -- Use the GHC API to extract the "minimal" imports (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr 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 2ab0631ce7..678b9b619b 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 EpsPollutionTests import ExceptionTests @@ -97,6 +98,7 @@ main = do , CradleTests.tests , DependentFileTest.tests , EpsPollutionTests.tests + , Dependency.tests , NonLspCommandLine.tests , IfaceTests.tests , BootTests.tests diff --git a/ghcide-test/exe/Progress.hs b/ghcide-test/exe/Progress.hs index 08ad03c78b..fedfcb3ac5 100644 --- a/ghcide-test/exe/Progress.hs +++ b/ghcide-test/exe/Progress.hs @@ -4,8 +4,8 @@ module Progress (tests) where import Control.Concurrent.STM import Data.Foldable (for_) import qualified Data.HashMap.Strict as Map -import Development.IDE (NormalizedFilePath) import Development.IDE.Core.ProgressReporting +import Development.IDE.Core.RuleInput import qualified "list-t" ListT import qualified StmContainers.Map as STM import Test.Tasty @@ -18,7 +18,7 @@ tests = testGroup "Progress" data InProgressModel = InProgressModel { done, todo :: Int, - current :: Map.HashMap NormalizedFilePath Int + current :: Map.HashMap SomeFileInput Int } reportProgressTests :: TestTree @@ -35,7 +35,7 @@ reportProgressTests = testGroup "recordProgress" decrease = recordProgressModel "A" succ increase done = recordProgressModel "A" pred decrease recordProgressModel key change state = - model state $ \st -> recordProgress st key change + model state $ \st -> recordProgress st (toSomeFileInput key) change model stateModelIO k = do state <- fromModel =<< stateModelIO _ <- k state diff --git a/ghcide-test/exe/UnitTests.hs b/ghcide-test/exe/UnitTests.hs index 09d6d7c1ba..05159b450b 100644 --- a/ghcide-test/exe/UnitTests.hs +++ b/ghcide-test/exe/UnitTests.hs @@ -13,6 +13,7 @@ import Data.List.Extra import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE.Core.FileStore (getModTime) +import Development.IDE.Core.RuleInput import Development.IDE.Import.DependencyInformation (DependencyInformation (..), FilePathId (..), PathIdMap (..), @@ -116,11 +117,13 @@ tests = do -- not just the immediate reverse-dep {1}. let path :: Int -> NormalizedFilePath path i = toNormalizedFilePath' ("/M" ++ show i ++ ".hs") + input :: Int -> ProjectHaskellInput + input i = ProjectHaskellInput (path i) loc :: Int -> ArtifactsLocation - loc i = ArtifactsLocation (path i) Nothing True Nothing + loc i = ArtifactsLocation (input i) Nothing True Nothing pathIdMap = PathIdMap { idToPathMap = IntMap.fromList [(i, loc i) | i <- [0..3]] - , pathToIdMap = HMS.fromList [(path i, FilePathId i) | i <- [0..3]] + , pathToIdMap = HMS.fromList [(input i, FilePathId i) | i <- [0..3]] , nextFreshId = 4 } revDeps = IntMap.fromList @@ -141,8 +144,8 @@ tests = do , depTransReverseDepsFingerprints = IntMap.empty , depImmediateReverseDepsFingerprints = IntMap.empty } - (sort <$> transitiveReverseDependencies (path 0) depInfo) - @?= Just [path 1, path 2, path 3] + (sort <$> transitiveReverseDependencies (input 0) depInfo) + @?= Just [input 1, input 2, input 3] , Progress.tests , FuzzySearch.tests ] diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index bad94546e3..6a01b39145 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -129,8 +129,10 @@ 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.LookupMod Development.IDE.Core.OfInterest @@ -138,6 +140,7 @@ library Development.IDE.Core.PositionMapping Development.IDE.Core.Preprocessor Development.IDE.Core.ProgressReporting + Development.IDE.Core.RuleInput Development.IDE.Core.Rules Development.IDE.Core.RuleTypes Development.IDE.Core.Service diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 34b968a08b..9484ee7165 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -43,6 +43,7 @@ import Data.Maybe import Data.Proxy import qualified Data.Text as T import Data.Version +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) @@ -109,11 +110,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) @@ -122,7 +124,7 @@ data Log | LogHieDbRetriesExhausted !Int !Int !Int !SomeException | LogHieDbWriterThreadSQLiteError !SQLError | LogHieDbWriterThreadException !SomeException - | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) + | LogKnownFilesUpdated !(HashMap Target (HashSet ProjectHaskellInput)) | LogCradlePath !FilePath | LogCradleNotFound !FilePath | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) @@ -137,6 +139,7 @@ data Log | LogLookupSessionCache !FilePath | LogTime !String | LogSessionGhc Ghc.Log + | LogHieFile HieFile.HieFileLog deriving instance Show Log instance Pretty Log where @@ -193,7 +196,7 @@ instance Pretty Log where nest 2 $ vcat [ "Known files updated:" - , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap + , viaShow $ (HM.map . Set.map) (fromNormalizedFilePath . inputFilePath) targetToPathsMap ] LogCradlePath path -> "Cradle path:" <+> pretty path @@ -208,6 +211,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." @@ -415,11 +419,11 @@ getHieDbLocIn base dir = do -- This approach ensures efficient batch loading while isolating problematic files for individual handling. -- SBL3 -handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap ProjectHaskellInput (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets = do pendings <- getPendingFiles sessionState -- this_flags_map might contains files not in pendingFiles, take the intersection - let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + let newLoaded = pendings `Set.intersection` Set.fromList (map (fromNormalizedFilePath . inputFilePath) (HM.keys this_flags_map)) atomically $ do STM.insert this_flags_map hieYaml (fileToFlags sessionState) insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets @@ -530,17 +534,17 @@ resetFileMaps state = do STM.reset (fileToFlags state) -- | Insert or update file flags for a specific hieYaml and normalized file path -insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM () +insertFileFlags :: SessionState -> Maybe FilePath -> ProjectHaskellInput -> (IdeResult HscEnvEq, DependencyInfo) -> STM () insertFileFlags state hieYaml ncfp flags = STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state) -- | Insert a file mapping from normalized path to hieYaml location -insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMapping :: SessionState -> Maybe FilePath -> ProjectHaskellInput -> STM () insertFileMapping state hieYaml ncfp = STM.insert hieYaml ncfp (filesMap state) -- | Same as 'insertFileMapping', but never overwrites an existing value. -insertFileMappingIfMissing :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMappingIfMissing :: SessionState -> Maybe FilePath -> ProjectHaskellInput -> STM () insertFileMappingIfMissing state hieYaml ncfp = STM.focus (Focus.alter (<|> Just hieYaml)) ncfp (filesMap state) @@ -555,7 +559,7 @@ addToPending state file = S.insert file (pendingFiles state) -- | Insert multiple file mappings at once -insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () +insertAllFileMappings :: SessionState -> [(Maybe FilePath, ProjectHaskellInput)] -> STM () insertAllFileMappings state mappings = mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings @@ -576,7 +580,7 @@ handleSingleFileProcessingError' state hieYaml file e = do handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM () handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles - let ncfp = toNormalizedFilePath' file + let ncfp = ProjectHaskellInput (toNormalizedFilePath' file) let flags = ((diags, Nothing), dep) handleSingleLoadFailure state file atomically $ do @@ -606,7 +610,7 @@ getExtraFilesToLoad state hieYaml cfp = do filterM ownedByThisCradle (Set.toList candidates) where ownedByThisCradle file = do - owner <- atomically $ STM.lookup (toNormalizedFilePath' file) (filesMap state) + owner <- atomically $ STM.lookup (ProjectHaskellInput (toNormalizedFilePath' file)) (filesMap state) pure $ owner == Just hieYaml -- | We allow users to specify a loading strategy. @@ -704,6 +708,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do , sessionClientConfig = clientConfig , sessionSharedNameCache = ideNc , sessionLoadingOptions = newSessionLoadingOptions + , sessionShakeExtras = extras } writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) @@ -724,7 +729,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do -- and wait until the options are available lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) lookupOrWaitCache recorder sessionState cradleLoc absFile = do - let ncfp = toNormalizedFilePath' absFile + let ncfp = ProjectHaskellInput (toNormalizedFilePath' absFile) cacheResult <- maybeM (return Nothing) (guardedA (checkDependencyInfo . snd)) @@ -750,7 +755,7 @@ lookupOrWaitCache recorder sessionState cradleLoc absFile = do addToPending sessionState absFile lookupOrWaitCache recorder sessionState cradleLoc absFile -checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) +checkInCache :: SessionState -> ProjectHaskellInput -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) checkInCache sessionState ncfp = runMaybeT $ do cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) @@ -772,6 +777,7 @@ data SessionEnv = SessionEnv , sessionClientConfig :: Config , sessionSharedNameCache :: NameCache , sessionLoadingOptions :: SessionLoadingOptions + , sessionShakeExtras :: ShakeExtras } type SessionM = ReaderT SessionEnv IO @@ -803,7 +809,7 @@ getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do findHieYamlForTarget :: FilesMap -> FilePath -> SessionM (Maybe FilePath) findHieYamlForTarget filesMapping file = do - let ncfp = toNormalizedFilePath' file + let ncfp = ProjectHaskellInput (toNormalizedFilePath' file) cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp filesMapping)) sessionLoadingOptions <- asks sessionLoadingOptions hieYaml <- liftIO $ findCradle sessionLoadingOptions file @@ -825,7 +831,7 @@ sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState) - case v >>= HM.lookup (toNormalizedFilePath' file) of + case v >>= HM.lookup (ProjectHaskellInput (toNormalizedFilePath' file)) of Just (_opts, old_di) -> do deps_ok <- liftIO $ checkDependencyInfo old_di if not deps_ok @@ -853,7 +859,7 @@ consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = d (cradle, eopts) <- loadCradleWithNotifications recorder sessionState hieYaml cfp logWith recorder Debug $ LogSessionLoadingResult eopts - let ncfp = toNormalizedFilePath' cfp + let ncfp = ProjectHaskellInput (toNormalizedFilePath' cfp) case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -904,7 +910,7 @@ session :: SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> - (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> + (Maybe FilePath, ProjectHaskellInput, ComponentOptions, FilePath) -> SessionM () session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do let initEmptyHscEnv = emptyHscEnvM libDir @@ -916,7 +922,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. @@ -933,10 +941,11 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l keys1 <- extendKnownTargets recorder knownTargetsVar all_targets -- Typecheck all files in the project on startup unless (null new_components_info || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath . inputFilePath) (concatMap targetLocations all_targets) void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + let files = map ( SomeFileHaskellInput . SomeProjectHaskellInput) cfps' + mmt <- uses GetModificationTime files + let cs_exist = map fst (filter (isJust . snd) (zip cfps' mmt)) modIfaces <- uses GetModIface cs_exist -- update exports map shakeExtras <- getShakeExtras @@ -945,7 +954,7 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l return [keys1, keys2] -- | Create a new HscEnv from a hieYaml root and a set of options -packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) +packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, ProjectHaskellInput, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions) haddockparse <- asks (optHaddockParse . sessionIdeOptions) @@ -975,7 +984,7 @@ directories and never the target list, and a module missing from the targets is a warning (-Wmissing-home-modules), not an error. A file below no import path is still an error, we have no options to compile it with. -} -addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> ProjectHaskellInput -> IO ([TargetDetails], HashMap ProjectHaskellInput (IdeResult HscEnvEq, DependencyInfo)) addErrorTargetIfUnknown all_target_details hieYaml cfp = do let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') all_targets' = concat all_target_details @@ -987,11 +996,11 @@ addErrorTargetIfUnknown all_target_details hieYaml cfp = do this_target_details = TargetDetails (TargetFile cfp) this_env this_dep_info [cfp] this_flags = (this_env, this_dep_info) -- See Note [Modules the build tool has not been told about] - this_env = case owningComponent all_targets' cfp of - Just env -> (missingHomeModuleWarning env cfp, Just env) + this_env = case owningComponent all_targets' (inputFilePath cfp) of + Just env -> (missingHomeModuleWarning env (inputFilePath cfp), Just env) Nothing -> ([noTargetError], Nothing) noTargetError = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (inputFilePath cfp) (T.unlines [ "No cradle target found. Is this file listed in the targets of your cradle?" , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" @@ -1061,11 +1070,11 @@ extendKnownTargets recorder knownTargetsVar newTargets = do -- If we don't generate a TargetFile for each potential location, we will only have -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' -- and also not find 'TargetModule Foo'. - fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + fs <- filterM (IO.doesFileExist . fromNormalizedFilePath . inputFilePath) targetLocations + pure $ map (\fp -> (TargetFile fp, Set.singleton (inputFilePath fp))) (nubOrd (f:fs)) TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return [(targetTarget, Set.fromList found)] + found <- filterM (IO.doesFileExist . fromNormalizedFilePath . inputFilePath) targetLocations + return [(targetTarget, Set.fromList (map inputFilePath found))] hasUpdate <- atomically $ do known <- readTVar knownTargetsVar let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) @@ -1073,7 +1082,7 @@ extendKnownTargets recorder knownTargetsVar newTargets = do writeTVar knownTargetsVar known' pure hasUpdate for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + logWith recorder Debug $ LogKnownFilesUpdated (HM.map (Set.fromList . mapMaybe toProjectHaskellInput . Set.toList) (targetMap x)) return $ toNoFileKey GetKnownTargets @@ -1160,7 +1169,7 @@ emptyHscEnvM libDir = do nc <- asks sessionSharedNameCache liftIO $ Ghc.emptyHscEnv nc libDir -toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] +toFlagsMap :: TargetDetails -> [(ProjectHaskellInput, (IdeResult HscEnvEq, DependencyInfo))] toFlagsMap TargetDetails{..} = [ (l, (targetEnv, targetDepends)) | l <- targetLocations] @@ -1172,10 +1181,10 @@ type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] -- | Maps a @hie.yaml@ location to all its Target Filepaths and options. -- Reverse of 'FilesMap'. -type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap ProjectHaskellInput (IdeResult HscEnvEq, DependencyInfo)) -- | Maps a Filepath to its respective @hie.yaml@ location. -- It aims to be the reverse of 'FlagsMap'. -type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) +type FilesMap = STM.Map ProjectHaskellInput (Maybe FilePath) -- | Memoize an IO function, with the characteristics: -- diff --git a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs index 0b861d0a0a..9149be021d 100644 --- a/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs +++ b/ghcide/session-loader/Development/IDE/Session/Diagnostics.hs @@ -9,6 +9,7 @@ import Data.List import Data.List.Extra (split) import Data.Maybe import qualified Data.Text as T +import Development.IDE.Core.RuleInput import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics @@ -40,8 +41,8 @@ data UnknownModuleDetails = the cradle error occurred (of the file we attempted to load). Depicts the cradle error in a user-friendly way. -} -renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic -renderCradleError cradleError cradle nfp = +renderCradleError :: CradleError -> Cradle a -> ProjectHaskellInput -> FileDiagnostic +renderCradleError cradleError cradle input = let noDetails = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing in @@ -54,6 +55,7 @@ renderCradleError cradleError cradle nfp = } else noDetails where + nfp = inputFilePath input ms = cradleErrorStderr cradleError absDeps = fmap (cradleRootDir cradle ) (cradleErrorDependencies cradleError) diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index d5b1146726..cb2a66788e 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -15,6 +15,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake hiding (Log, knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat @@ -58,7 +59,6 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State - #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) #endif @@ -101,7 +101,7 @@ data RawComponentInfo = RawComponentInfo -- | All targets of this components. , rawComponentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath + , rawComponentFP :: ProjectHaskellInput -- | Component Options used to load the component. , rawComponentCOptions :: ComponentOptions -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file @@ -120,7 +120,7 @@ data ComponentInfo = ComponentInfo -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath + , componentFP :: ProjectHaskellInput -- | Component Options used to load the component. , componentCOptions :: ComponentOptions -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file @@ -144,13 +144,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 + -> ProjectHaskellInput -- ^ 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. @@ -172,7 +173,7 @@ newComponentCache recorder exts cfp hsc_env old_cis new_cis = do #endif closure_err_to_multi_err err = ideErrorWithSource - (Just "cradle") (Just DiagnosticSeverity_Warning) cfp + (Just "cradle") (Just DiagnosticSeverity_Warning) (inputFilePath cfp) (T.pack (Compat.printWithoutUniques (singleMessage err))) (Just (fmap GhcDriverMessage err)) multi_errs = map closure_err_to_multi_err closure_errs @@ -200,7 +201,7 @@ newComponentCache recorder exts cfp hsc_env old_cis new_cis = do -- A session representative file of this load. See Note [Session representatives] -- Not cfp which may be an error target. - let repr = fromMaybe cfp $ listToMaybe + let repr = fromMaybe (inputFilePath cfp) $ listToMaybe [ loc | ci <- Map.elems cis , t <- componentTargets ci @@ -214,7 +215,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 repr thisEnv + henv <- newHscEnvEq repr indexDependencies thisEnv let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) @@ -228,7 +229,7 @@ newComponentCache recorder exts cfp hsc_env old_cis new_cis = do -- | Throws if package flags are unsatisfiable setOptions :: GhcMonad m => OptHaddockParse - -> NormalizedFilePath + -> ProjectHaskellInput -> ComponentOptions -> DynFlags -> FilePath -- ^ root dir, see Note [Root Directory] @@ -256,7 +257,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = -- -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file - let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath (inputFilePath cfp)) let special_target = Compat.mkSimpleTarget df abs_fp pure $ HomeUnitConfig df (special_target : targets) mHash :| [] where @@ -315,7 +316,7 @@ addComponentInfo :: (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) -> DependencyInfo -> NonEmpty HomeUnitConfig-> - (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + (Maybe FilePath, ProjectHaskellInput, ComponentOptions) -> Map.Map (Maybe FilePath) [RawComponentInfo] -> m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do @@ -508,7 +509,7 @@ data TargetDetails = TargetDetails targetTarget :: !Target, targetEnv :: !(IdeResult HscEnvEq), targetDepends :: !DependencyInfo, - targetLocations :: ![NormalizedFilePath] + targetLocations :: ![ProjectHaskellInput] } -- | Candidate locations of a target, in search order. @@ -537,12 +538,22 @@ fromTargetId :: [FilePath] -- ^ import paths -> IdeResult HscEnvEq -> DependencyInfo -> IO [TargetDetails] -fromTargetId is exts tid env dep = - return [TargetDetails target env dep (targetIdLocations is exts tid)] - where - target = case tid of - GHC.TargetModule modName -> TargetModule modName - GHC.TargetFile f _ -> TargetFile (toNormalizedFilePath' f) +-- For a target module we consider all the import paths +fromTargetId is exts (GHC.TargetModule modName) env dep = do + let fps = [i moduleNameSlashes modName -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] + let locs = mapMaybe (toProjectHaskellInput . toNormalizedFilePath') fps + return [TargetDetails (TargetModule modName) env dep locs] +-- For a 'TargetFile' we consider all the possible module names +fromTargetId _ _ (GHC.TargetFile f _) env deps = do + let nf = ProjectHaskellInput (toNormalizedFilePath' f) + let other + | isSuffixOf "-boot" f = ProjectHaskellInput (toNormalizedFilePath' (L.dropEnd 5 (fromNormalizedFilePath (inputFilePath nf)))) + | otherwise = ProjectHaskellInput (toNormalizedFilePath' (fromNormalizedFilePath (inputFilePath nf) ++ "-boot")) + return [TargetDetails (TargetFile nf) env deps [nf, other]] -- ---------------------------------------------------------------------------- -- Backwards compatibility diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 7b16f1fa4f..2deaa40217 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -21,6 +21,7 @@ import Development.IDE.Core.LookupMod (lookupMod) import Development.IDE.Core.OfInterest import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake @@ -45,29 +46,38 @@ import Language.LSP.Protocol.Types (DocumentHighlight (..), -- block waiting for the rule to be properly computed. -- | Try to get hover text for the name under point. -getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) +getAtPoint :: SomeHaskellInput -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) getAtPoint file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst 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 file of + SomeNonProjectHaskellInput _ -> pure (Nothing, Nothing, Nothing) + SomeProjectHaskellInput projectFile -> do + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession projectFile + modSummary <- fst <$> useWithStaleFastMT GetModSummary projectFile + dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap projectFile) + 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. toCurrentLocation :: PositionMapping - -> NormalizedFilePath + -> SomeFileInput -> Location -> IdeAction (Maybe Location) toCurrentLocation mapping file (Location uri range) = @@ -75,7 +85,7 @@ toCurrentLocation mapping file (Location uri range) = -- file than the one we are calling gotoDefinition from. -- So we check that the location file matches the file -- we are in. - if nUri == normalizedFilePathToUri file + if nUri == normalizedFilePathToUri (inputFilePath file) -- The Location matches the file, so use the PositionMapping -- we have. then pure $ Location uri <$> toCurrentRange mapping range @@ -84,28 +94,34 @@ toCurrentLocation mapping file (Location uri range) = else do otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri - useWithStaleFastMT GetHieAst otherLocationFile + otherHaskellFile <- MaybeT $ pure $ toSomeHaskellInput otherLocationFile + useWithStaleFastMT GetHieAst otherHaskellFile pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) where nUri :: NormalizedUri nUri = toNormalizedUri uri -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) +getDefinition :: SomeHaskellInput -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide + (hf, mapping) <- useWithStaleFastMT GetHieAst file - (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file + + ImportMap imports <- case file of + SomeNonProjectHaskellInput _ -> pure $ ImportMap mempty + SomeProjectHaskellInput pFile -> fst <$> useWithStaleFastMT GetImportMap pFile + !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts (fmap SomeProjectHaskellInput imports) hf pos' mapMaybeM (\(location, identifier) -> do - fixedLocation <- MaybeT $ toCurrentLocation mapping file location + fixedLocation <- MaybeT $ toCurrentLocation mapping (SomeFileHaskellInput file) location pure $ Just (fixedLocation, identifier) ) locationsWithIdentifier -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) +getTypeDefinition :: SomeHaskellInput -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide @@ -113,20 +129,20 @@ getTypeDefinition file pos = runMaybeT $ do !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' mapMaybeM (\(location, identifier) -> do - fixedLocation <- MaybeT $ toCurrentLocation mapping file location + fixedLocation <- MaybeT $ toCurrentLocation mapping (SomeFileHaskellInput file) location pure $ Just (fixedLocation, identifier) ) locationsWithIdentifier -getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getImplementationDefinition :: SomeHaskellInput -> Position -> IdeAction (Maybe [Location]) getImplementationDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos' - traverse (MaybeT . toCurrentLocation mapping file) locs + traverse (MaybeT . toCurrentLocation mapping (SomeFileHaskellInput file)) locs -highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) +highlightAtPoint :: SomeHaskellInput -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) @@ -134,7 +150,7 @@ highlightAtPoint file pos = runMaybeT $ do mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' -- Refs are not an IDE action, so it is OK to be slow and (more) accurate -refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint :: SomeHaskellInput -> Position -> Action [Location] refsAtPoint file pos = do ShakeExtras{withHieDb} <- getShakeExtras fs <- HM.keys <$> getFilesOfInterestUntracked diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 11c678984e..1f7a4cc45e 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -76,6 +76,7 @@ import Debug.Trace import Development.IDE.Core.FileStore (resetInterfaceStore) import Development.IDE.Core.Preprocessor import Development.IDE.Core.ProgressReporting (progressUpdate) +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.Core.WorkerThread (writeTaskQueue) @@ -207,7 +208,7 @@ computePackageDeps env pkg = do data TypecheckHelpers = TypecheckHelpers - { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files + { getLinkables :: [ProjectHaskellInput] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files , getModuleGraph :: IO DependencyInformation } @@ -872,9 +873,9 @@ tagDiag (w@(Just (WarningWithFlag warning)), fd) -- other diagnostics are left unaffected tagDiag t = t -addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags -addRelativeImport fp modu dflags = dflags - {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} +addRelativeImport :: ProjectHaskellInput -> ModuleName -> DynFlags -> DynFlags +addRelativeImport input modu dflags = dflags + {importPaths = nubOrd (maybeToList (moduleImportPath (inputFilePath input) modu) ++ importPaths dflags)} -- | Also resets the interface store atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a @@ -882,7 +883,7 @@ atomicFileWrite se targetPath write = do let dir = takeDirectory targetPath createDirectoryIfMissing True dir (tempFilePath, cleanUp) <- newTempFileWithin dir - (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toSomeFileInput (toNormalizedFilePath' targetPath))) >> pure x) `onException` cleanUp generateHieAsts :: HscEnv -> TcModuleResult @@ -961,22 +962,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 @@ -984,10 +985,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 @@ -996,7 +995,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) $ @@ -1004,11 +1003,13 @@ 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 - :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] + :: HscEnv -> ShakeExtras -> ModSummary -> SomeHaskellInput -> [GHC.AvailInfo] #if MIN_VERSION_ghc(9,11,0) -> (HieASTs Type, NameEntityInfo) #else @@ -1021,7 +1022,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 $ inputFilePath srcPath) hash hf where dflags = hsc_dflags hscEnv mod_location = ms_location mod_summary @@ -1105,7 +1106,7 @@ mergeEnvs env mg dep_info ms extraMods envs = do then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im) Just fs -> let ml = fromJust $ do - id <- lookupPathToId (depPathIdMap dep_info) fs + id <- pathToId (depPathIdMap dep_info) fs artifactModLocation (idToModLocation (depPathIdMap dep_info) id) #if MIN_VERSION_ghc(9,13,0) in pure $ Just $ InstalledFound ml @@ -1132,8 +1133,8 @@ mergeEnvs env mg dep_info ms extraMods envs = do then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of Nothing -> pure $ Just $ InstalledNotFound [] (Just $ moduleUnit im) Just fs -> let ml = fromJust $ do - id <- lookupPathToId (depPathIdMap dep_info) fs - artifactModLocation (idToModLocation (depPathIdMap dep_info) id) + id <- pathToId (depPathIdMap dep_info) fs + artifactModLocation (idToModLocation (depPathIdMap dep_info) id) in pure $ Just $ InstalledFound ml im else lookupFinderCache (hsc_FC env) gwib } @@ -1537,8 +1538,8 @@ data RecompilationInfo m = RecompilationInfo { source_version :: FileVersion , old_value :: Maybe (HiFileResult, FileVersion) - , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) - , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString] + , get_file_version :: SomeFileInput -> m (Maybe FileVersion) + , get_linkable_hashes :: [ProjectHaskellInput] -> m [BS.ByteString] , get_module_graph :: m DependencyInformation , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface } @@ -1652,7 +1653,7 @@ parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH] -checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies :: MonadIO m => ([ProjectHaskellInput] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps = do graph <- get_module_graph let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph diff --git a/ghcide/src/Development/IDE/Core/Dependencies.hs b/ghcide/src/Development/IDE/Core/Dependencies.hs new file mode 100644 index 0000000000..625b83b2f8 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Dependencies.hs @@ -0,0 +1,208 @@ +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) +import qualified GHC.Unit.Info as GHC +import GHC.Unit.State (listUnitInfo) +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 "newHscEnvEqWithImportPaths" 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 + $ matchingUnitInfos dependencyIds unitInfos + where + unitInfos :: [GHC.UnitInfo] + unitInfos = listUnitInfo $ GHC.unitState hscEnv + dependencyIds :: Set GHC.UnitId + dependencyIds = + calculateTransitiveDependencies unitInfos 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.UnitInfo] -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId +calculateTransitiveDependencies unitInfos 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 unitInfos 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) + $ matchingUnitInfos newDependencies unitInfos + +matchingUnitInfos :: Set GHC.UnitId -> [GHC.UnitInfo] -> [GHC.UnitInfo] +matchingUnitInfos unitIds = + filter $ \unitInfo -> GHC.unitId unitInfo `Set.member` unitIds + +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 0538e57bd8..e4180d7fdf 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -23,6 +23,7 @@ import Data.Maybe import Development.IDE.Core.FileStore hiding (Log, LogShake) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake @@ -84,7 +85,7 @@ fast path by a check that the path also matches our watching patterns. -- | A map for tracking the file existence. -- If a path maps to 'True' then it exists; if it maps to 'False' then it doesn't exist'; and -- if it's not in the map then we don't know. -type FileExistsMap = STM.Map NormalizedFilePath Bool +type FileExistsMap = STM.Map SomeFileInput Bool -- | A wrapper around a mutable 'FileExistsState' newtype FileExistsMapVar = FileExistsMapVar FileExistsMap @@ -108,7 +109,7 @@ getFileExistsMapUntracked = do return v -- | Modify the global store of file exists and return the keys that need to be marked as dirty -modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] +modifyFileExists :: IdeState -> [(SomeFileInput, FileChangeType)] -> IO [Key] modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update @@ -134,7 +135,7 @@ fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- -- | Returns True if the file exists -getFileExists :: NormalizedFilePath -> Action Bool +getFileExists :: SomeFileInput -> Action Bool getFileExists fp = use_ GetFileExists fp {- Note [Which files should we watch?] @@ -186,7 +187,7 @@ fileExistsRules recorder lspEnv = do isWatched = if supportsWatchedFiles then \f -> do isWF <- isWorkspaceFile f - return $ isWF && fpMatches (fromNormalizedFilePath f) + return $ isWF && fpMatches (fromNormalizedFilePath (inputFilePath f)) else const $ pure False if supportsWatchedFiles @@ -196,7 +197,7 @@ fileExistsRules recorder lspEnv = do fileStoreRules (cmapWithPrio LogFileStore recorder) isWatched -- 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 (WithPriority Log) -> (SomeFileInput -> Action Bool) -> Rules () fileExistsRulesFast recorder isWatched = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file @@ -221,11 +222,10 @@ For the VFS lookup, however, we won't get prompted to flush the result, so inste we use 'alwaysRerun'. -} -fileExistsFast :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsFast :: SomeFileInput -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsFast file = do -- Could in principle use 'alwaysRerun' here, but it's too slwo, See Note [Invalidating file existence results] mp <- getFileExistsMapUntracked - mbFilesWatched <- liftIO $ atomically $ STM.lookup file mp exist <- case mbFilesWatched of Just exist -> pure exist @@ -241,17 +241,18 @@ fileExistsRulesSlow :: Recorder (WithPriority Log) -> Rules () fileExistsRulesSlow recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow file -fileExistsSlow :: NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) +fileExistsSlow :: SomeFileInput -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsSlow file = do -- See Note [Invalidating file existence results] alwaysRerun exist <- getFileExistsVFS file pure (summarizeExists exist, Just exist) -getFileExistsVFS :: NormalizedFilePath -> Action Bool +getFileExistsVFS :: SomeFileInput -> Action Bool getFileExistsVFS file = do + let srcPath = inputFilePath file vf <- getVirtualFile file if isJust vf then pure True else liftIO $ handle (\(_ :: IOException) -> return False) $ - Dir.doesFileExist (fromNormalizedFilePath file) + Dir.doesFileExist (fromNormalizedFilePath srcPath) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7d253131d6..6c7f12f8a1 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.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake @@ -80,7 +81,7 @@ import System.IO.Unsafe data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath - | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) + | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [ProjectHaskellInput]) | LogShake Shake.Log deriving Show @@ -95,7 +96,7 @@ instance Pretty Log where <+> pretty (fmap (fmap show) reverseDepPaths) LogShake msg -> pretty msg -addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +addWatchedFileRule :: Recorder (WithPriority Log) -> (SomeFileInput -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f isWp <- isWorkspaceFile f @@ -104,7 +105,7 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogSha ShakeExtras{lspEnv} <- getShakeExtras case lspEnv of Just env -> fmap Just $ liftIO $ LSP.runLspT env $ - registerFileWatches [fromNormalizedFilePath f] + registerFileWatches [fromNormalizedFilePath (inputFilePath f)] Nothing -> pure $ Just False @@ -114,10 +115,11 @@ getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco getModificationTimeImpl :: Bool - -> NormalizedFilePath + -> SomeFileInput -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) getModificationTimeImpl missingFileDiags file = do - let file' = fromNormalizedFilePath file + let srcPath = inputFilePath file + file' = fromNormalizedFilePath srcPath let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) mbVf <- getVirtualFile file case mbVf of @@ -130,7 +132,9 @@ getModificationTimeImpl missingFileDiags file = do 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) + case file of + SomeFileHaskellInput x -> void (use_ IsFileOfInterest x) + _ -> pure () else if isInterface file then -- interface files are tracked specially using the closed world assumption pure () @@ -141,21 +145,22 @@ getModificationTimeImpl missingFileDiags file = do `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) + diag = ideErrorText srcPath (T.pack err) if isDoesNotExistError e && not missingFileDiags then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) getPhysicalModificationTimeRule :: Recorder (WithPriority Log) -> Rules () -getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime file -> - getPhysicalModificationTimeImpl file +getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime input -> + getPhysicalModificationTimeImpl input getPhysicalModificationTimeImpl - :: NormalizedFilePath + :: SomeFileInput -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) getPhysicalModificationTimeImpl file = do - let file' = fromNormalizedFilePath file + let srcPath = inputFilePath file + file' = fromNormalizedFilePath srcPath let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) alwaysRerun @@ -164,7 +169,7 @@ getPhysicalModificationTimeImpl file = do `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e - diag = ideErrorText file (T.pack err) + diag = ideErrorText srcPath (T.pack err) if isDoesNotExistError e then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) @@ -172,30 +177,30 @@ getPhysicalModificationTimeImpl file = do -- | Interface files cannot be watched, since they live outside the workspace. -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. -isInterface :: NormalizedFilePath -> Bool -isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] +isInterface :: IsFileInput file => file -> Bool +isInterface f = takeExtension (fromNormalizedFilePath (inputFilePath f)) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key] +resetInterfaceStore :: ShakeExtras -> SomeFileInput -> STM [Key] resetInterfaceStore state f = do deleteValue state GetModificationTime f -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key] +resetFileStore :: IdeState -> [(SomeFileInput, LSP.FileChangeType)] -> IO [Key] resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) fmap concat <$> - forM changes $ \(nfp, c) -> do + forM changes $ \(input, c) -> do case c of LSP.FileChangeType_Changed -- already checked elsewhere | not $ HM.member nfp fois -> atomically $ do - ks <- deleteValue (shakeExtras ideState) GetModificationTime nfp - vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime nfp + ks <- deleteValue (shakeExtras ideState) GetModificationTime input + vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime input pure $ ks ++ vs _ -> pure [] @@ -208,7 +213,7 @@ getFileContentsRule :: Recorder (WithPriority Log) -> Rules () getFileContentsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl file getFileContentsImpl - :: NormalizedFilePath + :: SomeFileInput -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff @@ -220,26 +225,28 @@ 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 :: SomeFileInput -> Action (UTCTime, Maybe Rope) getFileModTimeContents f = do (fv, contents) <- use_ GetFileContents f modTime <- case modificationTime fv of Just t -> pure t Nothing -> do - foi <- use_ IsFileOfInterest f + foi <- case f of + SomeFileHaskellInput x -> use_ IsFileOfInterest x + _ -> pure NotFOI liftIO $ case foi of IsFOI Modified{} -> getCurrentTime _ -> do - posix <- getModTime $ fromNormalizedFilePath f + posix <- getModTime $ fromNormalizedFilePath (inputFilePath f) pure $ posixSecondsToUTCTime posix return (modTime, contents) -getFileContents :: NormalizedFilePath -> Action (Maybe Rope) +getFileContents :: SomeFileInput -> Action (Maybe Rope) getFileContents f = snd <$> use_ GetFileContents f getUriContents :: NormalizedUri -> Action (Maybe Rope) getUriContents uri = - join <$> traverse getFileContents (uriToNormalizedFilePath uri) + join <$> traverse (getFileContents . toSomeFileInput) (uriToNormalizedFilePath uri) -- | Given a text document identifier, annotate it with the latest version. -- @@ -249,14 +256,14 @@ getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIde getVersionedTextDoc doc = do let uri = doc ^. L.uri mvf <- - maybe (pure Nothing) getVirtualFile $ - uriToNormalizedFilePath $ toNormalizedUri uri + maybe (pure Nothing) (getVirtualFile . toSomeFileInput) + (uriToNormalizedFilePath (toNormalizedUri uri)) let ver = case mvf of Just (VirtualFile lspver _ _ _) -> lspver Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) -fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules :: Recorder (WithPriority Log) -> (SomeFileInput -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do getModificationTimeRule recorder getPhysicalModificationTimeRule recorder @@ -269,7 +276,7 @@ setFileModified :: Recorder (WithPriority Log) -> VFSModified -> IdeState -> Bool -- ^ Was the file saved? - -> NormalizedFilePath + -> ProjectHaskellInput -> IO [Key] -> IO () setFileModified recorder vfs state saved nfp actionBefore = do @@ -279,19 +286,20 @@ setFileModified recorder vfs state saved nfp actionBefore = do AlwaysCheck -> True CheckOnSave -> saved _ -> False - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath (inputFilePath nfp) ++ " (modified)") [] $ do keys<-actionBefore - return (toKey GetModificationTime nfp:keys) + return (toKey GetModificationTime (SomeFileHaskellInput $ SomeProjectHaskellInput nfp):keys) when checkParents $ typecheckParents recorder state nfp -typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () -typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents - where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) +typecheckParents :: Recorder (WithPriority Log) -> IdeState -> ProjectHaskellInput -> IO () +typecheckParents recorder state input = + void $ shakeEnqueue (shakeExtras state) $ mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder input) -typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () -typecheckParentsAction recorder nfp = do - revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp +typecheckParentsAction :: Recorder (WithPriority Log) -> ProjectHaskellInput -> Action () +typecheckParentsAction recorder input = do + let nfp = inputFilePath input + revs <- transitiveReverseDependencies input <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph input case revs of Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do diff --git a/ghcide/src/Development/IDE/Core/HieFile.hs b/ghcide/src/Development/IDE/Core/HieFile.hs new file mode 100644 index 0000000000..b605088cc0 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/HieFile.hs @@ -0,0 +1,144 @@ +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 Control.Exception.Safe (tryAny) +import Control.Monad.Trans.Except (except) +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 + +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/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index eb42450bde..88eb46e722 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -19,6 +19,7 @@ import Data.Aeson.Types (Value) import Data.Hashable (Hashed, hashed, unhashed) import Data.HashSet (HashSet, singleton) import Data.Text (isPrefixOf) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location @@ -76,8 +77,9 @@ modifyIdeConfiguration ide f = do IdeConfigurationVar var <- getIdeGlobalState ide void $ modifyVar' var f -isWorkspaceFile :: NormalizedFilePath -> Action Bool -isWorkspaceFile file = +isWorkspaceFile :: SomeFileInput -> Action Bool +isWorkspaceFile input = do + let file = inputFilePath input if isRelative (fromNormalizedFilePath file) then return True else do 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..dd1564e7ec 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -30,8 +30,9 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar') import Data.Aeson (toJSON) import qualified Data.ByteString as BS -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, mapMaybe) import Development.IDE.Core.ProgressReporting +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake @@ -57,7 +58,7 @@ instance Pretty Log where pretty = \case LogShake msg -> pretty msg -newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +newtype OfInterestVar = OfInterestVar (Var (HashMap SomeHaskellInput FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar @@ -78,6 +79,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) @@ -86,24 +88,24 @@ instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API -getFilesOfInterest :: IdeState -> IO( HashMap NormalizedFilePath FileOfInterestStatus) +getFilesOfInterest :: IdeState -> IO( HashMap SomeHaskellInput FileOfInterestStatus) getFilesOfInterest state = do OfInterestVar var <- getIdeGlobalState state readVar var -- | Set the files-of-interest - not usually necessary or advisable. -- The LSP client will keep this information up to date. -setFilesOfInterest :: IdeState -> HashMap NormalizedFilePath FileOfInterestStatus -> IO () +setFilesOfInterest :: IdeState -> HashMap SomeHaskellInput FileOfInterestStatus -> IO () setFilesOfInterest state files = do OfInterestVar var <- getIdeGlobalState state writeVar var files -getFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getFilesOfInterestUntracked :: Action (HashMap SomeHaskellInput FileOfInterestStatus) getFilesOfInterestUntracked = do OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest :: IdeState -> SomeHaskellInput -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do @@ -112,16 +114,16 @@ addFileOfInterest state f v = do if prev /= Just v then do logWith (ideLogger state) Debug $ - LogSetFilesOfInterest (HashMap.toList files) + LogSetFilesOfInterest (listFilesOfInterestStatus files) return [toKey IsFileOfInterest f] else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest :: IdeState -> SomeHaskellInput -> IO [Key] deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f logWith (ideLogger state) Debug $ - LogSetFilesOfInterest (HashMap.toList files) + LogSetFilesOfInterest (listFilesOfInterestStatus files) return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do @@ -132,23 +134,27 @@ 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 files = HashMap.keys filesOfInterestMap + normalizedFiles = map inputFilePath files + -- keep project-specific GHC rules run only for project Haskell files. + projectHaskellFiles = mapMaybe (toProjectHaskellInput . inputFilePath) files let signal :: KnownSymbol s => Proxy s -> Action () signal msg = when testing $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ - toJSON $ map fromNormalizedFilePath files + toJSON $ map fromNormalizedFilePath normalizedFiles signal (Proxy @"kick/start") liftIO $ progressUpdate progress ProgressNewStarted -- Update the exports map - results <- uses GenerateCore files + results <- uses GenerateCore projectHaskellFiles <* uses GetHieAst files -- needed to have non local completions on the first edit -- when the first edit breaks the module header - <* uses NonLocalCompletions files + <* uses NonLocalCompletions projectHaskellFiles let mguts = catMaybes results void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) @@ -161,3 +167,9 @@ kick = do liftIO $ writeVar var False signal (Proxy @"kick/done") + +-- | Convert the files-of-interest map to a list keyed by normalized file path. +listFilesOfInterestStatus :: HashMap SomeHaskellInput FileOfInterestStatus -> [(NormalizedFilePath, FileOfInterestStatus)] +listFilesOfInterestStatus = fmap firstFilePath . HashMap.toList + where + firstFilePath (file, status) = (inputFilePath file, status) diff --git a/ghcide/src/Development/IDE/Core/PluginUtils.hs b/ghcide/src/Development/IDE/Core/PluginUtils.hs index 330468affe..1eeb5a9ce8 100644 --- a/ghcide/src/Development/IDE/Core/PluginUtils.hs +++ b/ghcide/src/Development/IDE/Core/PluginUtils.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Core.PluginUtils (-- * Wrapped Action functions runActionE @@ -43,6 +44,7 @@ import qualified Data.Text as T import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (IdeAction, IdeRule, IdeState (shakeExtras), @@ -81,30 +83,30 @@ 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 v => k -> RuleInput k -> 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 :: IdeRule k v => k -> RuleInput k -> MaybeT Action v useMT k = MaybeT . Shake.use k -- |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 v) => k -> f (RuleInput k) -> 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 :: (Traversable f, IdeRule k v) => k -> f (RuleInput k) -> MaybeT Action (f v) usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs -- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon -- failure useWithStaleE :: IdeRule k v - => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) + => k -> RuleInput k -> 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) + => k -> RuleInput k -> MaybeT Action (v, PositionMapping) useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) -- ---------------------------------------------------------------------------- @@ -121,11 +123,11 @@ 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 v) => k -> RuleInput k -> 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 :: (IdeRule k v) => k -> RuleInput k -> MaybeT IdeAction (v, PositionMapping) useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k -- ---------------------------------------------------------------------------- @@ -250,7 +252,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 $ toSomeFileInput nfp case contentsMaybe of Just contents -> do let (typ, mtoken) = case m of diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 3d8a2bf989..88a3cae76c 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -30,6 +30,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Functor (($>)) import qualified Data.Text as T +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -56,7 +57,7 @@ data ProgressReporting = ProgressReporting data PerFileProgressReporting = PerFileProgressReporting { - inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + inProgress :: forall a. SomeFileInput -> IO a -> IO a, -- ^ see Note [ProgressReporting API and InProgressState] progressReportingInner :: ProgressReporting } @@ -127,13 +128,13 @@ data InProgressState todoVar :: TVar Int, -- | Number of files done doneVar :: TVar Int, - currentVar :: STM.Map NormalizedFilePath Int + currentVar :: STM.Map SomeFileInput Int } newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO -recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () +recordProgress :: InProgressState -> SomeFileInput -> (Int -> Int) -> IO () recordProgress InProgressState {..} file shift = do (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar atomicallyNamed "recordProgress2" $ case (prev, new) of @@ -184,7 +185,7 @@ progressReporting (Just lspEnv) title optProgressStyle = do progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle let - inProgress :: NormalizedFilePath -> IO a -> IO a + inProgress :: SomeFileInput -> IO a -> IO a inProgress = updateStateForFile inProgressState return PerFileProgressReporting {..} where diff --git a/ghcide/src/Development/IDE/Core/RuleInput.hs b/ghcide/src/Development/IDE/Core/RuleInput.hs new file mode 100644 index 0000000000..0cfc4e2133 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/RuleInput.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.IDE.Core.RuleInput + ( RuleInput + , InputFingerprint(..) + , ProjectHaskellInput(..) + , NonProjectHaskellInput(..) + , SomeHaskellInput(..) + , CabalInput(..) + , SomeFileInput(..) + , NoInput(..) + , SomeInput + , IsInput(..) + , fileInputFingerprint + , isHaskellFilePath + , isDependencyHaskellPath + , IsFileInput(..) + , inputUri + , toProjectHaskellInput + , toNonProjectHaskellInput + , toCabalInput + , toSomeHaskellInput + , toSomeFileInput + , classifyAsProjectHaskell + , classifyAsDep + , classifyAsCabal + , classifyAsSomeHaskell + , classifyAsSomeFile + ) where + +import Control.DeepSeq +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.Hashable +import Data.List (isInfixOf) +import qualified Data.Text as T +import Data.Typeable +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (..)) +import Language.LSP.Protocol.Types (NormalizedFilePath, Uri, + filePathToUri, + fromNormalizedFilePath, + toNormalizedUri, + uriToNormalizedFilePath) +import System.FilePath (normalise, takeExtension) + +-- | Associate a rule key @k@ with the type of input that identifies an +-- invocation of that rule. +-- +-- Every rule key must define an instance of this open type family. For +-- example: +-- +-- @ +-- data GetParsedModule = GetParsedModule +-- type instance RuleInput GetParsedModule = ProjectHaskellInput +-- @ +type family RuleInput k + +-- | Identity of RuleInputs. +-- +-- Used to efficiently compare and hash rule inputs. +data InputFingerprint + = InputNoFile + | InputFile !NormalizedFilePath + | forall a. (Eq a, Hashable a, Typeable a) => InputValue a + +instance Eq InputFingerprint where + InputNoFile == InputNoFile = True + InputFile p1 == InputFile p2 = p1 == p2 + InputValue a == InputValue b = + case cast b of + Just b' -> a == b' + Nothing -> False + _ == _ = False + +instance Hashable InputFingerprint where + hashWithSalt s InputNoFile = hashWithSalt s (0 :: Int) + hashWithSalt s (InputFile p) = hashWithSalt s (1 :: Int, p) + hashWithSalt s (InputValue a) = hashWithSalt s (2 :: Int, hash a) + +{- Note [Rule input hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'RuleInput' can be a node from this AST: + +@ +'SomeInput' -- any rule input +├── 'NoInput' -- global +└── 'SomeFileInput' -- has a 'NormalizedFilePath' + ├── 'SomeHaskellInput' -- all Haskell files + │ ├── 'NonProjectHaskellInput' -- files in .hls/dependencies + │ └── 'ProjectHaskellInput' -- haskell files of your project + └── 'CabalInput' -- all .cabal files +@ + +Upcasting wraps a child in each parent constructor, then uses 'toInput' for 'SomeInput'; +for example, 'ProjectHaskellInput' -> 'SomeHaskellInput' -> 'SomeFileInput' -> 'SomeInput'. +We can downcast a rule input via 'fromInput'. +-} + +-- | Types that can be used as rule inputs. +-- +-- 'toInput' packs a value into the existential 'SomeInput' wrapper. +-- 'fromInput' attempts to recover a supported input type +-- 'inputFingerprint' defines the identity used when comparing and hashing wrapped inputs. +-- +-- See Note [Rule input hierarchy]. +class (Typeable i, Hashable i, Eq i, Show i, NFData i) => IsInput i where + toInput :: i -> SomeInput + toInput = SomeInput + + fromInput :: SomeInput -> Maybe i + fromInput (SomeInput i) = cast i + + inputFingerprint :: i -> InputFingerprint + inputFingerprint i = InputValue i + +-- | Stores any value that implements 'IsInput'. +data SomeInput = forall i. IsInput i => SomeInput i + +instance Eq SomeInput where + SomeInput a == SomeInput b = inputFingerprint a == inputFingerprint b + +instance Hashable SomeInput where + hashWithSalt salt (SomeInput i) = hashWithSalt salt (inputFingerprint i) + +instance Show SomeInput where + show (SomeInput i) = show i + +instance NFData SomeInput where + rnf (SomeInput i) = rnf i + +instance IsInput SomeInput where + toInput = id + fromInput = Just + inputFingerprint (SomeInput i) = inputFingerprint i + +-- | A Rule Input that has no file associated with it. +-- Rules with 'RuleInput' 'NoInput' ruletype must be treated as global rules. +data NoInput = NoInput + deriving (Eq, Ord, Show, Generic) + +instance Hashable NoInput + +instance NFData NoInput + +instance IsInput NoInput where + fromInput input = case inputFingerprint input of + InputNoFile -> Just NoInput + _ -> Nothing + + inputFingerprint :: NoInput -> InputFingerprint + inputFingerprint _ = InputNoFile + +-- | A Rule Input that has some file (Haskell, cabal etc.) associated with it. +class IsInput i => IsFileInput i where + inputFilePath :: i -> NormalizedFilePath + +data SomeFileInput + = SomeFileHaskellInput SomeHaskellInput + | SomeFileCabalInput CabalInput + | SomeFileNormalizedFilePath NormalizedFilePath + deriving (Generic) + +instance Eq SomeFileInput where + a == b = fileInputFingerprint a == fileInputFingerprint b + +instance Hashable SomeFileInput where + hashWithSalt salt = hashWithSalt salt . fileInputFingerprint + +instance Show SomeFileInput where + show (SomeFileHaskellInput input) = "SomeFileInput (" <> show input <> ")" + show (SomeFileCabalInput input) = "SomeFileInput (" <> show input <> ")" + show (SomeFileNormalizedFilePath input) = "SomeFileInput (" <> show input <> ")" + +instance NFData SomeFileInput + +instance IsInput SomeFileInput where + fromInput input = toSomeFileInput <$> someInputFilePathMaybe input + inputFingerprint = fileInputFingerprint + +instance IsFileInput SomeFileInput where + inputFilePath (SomeFileHaskellInput input) = inputFilePath input + inputFilePath (SomeFileCabalInput input) = inputFilePath input + inputFilePath (SomeFileNormalizedFilePath input) = inputFilePath input + +instance IsInput NormalizedFilePath where + fromInput = someInputFilePathMaybe + inputFingerprint = InputFile + +instance IsFileInput NormalizedFilePath where + inputFilePath = id + +-- | Fingerprint a file input by its normalized file path. +fileInputFingerprint :: IsFileInput i => i -> InputFingerprint +fileInputFingerprint input = InputFile (inputFilePath input) + +-- | Convert a file input to a URI. +inputUri :: IsFileInput i => i -> Uri +inputUri = filePathToUri . fromNormalizedFilePath . inputFilePath + +-- | Leaf Type which represents a cabal file. +newtype CabalInput = CabalInput NormalizedFilePath + deriving (Eq, Ord, Show, Generic) + +instance Hashable CabalInput + +instance NFData CabalInput + +instance IsInput CabalInput where + fromInput input = someInputFilePathMaybe input >>= toCabalInput + inputFingerprint = fileInputFingerprint + +instance IsFileInput CabalInput where + inputFilePath (CabalInput path) = path + +-- | Mark an input as a validated Haskell source file input. +class IsFileInput i => IsHaskellInput i + +data SomeHaskellInput + = SomeProjectHaskellInput ProjectHaskellInput + | SomeNonProjectHaskellInput NonProjectHaskellInput + deriving (Generic) + +instance Eq SomeHaskellInput where + a == b = fileInputFingerprint a == fileInputFingerprint b + +instance Hashable SomeHaskellInput where + hashWithSalt salt = hashWithSalt salt . fileInputFingerprint + +instance Show SomeHaskellInput where + show (SomeProjectHaskellInput input) = "SomeHaskellInput (" <> show input <> ")" + show (SomeNonProjectHaskellInput input) = "SomeHaskellInput (" <> show input <> ")" + +instance NFData SomeHaskellInput + +instance IsInput SomeHaskellInput where + fromInput input = someInputFilePathMaybe input >>= toSomeHaskellInput + inputFingerprint = fileInputFingerprint + +instance IsFileInput SomeHaskellInput where + inputFilePath (SomeProjectHaskellInput input) = inputFilePath input + inputFilePath (SomeNonProjectHaskellInput input) = inputFilePath input + +instance IsHaskellInput SomeHaskellInput + +-- | Leaf Type representing a Haskell file inside project directory. +newtype ProjectHaskellInput = ProjectHaskellInput NormalizedFilePath + deriving (Eq, Ord, Show, Generic) + +instance Hashable ProjectHaskellInput + +instance NFData ProjectHaskellInput + +instance IsInput ProjectHaskellInput where + fromInput input = someInputFilePathMaybe input >>= toProjectHaskellInput + inputFingerprint = fileInputFingerprint + +instance IsFileInput ProjectHaskellInput where + inputFilePath (ProjectHaskellInput path) = path + +instance IsHaskellInput ProjectHaskellInput + +-- | Leaf Type representing a Haskell file inside project .hls/dependencies directory. + +newtype NonProjectHaskellInput = NonProjectHaskellInput NormalizedFilePath + deriving (Eq, Ord, Show, Generic) + +instance Hashable NonProjectHaskellInput + +instance NFData NonProjectHaskellInput + +instance IsInput NonProjectHaskellInput where + fromInput input = someInputFilePathMaybe input >>= toNonProjectHaskellInput + inputFingerprint = fileInputFingerprint + +instance IsFileInput NonProjectHaskellInput where + inputFilePath (NonProjectHaskellInput path) = path + +instance IsHaskellInput NonProjectHaskellInput + +-- ---------------------------------------------------------------------------- +-- Classify NFP as RuleInputs +-- ---------------------------------------------------------------------------- +isCabalInput :: NormalizedFilePath -> Bool +isCabalInput = (== ".cabal") . takeExtension . fromNormalizedFilePath + +-- TODO: needs to be unified with optExtensions +isHaskellFilePath :: NormalizedFilePath -> Bool +isHaskellFilePath fp = takeExtension (fromNormalizedFilePath fp) `elem` + [".hs", ".lhs", ".hs-boot", ".lhs-boot"] + +isNonProjectHaskellInput :: NormalizedFilePath -> Bool +isNonProjectHaskellInput fp = isHaskellFilePath fp && isDependencyHaskellPath fp + +isProjectHaskellInput :: NormalizedFilePath -> Bool +isProjectHaskellInput fp = isHaskellFilePath fp && not (isDependencyHaskellPath fp) + +isDependencyHaskellPath :: NormalizedFilePath -> Bool +isDependencyHaskellPath = (".hls/dependencies" `isInfixOf`) . normalise . fromNormalizedFilePath + +-- | Returns the underlying Normalised File Path of a Typed Rule ONLY if it exists. +someInputFilePathMaybe :: SomeInput -> Maybe NormalizedFilePath +someInputFilePathMaybe input = + case inputFingerprint input of + InputFile path -> Just path + _ -> Nothing + +toProjectHaskellInput :: NormalizedFilePath -> Maybe ProjectHaskellInput +toProjectHaskellInput nfp = case toSomeFileInput nfp of + SomeFileHaskellInput (SomeProjectHaskellInput input) -> Just input + _ -> Nothing + +toNonProjectHaskellInput :: NormalizedFilePath -> Maybe NonProjectHaskellInput +toNonProjectHaskellInput nfp = case toSomeFileInput nfp of + SomeFileHaskellInput (SomeNonProjectHaskellInput input) -> Just input + _ -> Nothing + +toCabalInput :: NormalizedFilePath -> Maybe CabalInput +toCabalInput nfp = case toSomeFileInput nfp of + SomeFileCabalInput input -> Just input + _ -> Nothing + +toSomeHaskellInput :: NormalizedFilePath -> Maybe SomeHaskellInput +toSomeHaskellInput nfp = case toSomeFileInput nfp of + SomeFileHaskellInput input -> Just input + _ -> Nothing + +toSomeFileInput :: NormalizedFilePath -> SomeFileInput +toSomeFileInput nfp + | isCabalInput nfp = SomeFileCabalInput (CabalInput nfp) + | isProjectHaskellInput nfp = SomeFileHaskellInput (SomeProjectHaskellInput (ProjectHaskellInput nfp)) + | isNonProjectHaskellInput nfp = SomeFileHaskellInput (SomeNonProjectHaskellInput (NonProjectHaskellInput nfp)) + | otherwise = SomeFileNormalizedFilePath nfp + +-- ---------------------------------------------------------------------------- +-- Classify URI as RuleInputs +-- ---------------------------------------------------------------------------- +classifyUri :: Monad m => Uri -> ExceptT PluginError m NormalizedFilePath +classifyUri uri = + case uriToNormalizedFilePath (toNormalizedUri uri) of + Just nfp -> pure nfp + Nothing -> throwE (PluginUnsupportedUriType uri) + +classifyAs + :: Monad m + => String + -> (NormalizedFilePath -> Maybe i) + -> Uri + -> ExceptT PluginError m i +classifyAs expected classifier uri = do + nfp <- classifyUri uri + case classifier nfp of + Just input -> pure input + Nothing -> + throwE (PluginInvalidParams (T.pack ("Expected " <> expected <> " URI: " <> show uri))) + +classifyAsProjectHaskell :: Monad m => Uri -> ExceptT PluginError m ProjectHaskellInput +classifyAsProjectHaskell = classifyAs "project Haskell" toProjectHaskellInput + +classifyAsDep :: Monad m => Uri -> ExceptT PluginError m NonProjectHaskellInput +classifyAsDep = classifyAs "dependency Haskell" toNonProjectHaskellInput + +classifyAsCabal :: Monad m => Uri -> ExceptT PluginError m CabalInput +classifyAsCabal = classifyAs "cabal" toCabalInput + +classifyAsSomeHaskell :: Monad m => Uri -> ExceptT PluginError m SomeHaskellInput +classifyAsSomeHaskell = classifyAs "Haskell" toSomeHaskellInput + +classifyAsSomeFile :: Monad m => Uri -> ExceptT PluginError m SomeFileInput +classifyAsSomeFile uri = toSomeFileInput <$> classifyUri uri diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 44bad8f709..7d3414d18a 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -35,11 +35,14 @@ 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) +import Development.IDE.Core.RuleInput import Development.IDE.Import.FindImports (ArtifactsLocation, ModuleToFilenames) import Development.IDE.Spans.Common @@ -49,8 +52,7 @@ import GHC.Driver.Errors.Types (WarningMessages) import GHC.Serialized (Serialized) import Ide.Logger (Pretty (..), viaShow) -import Language.LSP.Protocol.Types (Int32, - NormalizedFilePath) +import Language.LSP.Protocol.Types (Int32) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) @@ -71,27 +73,37 @@ encodeLinkableType (Just ObjectLinkable) = "2" -- | The parse tree for the file using GetFileContents type instance RuleResult GetParsedModule = ParsedModule +type instance RuleInput GetParsedModule = ProjectHaskellInput -- | The parse tree for the file using GetFileContents, -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule +type instance RuleInput GetParsedModuleWithComments = ProjectHaskellInput type instance RuleResult GetModuleGraph = DependencyInformation +type instance RuleInput GetModuleGraph = NoInput -- | 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 = ProjectHaskellInput + type instance RuleResult GetModuleGraphTransReverseDepsFingerprints = Fingerprint +type instance RuleInput GetModuleGraphTransReverseDepsFingerprints = ProjectHaskellInput + type instance RuleResult GetModuleGraphImmediateReverseDepsFingerprints = Fingerprint +type instance RuleInput GetModuleGraphImmediateReverseDepsFingerprints = ProjectHaskellInput data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets instance NFData GetKnownTargets type instance RuleResult GetKnownTargets = KnownTargets +type instance RuleInput GetKnownTargets = NoInput -- | Convert to Core, requires TypeCheck* type instance RuleResult GenerateCore = ModGuts +type instance RuleInput GenerateCore = ProjectHaskellInput data GenerateCore = GenerateCore deriving (Eq, Show, Generic) @@ -99,6 +111,7 @@ instance Hashable GenerateCore instance NFData GenerateCore type instance RuleResult GetLinkable = LinkableResult +type instance RuleInput GetLinkable = ProjectHaskellInput data LinkableResult = LinkableResult @@ -127,8 +140,9 @@ instance Hashable GetImportMap instance NFData GetImportMap type instance RuleResult GetImportMap = ImportMap +type instance RuleInput GetImportMap = ProjectHaskellInput newtype ImportMap = ImportMap - { importMap :: M.Map ModuleName NormalizedFilePath -- ^ Where are the modules imported by this file located? + { importMap :: M.Map ModuleName ProjectHaskellInput -- ^ Where are the modules imported by this file located? } deriving stock Show deriving newtype NFData @@ -233,6 +247,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 @@ -249,12 +276,15 @@ instance Show HieAstResult where -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult +type instance RuleInput TypeCheck = ProjectHaskellInput -- | The uncompressed HieAST type instance RuleResult GetHieAst = HieAstResult +type instance RuleInput GetHieAst = SomeHaskellInput -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings +type instance RuleInput GetBindings = ProjectHaskellInput data DocAndTyThingMap = DKMap { getDocMap :: !DocMap @@ -270,41 +300,53 @@ instance Show DocAndTyThingMap where show = const "docmap" type instance RuleResult GetDocMap = DocAndTyThingMap +type instance RuleInput GetDocMap = ProjectHaskellInput -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq +type instance RuleInput GhcSession = ProjectHaskellInput -- | 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 = ProjectHaskellInput -- | 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 = ProjectHaskellInput -- | 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 = ProjectHaskellInput -- | 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 = ProjectHaskellInput -- | 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 = ProjectHaskellInput -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult +type instance RuleInput GetModIface = ProjectHaskellInput -- | 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 = SomeFileInput type instance RuleResult GetFileExists = Bool +type instance RuleInput GetFileExists = SomeFileInput type instance RuleResult GetFileHash = Fingerprint +type instance RuleInput GetFileHash = SomeFileInput type instance RuleResult AddWatchedFile = Bool +type instance RuleInput AddWatchedFile = SomeFileInput -- The Shake key type for getModificationTime queries @@ -335,12 +377,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 = SomeFileInput pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion +type instance RuleInput GetModificationTime = SomeFileInput -- | Either the mtime from disk or an LSP version -- LSP versions always compare as greater than on disk versions @@ -374,6 +418,7 @@ instance Hashable GetFileHash data FileOfInterestStatus = OnDisk + | ReadOnly | Modified { firstOpen :: !Bool -- ^ was this file just opened } deriving (Eq, Show, Generic) @@ -389,6 +434,7 @@ instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult type instance RuleResult IsFileOfInterest = IsFileOfInterestResult +type instance RuleInput IsFileOfInterest = SomeHaskellInput data ModSummaryResult = ModSummaryResult { msrModSummary :: !ModSummary @@ -411,11 +457,14 @@ instance NFData ModSummaryResult where -- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. -- without needing to parse the entire source type instance RuleResult GetModSummary = ModSummaryResult +type instance RuleInput GetModSummary = ProjectHaskellInput -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleInput GetModSummaryWithoutTimestamps = ProjectHaskellInput type instance RuleResult GetModulesPaths = ModuleToFilenames +type instance RuleInput GetModulesPaths = ProjectHaskellInput data GetParsedModule = GetParsedModule deriving (Eq, Show, Generic) @@ -434,6 +483,7 @@ instance NFData GetLocatedImports -- | Does this module need to be compiled? type instance RuleResult NeedsCompilation = Maybe LinkableType +type instance RuleInput NeedsCompilation = ProjectHaskellInput data NeedsCompilation = NeedsCompilation deriving (Eq, Show, Generic) @@ -549,6 +599,7 @@ instance Hashable GetClientSettings instance NFData GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) +type instance RuleInput GetClientSettings = NoInput data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile @@ -559,6 +610,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 = NoInput 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 df49bc7a6b..fb8b5f7a4b 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -75,6 +75,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 @@ -85,6 +86,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet import Data.IORef import Data.List #if MIN_VERSION_ghc(9,13,0) @@ -110,6 +112,7 @@ import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) @@ -180,9 +183,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 Data.Char (isUpper) import qualified Data.HashSet as HS @@ -202,10 +206,12 @@ import System.FilePath (dropExtension, data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath - | LogLoadingHieFile !NormalizedFilePath + | LogLoadingHieFile !SomeHaskellInput | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath + | LogMissingHieFile !NormalizedFilePath | LogTypecheckedFOI !NormalizedFilePath + | LogHieFile HieFile.HieFileLog deriving Show instance Pretty Log where @@ -214,7 +220,7 @@ instance Pretty Log where LogReindexingHieFile path -> "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path -> - "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath $ inputFilePath path) LogLoadingHieFileFail path e -> nest 2 $ vcat @@ -222,6 +228,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." @@ -230,6 +238,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" @@ -246,20 +255,20 @@ toIdeResult = either (, Nothing) (([],) . Just) -- TODO: rename -- TODO: return text --> return rope -getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString -getSourceFileSource nfp = do - msource <- getFileContents nfp +getSourceFileSource :: SomeFileInput -> Action BS.ByteString +getSourceFileSource input = do + msource <- getFileContents input case msource of - Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) + Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath (inputFilePath input)) Just source -> pure $ T.encodeUtf8 $ Rope.toText source -- | Parse the contents of a haskell file. -getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) +getParsedModule :: ProjectHaskellInput -> 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 :: ProjectHaskellInput -> Action (Maybe ParsedModule) getParsedModuleWithComments = use GetParsedModuleWithComments ------------------------------------------------------------ @@ -278,14 +287,14 @@ getParsedModuleWithComments = use GetParsedModuleWithComments getParsedModuleRule :: Recorder (WithPriority Log) -> Rules () getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it - define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do - ModSummaryResult{msrModSummary = ms', msrHscEnv = hsc} <- use_ GetModSummary file + define (cmapWithPrio LogShake recorder) $ \GetParsedModule input -> do + ModSummaryResult{msrModSummary = ms', msrHscEnv = hsc} <- use_ GetModSummary input opt <- getIdeOptions modify_dflags <- getModifyDynFlags dynFlagsModifyParser 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 input ms withoutOptHaddock :: ModSummary -> ModSummary withoutOptHaddock = withoutOption Opt_Haddock @@ -303,8 +312,8 @@ getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules () getParsedModuleWithCommentsRule recorder = -- The parse diagnostics are owned by the GetParsedModule rule -- For this reason, this rule does not produce any diagnostics - defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do - ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments input -> do + ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary input opt <- getIdeOptions let ms' = withoutOptHaddock $ withOption Opt_KeepRawTokenStream ms @@ -312,7 +321,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 input ms'' getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do @@ -324,14 +333,11 @@ getModifyDynFlags f = do getParsedModuleDefinition :: HscEnv -> IdeOptions - -> NormalizedFilePath + -> ProjectHaskellInput -> ModSummary -> IO ([FileDiagnostic], Maybe ParsedModule) -getParsedModuleDefinition packageState opt file ms = do - let fp = fromNormalizedFilePath file - (diag, res) <- parseModule opt packageState fp ms - case res of - Nothing -> pure (diag, Nothing) - Just modu -> pure (diag, Just modu) +getParsedModuleDefinition packageState opt input ms = do + let fp = fromNormalizedFilePath (inputFilePath input) + parseModule opt packageState fp ms getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules () getLocatedImportsRule recorder = @@ -379,9 +385,10 @@ getLocatedImportsRule recorder = let moduleImports = catMaybes $ bootArtifact : imports' pure (concat diags, Just moduleImports) -type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a +type RawDepState = (RawDependencyInformation, IntMap ArtifactsLocation) +type RawDepM a = StateT RawDepState Action a -execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) +execRawDepM :: Monad m => StateT RawDepState m a -> m RawDepState execRawDepM act = execStateT act ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty @@ -390,17 +397,18 @@ execRawDepM act = -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) +rawDependencyInformation :: [ProjectHaskellInput] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss return (rdi, bm) where + goPlural :: [ProjectHaskellInput] -> RawDepM [FilePathId] goPlural ff = do mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff zipWithM go ff mss - go :: NormalizedFilePath -- ^ Current module being processed + go :: ProjectHaskellInput -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module -> RawDepM FilePathId go f mbModSum = do @@ -444,10 +452,10 @@ rawDependencyInformation fs = do return fId - checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId + checkAlreadyProcessed :: ProjectHaskellInput -> RawDepM FilePathId -> RawDepM FilePathId checkAlreadyProcessed nfp k = do (rawDepInfo, _) <- get - maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp) + maybe k return (pathToId (rawPathIdMap rawDepInfo) nfp) modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM () modifyRawDepInfo f = modify (first f) @@ -478,7 +486,8 @@ rawDependencyInformation fs = do updateBootMap pm boot_mod_id ArtifactsLocation{..} bm = if not artifactIsSource then - let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath artifactFilePath) + let msource_mod_id = toProjectHaskellInput (toNormalizedFilePath' $ dropBootSuffix $ fromNormalizedFilePath $ inputFilePath artifactFilePath) + >>= pathToId (rawPathIdMap pm) in case msource_mod_id of Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm Nothing -> bm @@ -489,9 +498,9 @@ rawDependencyInformation fs = do 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 + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles input -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do + DependencyInformation{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph input + case pathToId depPathIdMap input of -- The header of the file does not parse, so it can't be part of any import cycles. Nothing -> pure [] Just fileId -> @@ -512,21 +521,40 @@ reportImportCyclesRule recorder = & fdLspDiagnosticL %~ JL.range .~ rng where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) - getModuleName file = do - ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file + getModuleName 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 + case f of + -- For Dependency source files, get the HieAstResult from + -- the HIE file in the HieDb database + SomeNonProjectHaskellInput _ -> 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) + SomeProjectHaskellInput input -> do + tmr <- use_ TypeCheck input + hsc <- hscEnv <$> use_ GhcSessionDeps input + getHieAstRuleDefinition f hsc tmr persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () -persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do - res <- readHieFileForSrcFromDisk recorder file +persistentHieFileRule recorder = addPersistentRule GetHieAst $ \input -> runMaybeT $ do + projectInput <- MaybeT $ pure $ case input of + SomeProjectHaskellInput projectInput -> Just projectInput + _ -> Nothing + let file = inputFilePath projectInput + res <- readHieFileForSrcFromDisk recorder (SomeProjectHaskellInput projectInput) vfsRef <- asks vfsVar vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of @@ -536,7 +564,7 @@ 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 :: SomeHaskellInput -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do (diags, masts') <- liftIO $ generateHieAsts hsc tmr #if MIN_VERSION_ghc(9,11,0) @@ -544,17 +572,17 @@ getHieAstRuleDefinition f hsc tmr = do #else let masts = masts' #endif + let file = inputFilePath f se <- getShakeExtras - isFoi <- use_ IsFileOfInterest f diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ - toJSON $ fromNormalizedFilePath f + toJSON $ fromNormalizedFilePath (file) pure [] _ | Just asts <- masts' -> do - source <- getSourceFileSource f + source <- getSourceFileSource (toSomeFileInput file) let exports = tcg_exports $ tmrTypechecked tmr modSummary = tmrModSummary tmr liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source @@ -577,7 +605,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 (SomeProjectHaskellInput f) case kind of HieFresh -> pure ([], Just $ bindings rm) HieFromDisk _ -> pure ([], Nothing) @@ -587,7 +615,7 @@ getDocMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do (tmrTypechecked -> tc) <- use_ TypeCheck file (hscEnv -> hsc) <- use_ GhcSessionDeps file - HAR{refMap=rf} <- use_ GetHieAst file + HAR{refMap=rf} <- use_ GetHieAst (SomeProjectHaskellInput file) cfg <- getClientConfigAction dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets { linkSource = linkSourceTo cfg @@ -599,35 +627,27 @@ getDocMapRule recorder = persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile -readHieFileForSrcFromDisk recorder file = do +readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> SomeHaskellInput -> MaybeT IdeAction Compat.HieFile +readHieFileForSrcFromDisk recorder input = do ShakeExtras{withHieDb} <- ask + let file = inputFilePath input 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 + liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile input + 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 +typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck input -> do + pm <- use_ GetParsedModule input + hsc <- hscEnv <$> use_ GhcSessionDeps input + foi <- use_ IsFileOfInterest (SomeProjectHaskellInput input) -- 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 - typeCheckRuleDefinition hsc pm file + logWith recorder Logger.Warning $ LogTypecheckedFOI (inputFilePath input) + typeCheckRuleDefinition hsc pm input knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do @@ -637,17 +657,15 @@ 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) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash input -> do + void $ use_ GetModificationTime input + fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath (inputFilePath input)) return (Just (fingerprintToBS fileHash), ([], Just fileHash)) getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do - -- Only the files of the project: a file no component claims has no session to - -- be compiled in. See Note [Files that are not targets] fs <- toTargetFiles <$> useNoFile_ GetKnownTargets - dependencyInfoForFiles (HashSet.toList fs) + dependencyInfoForFiles (mapMaybe toProjectHaskellInput (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. @@ -672,11 +690,11 @@ getModulesPathsRule recorder = use GhcSession file >>= \case Nothing -> pure (Nothing, Nothing) Just env_eq - | file == envRepresentative env_eq -> do + | inputFilePath file == envRepresentative env_eq -> do res <- computeModulesPaths env_eq pure (Just (fingerprintToBS (mtfFingerprint res)), Just res) | otherwise -> do - res <- use GetModulesPaths (envRepresentative env_eq) + res <- use GetModulesPaths (ProjectHaskellInput (envRepresentative env_eq)) pure (fingerprintToBS . mtfFingerprint <$> res, res) {- Note [Session representatives] @@ -753,11 +771,14 @@ computeModulesPaths env_eq = do [ providers u m | (u, (m, _)) <- unit_maps ] pure $ mkModuleToFilenames normal (HS.unions [ b | (_, (_, b)) <- unit_maps ]) -dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) +dependencyInfoForFiles :: [ProjectHaskellInput] -> 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 + let allInputsWithIds = + map (\(fileId, location) -> (artifactFilePath location, FilePathId fileId)) $ + IntMap.toList $ idToPathMap $ rawPathIdMap rawDepInfo + (allProjectInputs, _all_ids) = unzip allInputsWithIds + msrs <- uses GetModSummaryWithoutTimestamps allProjectInputs 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 @@ -788,14 +809,14 @@ dependencyInfoForFiles fs = do typeCheckRuleDefinition :: HscEnv -> ParsedModule - -> NormalizedFilePath + -> ProjectHaskellInput -> Action (IdeResult TcModuleResult) typeCheckRuleDefinition hsc pm fp = do IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO let dets = TypecheckHelpers - { getLinkables = unliftIO unlift . uses_ GetLinkable + { getLinkables = \files -> unliftIO unlift $ uses_ GetLinkable files , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp } -- This 'setFileCacheHook' is neccessary to work correctly @@ -813,7 +834,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 (toSomeFileInput . toNormalizedFilePath') used_files) return r -- | Get all the linkables stored in the graph, i.e. the ones we *do not* need to unload. @@ -846,27 +867,28 @@ loadGhcSession recorder ghcSessionDepsConfig = do ] return (fingerprint, res) - defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession input -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO -- loading is always returning a absolute path now - (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath (inputFilePath input) -- 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 + let file = toSomeFileInput nfp + itExists <- getFileExists file when itExists $ void $ do - use_ GetPhysicalModificationTime nfp + use_ GetPhysicalModificationTime file mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do - env <- use_ GhcSession file - ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) input -> do + env <- use_ GhcSession input + ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env input newtype GhcSessionDepsConfig = GhcSessionDepsConfig { fullModuleGraph :: Bool @@ -885,12 +907,13 @@ instance Default GhcSessionDepsConfig where ghcSessionDepsDefinition :: -- | full mod summary Bool -> - GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) + GhcSessionDepsConfig -> HscEnvEq -> ProjectHaskellInput -> Action (Maybe HscEnvEq) ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = do - mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file + mbdeps <- mapM snd <$> use_ GetLocatedImports file case mbdeps of Nothing -> return Nothing Just deps -> do + let projectDeps = map artifactFilePath deps when fullModuleGraph $ void $ use_ ReportImportCycles file msr <- if fullModSummary then use_ GetModSummary file @@ -900,8 +923,8 @@ 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 + depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) projectDeps + ifaces <- uses_ GetModIface projectDeps -- 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) @@ -919,7 +942,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 projectDeps return $!! map (NodeKey_Module . msKey) dep_mss #if MIN_VERSION_ghc(9,13,0) let final_dep_edges = mkLevelEdges ms final_deps @@ -950,7 +973,7 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco Nothing -> return (Nothing, ([], Nothing)) Just session -> do linkableType <- getLinkableType f - ver <- use_ GetModificationTime f + ver <- use_ GetModificationTime (SomeFileHaskellInput $ SomeProjectHaskellInput 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) @@ -959,7 +982,9 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco { 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_linkable_hashes = \fs -> + map (snd . fromJust . hirCoreFp) + <$> uses_ GetModIface fs , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f , regenerate = regenerateHiFile session f ms } @@ -989,8 +1014,9 @@ getModIfaceFromDiskAndIndexRule recorder = -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x hie_loc = Compat.ml_hie_file $ ms_location ms + file = inputFilePath f fileHash <- liftIO $ Util.getFileHash hie_loc - mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) + mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath file)) let hie_loc' = HieDb.hieModuleHieFile <$> mrow case mrow of Just row @@ -1000,18 +1026,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 file -- 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 file + indexHieFile se (toNormalizedFilePath' hie_loc) (HieDb.RealFile $ fromNormalizedFilePath file) fileHash hf return (Just x) @@ -1033,8 +1059,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 (SomeFileHaskellInput(SomeProjectHaskellInput f)) + let fp = fromNormalizedFilePath (inputFilePath f) modS <- liftIO $ runExceptT $ getModSummaryFromImports session fp (textToStringBuffer . Rope.toText <$> mFileContent) case modS of @@ -1060,11 +1086,11 @@ getModSummaryRule displayTHWarning recorder = do return (Just fp, Just res{msrModSummary = ms}) Nothing -> return (Nothing, Nothing) -generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) -generateCore runSimplifier file = do - packageState <- hscEnv <$> use_ GhcSessionDeps file +generateCore :: RunSimplifier -> ProjectHaskellInput -> Action (IdeResult ModGuts) +generateCore runSimplifier input = do + packageState <- hscEnv <$> use_ GhcSessionDeps input hsc' <- setFileCacheHook packageState - tm <- use_ TypeCheck file + tm <- use_ TypeCheck input liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () @@ -1073,7 +1099,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 (SomeProjectHaskellInput f) res <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest @@ -1116,7 +1142,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 . toSomeFileInput . toNormalizedFilePath' } } #else return old_hsc_env #endif @@ -1124,19 +1150,19 @@ 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 -> ProjectHaskellInput -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) +regenerateHiFile sess input ms compNeeded = do hsc <- setFileCacheHook (hscEnv sess) opt <- getIdeOptions -- By default, we parse with `-haddock` unless 'OptHaddockParse' is overwritten. - (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms + (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt input ms case mb_pm of Nothing -> return (diags, Nothing) 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 @@ -1151,15 +1177,24 @@ regenerateHiFile sess f ms compNeeded = do -- Write hi file hiDiags <- case res of Just !hiFile -> do - + let haskellInput = SomeProjectHaskellInput input + fileInput = SomeFileHaskellInput haskellInput -- Write hie file. Do this before writing the .hi file to -- ensure that we always have a up2date .hie file if we have -- a .hi file se' <- getShakeExtras (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr - source <- getSourceFileSource f + source <- getSourceFileSource fileInput wDiags <- forM masts $ \asts -> - liftIO $ writeAndIndexHieFile hsc se' (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + liftIO $ + writeAndIndexHieFile + hsc + se' + (tmrModSummary tmr) + haskellInput + (tcg_exports $ tmrTypechecked tmr) + asts + source -- We don't write the `.hi` file if there are deferred errors, since we won't get -- accurate diagnostics next time if we do @@ -1327,21 +1362,21 @@ getLinkableRule recorder = return (versionBS <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash <*> pure versionBS)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH -getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) +getLinkableType :: ProjectHaskellInput -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) -needsCompilationRule file - | "boot" `isSuffixOf` fromNormalizedFilePath file = +needsCompilationRule :: ProjectHaskellInput -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule input + | "boot" `isSuffixOf` fromNormalizedFilePath (inputFilePath input) = pure (Just $ encodeLinkableType Nothing, Just Nothing) -needsCompilationRule file = do - graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file +needsCompilationRule input = do + graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph input 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 input 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 input 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 @@ -1463,13 +1498,16 @@ mainRule recorder RulesConfig{..} = do -- | 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 :: SomeHaskellInput -> Action (Maybe HieFile) +getHieFile input = runMaybeT $ do + projectInput <- MaybeT $ pure $ case input of + SomeProjectHaskellInput fp -> Just fp + _ -> Nothing + HAR {hieAst} <- MaybeT $ use GetHieAst input + tmr <- MaybeT $ use TypeCheck projectInput + ghc <- MaybeT $ use GhcSession projectInput + msr <- MaybeT $ use GetModSummaryWithoutTimestamps projectInput + source <- lift $ getSourceFileSource (SomeFileHaskellInput 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 42193f13aa..5e9544b1f8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -132,6 +132,7 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Types.Options as Options import qualified Language.LSP.Protocol.Message as LSP @@ -209,6 +210,7 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] + | LogUnsafeDependencyRule !NormalizedFilePath !T.Text deriving Show instance Pretty Log where @@ -251,7 +253,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. @@ -301,7 +308,7 @@ data ShakeExtras = ShakeExtras -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens + ,semanticTokensCache:: STM.Map SomeHaskellInput SemanticTokens -- ^ Cache of last response of semantic tokens for each file, -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). -- putting semantic tokens cache and id in shakeExtras might not be ideal @@ -356,7 +363,7 @@ type WithProgressFunc = forall a. type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32)) +type GetStalePersistent = SomeInput -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32)) getShakeExtras :: Action ShakeExtras getShakeExtras = do @@ -398,19 +405,22 @@ 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 v => k -> (RuleInput k -> 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) + let getVal' input = case fromInput input of + Nothing -> pure Nothing + Just ruleInput -> fmap (fmap (first3 toDyn)) $ getVal ruleInput + void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) getVal' class Typeable a => IsIdeGlobal a where -- | Read a virtual file from the current snapshot -getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) -getVirtualFile nf = do +getVirtualFile :: SomeFileInput -> Action (Maybe VirtualFile) +getVirtualFile input = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras pure $! -- Don't leak a reference to the entire map - getVirtualFileFromVFS (VFS vfs) $ filePathToUri' nf + getVirtualFileFromVFS (VFS vfs) (filePathToUri' (inputFilePath input)) -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS @@ -469,8 +479,8 @@ getIdeOptionsIO ide = do -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) -lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do +lastValueIO :: IdeRule k v => ShakeExtras -> k -> RuleInput k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k input file = do let readPersistent | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests @@ -480,11 +490,11 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do mv <- runMaybeT $ do liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k) f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap - (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file + (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f (toInput input) MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> atomicallyNamed "lastValueIO 1" $ do - STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state + STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k input) state return Nothing Just (v,del,mbVer) -> do actual_version <- case mbVer of @@ -492,7 +502,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) `catch` (\(_ :: IOException) -> pure Nothing) atomicallyNamed "lastValueIO 2" $ do - STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state + STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k input) state Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics @@ -503,7 +513,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case + atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k input) state) >>= \case Nothing -> readPersistent Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> @@ -513,12 +523,18 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do Failed p | not p -> readPersistent _ -> pure Nothing +lastValueForInput :: forall k v. IdeRule k v => ShakeExtras -> k -> RuleInput k -> IO (Maybe (v, PositionMapping)) +lastValueForInput s k input = + case inputFingerprint input of + InputFile file -> lastValueIO s k input file + _ -> pure Nothing + -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) -lastValue key file = do +lastValue :: IdeRule k v => k -> RuleInput k -> Action (Maybe (v, PositionMapping)) +lastValue key input = do s <- getShakeExtras - liftIO $ lastValueIO s key file + liftIO $ lastValueForInput s key input mappingForVersion :: STM.Map NormalizedUri (EnumMap Int32 (a, PositionMapping)) @@ -533,6 +549,7 @@ mappingForVersion _ _ _ = pure zeroMapping type IdeRule k v = ( Shake.RuleResult k ~ v , Shake.ShakeValue k + , IsInput (RuleInput k) , Show v , Typeable v , NFData v @@ -601,25 +618,25 @@ shakeDatabaseProfileIO mbProfileDir = do setValues :: IdeRule k v => Values -> k - -> NormalizedFilePath + -> RuleInput k -> Value v -> Vector FileDiagnostic -> STM () -setValues state key file val diags = - STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key file) state +setValues state key input val diags = + STM.insert (ValueWithDiagnostics (fmap toDyn val) diags) (toKey key input) state -- | Delete the value stored for a given ide build key -- and return the key that was deleted. deleteValue - :: Shake.ShakeValue k + :: (Shake.ShakeValue k, IsInput (RuleInput k)) => ShakeExtras -> k - -> NormalizedFilePath + -> RuleInput k -> STM [Key] -deleteValue ShakeExtras{state} key file = do - STM.delete (toKey key file) state - return [toKey key file] +deleteValue ShakeExtras{state} key input = do + STM.delete (toKey key input) state + return [toKey key input] -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. @@ -628,10 +645,10 @@ getValues :: IdeRule k v => Values -> k -> - NormalizedFilePath -> + RuleInput k -> STM (Maybe (Value v, Vector FileDiagnostic)) -getValues state key file = do - STM.lookup (toKey key file) state >>= \case +getValues state key input = do + STM.lookup (toKey key input) state >>= \case Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let !r = seqValue $ fmap (fromJust . fromDynamic @v) v @@ -1016,7 +1033,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do return garbage where - showKey = show . Q + showKey (kt, input) = show (Q kt input) removeDirtyKey dk values st@(!counter, keys) (k, age) | age > maxAge , Just (kt,_) <- fromKeyType k @@ -1055,23 +1072,23 @@ preservedKeys checkParents = HSet.fromList $ -- | Define a new Rule without early cutoff define :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () + => Recorder (WithPriority Log) -> (k -> RuleInput k -> Action (IdeResult v)) -> Rules () define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v defineNoDiagnostics :: IdeRule k v - => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () + => Recorder (WithPriority Log) -> (k -> RuleInput k -> Action (Maybe v)) -> Rules () defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available -use :: IdeRule k v - => k -> NormalizedFilePath -> Action (Maybe v) -use key file = runIdentity <$> uses key (Identity file) +use :: (IdeRule k v) + => k -> RuleInput k -> 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 v) + => k -> RuleInput k -> 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. @@ -1080,9 +1097,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 v) + => k -> RuleInput k -> Action (v, PositionMapping) +useWithStale_ key input = runIdentity <$> usesWithStale_ key (Identity input) -- |Plural version of 'useWithStale_' -- @@ -1090,9 +1107,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 v) => k -> f (RuleInput k) -> 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 @@ -1121,27 +1138,31 @@ 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 v) => k -> RuleInput k -> 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 v) => k -> RuleInput k -> IdeAction (FastResult v) +useWithStaleFast' key input = do + let inputLabel = case inputFingerprint input of + InputFile file -> fromNormalizedFilePath file + InputNoFile -> "" + InputValue{} -> show 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 ++ ":" ++ inputLabel) 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 <- lastValueForInput s key input case res of Nothing -> do a <- waitValue @@ -1149,11 +1170,12 @@ 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 <- lastValueForInput s key input pure $ FastResult res waitValue useNoFile :: IdeRule k v => k -> Action (Maybe v) -useNoFile key = use key emptyFilePath +useNoFile key = + (\(Identity (A value)) -> currentValue value) <$> apply (Identity (Q key (toInput NoInput))) -- Requests a rule if available. -- @@ -1161,11 +1183,13 @@ 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 v => k -> RuleInput k -> Action v +use_ key input = runIdentity <$> uses_ key (Identity input) useNoFile_ :: IdeRule k v => k -> Action v -useNoFile_ key = use_ key emptyFilePath +useNoFile_ key = useNoFile key >>= \case + Just v -> return v + Nothing -> liftIO $ throwIO $ BadDependency (show key) -- |Plural version of `use_` -- @@ -1173,100 +1197,120 @@ 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 v) => k -> f (RuleInput k) -> 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) + => k -> f (RuleInput k) -> Action (f (Maybe v)) +uses key inputs = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q key . toInput) 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) + => k -> f (RuleInput k) -> Action (f (Maybe (v, PositionMapping))) +usesWithStale key inputs = do + _ <- apply (fmap (Q key . toInput) 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 + :: forall k v k1. (IdeRule k v, IdeRule k1 Fingerprint, RuleInput k ~ NoInput) + => k1 -> k -> RuleInput k1 -> Action (Maybe v) +useWithSeparateFingerprintRule fingerKey key input = do + _ <- use fingerKey input + useWithoutDependency key NoInput -- 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 + :: forall k v k1. (IdeRule k v, IdeRule k1 Fingerprint, RuleInput k ~ NoInput) + => k1 -> k -> RuleInput k1 -> 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 :: forall k v. (IdeRule k v) + => k -> RuleInput k -> Action (Maybe v) +useWithoutDependency key input = + (\(Identity (A value)) -> currentValue value) <$> applyWithoutDependency (Identity (Q key (toInput input))) data RuleBody k v - = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) - | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) + = Rule (k -> RuleInput k -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleNoDiagnostics (k -> RuleInput k -> Action (Maybe BS.ByteString, Maybe v)) | RuleWithCustomNewnessCheck { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool - , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) + , build :: k -> RuleInput k -> Action (Maybe BS.ByteString, Maybe v) } - | RuleWithOldValue (k -> NormalizedFilePath -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) + | RuleWithOldValue (k -> RuleInput k -> Value v -> Action (Maybe BS.ByteString, IdeResult v)) -- | Define a new Rule with early cutoff defineEarlyCutoff - :: IdeRule k v + :: forall k v. IdeRule k v => Recorder (WithPriority Log) -> RuleBody k 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 -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 -defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = - addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> - otTracedAction key file mode traceA $ \ traceDiagnostics -> do +defineEarlyCutoff recorder (Rule op) = addRule $ \(Q key input) (old :: Maybe BS.ByteString) mode -> + case fromInput input :: Maybe (RuleInput k) of + Nothing -> fail "invalid rule input" + Just ruleInput -> do + case inputFingerprint input of + InputFile file -> + otTracedAction key input mode traceA $ \traceDiagnostics -> do + extras <- getShakeExtras + let diagnostics ver diags = do + traceDiagnostics diags + updateFileDiagnostics recorder (toSomeFileInput file) ver (newKey key) extras diags + defineEarlyCutoff' diagnostics (==) key ruleInput old mode $ const $ op key ruleInput + _ -> fail "expected file input" +defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q key input) (old :: Maybe BS.ByteString) mode -> + case fromInput input :: Maybe (RuleInput k) of + Nothing -> fail "invalid rule input" + Just ruleInput -> do + otTracedAction key input mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do traceDiagnostics diags - mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags - defineEarlyCutoff' diagnostics newnessCheck key file old mode $ - const $ second (mempty,) <$> build key file -defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do - 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 - -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" - -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" + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags + defineEarlyCutoff' diagnostics (==) key ruleInput old mode $ const $ second (mempty,) <$> op key ruleInput +defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = + addRule $ \(Q key input) (old :: Maybe BS.ByteString) mode -> + case fromInput input :: Maybe (RuleInput k) of + Nothing -> fail "invalid rule input" + Just ruleInput -> do + otTracedAction key input mode traceA $ \ traceDiagnostics -> do + let diagnostics _ver diags = do + traceDiagnostics diags + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags + defineEarlyCutoff' diagnostics newnessCheck key ruleInput old mode $ + const $ second (mempty,) <$> build key ruleInput +defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q key input) (old :: Maybe BS.ByteString) mode -> + case fromInput input :: Maybe (RuleInput k) of + Nothing -> fail "invalid rule input" + Just ruleInput -> do + case inputFingerprint input of + InputFile file -> + otTracedAction key input mode traceA $ \traceDiagnostics -> do + extras <- getShakeExtras + let diagnostics ver diags = do + traceDiagnostics diags + updateFileDiagnostics recorder (toSomeFileInput file) ver (newKey key) extras diags + defineEarlyCutoff' diagnostics (==) key ruleInput old mode $ op key ruleInput + _ -> fail "expected file input" + +defineNoFile :: (IdeRule k v, RuleInput k ~ NoInput ) => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () +defineNoFile recorder f = defineNoDiagnostics recorder $ \k NoInput -> do + res <- f k + return (Just res) +defineEarlyCutOffNoFile :: (IdeRule k v, RuleInput k ~ NoInput) => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k NoInput -> do + (hashString, res) <- f k + return (Just hashString, Just res) defineEarlyCutoff' :: forall k v. IdeRule k v @@ -1274,24 +1318,29 @@ defineEarlyCutoff' -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k - -> NormalizedFilePath + -> RuleInput k -> 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 mbFile = case inputFingerprint input of + InputFile file -> Just file + _ -> Nothing + 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 + (case inputFingerprint input of + InputFile file | not (optSkipProgress options key) -> trans (inProgress progress (toSomeFileInput file)) + _ -> id) $ 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 @@ -1302,17 +1351,28 @@ 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 (prettyRuleAbortedByException key file e) | not $ isBadDependency e],Nothing)) - - ver <- estimateFileVersionUnsafely key mbRes file + let doAction = + actionCatch + (do v <- action staleV; liftIO $ evaluate $ force v) $ + \(e :: SomeException) -> do + let file = case inputFingerprint input of + InputFile file -> file + _ -> emptyFilePath + pure (Nothing, ([ideErrorText file (prettyRuleAbortedByException key input e) | not $ isBadDependency e], Nothing)) + (mbBs, (diags, mbRes)) <- case mbFile of + Just file + | isDependencyHaskellPath file + , not (isSafeDependencyRule key) -> do + logWith shakeRecorder Error (LogUnsafeDependencyRule file (T.pack (show key))) + doAction + _ -> doAction + + ver <- estimateFileVersionUnsafely key mbRes input (bs, res) <- case mbRes of Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) @@ -1330,8 +1390,8 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do (A res) $ do -- this hook needs to be run in the same transaction as the key is marked clean -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] - setValues state key file res (Vector.fromList diags) - modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + setValues state key input res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key input) return res where -- Highly unsafe helper to compute the version of a file @@ -1340,26 +1400,29 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do estimateFileVersionUnsafely :: k -> Maybe v - -> NormalizedFilePath + -> RuleInput k -> Action (Maybe FileVersion) - estimateFileVersionUnsafely _k v fp - | fp == 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 - | Just Refl <- eqT @k @IsFileOfInterest = pure Nothing - -- GetFileExists gets called for missing files - | Just Refl <- eqT @k @GetFileExists = pure Nothing - -- 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 - - prettyRuleAbortedByException key file e = T.pack $ unlines $ + estimateFileVersionUnsafely _k v input = + case inputFingerprint input of + InputFile file + | Just Refl <- eqT @k @GetModificationTime -> pure v + -- GetModificationTime depends on these rules, so avoid creating a cycle + | Just Refl <- eqT @k @AddWatchedFile -> pure Nothing + | Just Refl <- eqT @k @IsFileOfInterest -> pure Nothing + -- GetFileExists gets called for missing files + | Just Refl <- eqT @k @GetFileExists -> pure Nothing + -- 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) (toSomeFileInput file) + InputNoFile -> pure Nothing + InputValue{} -> pure Nothing + + prettyRuleAbortedByException key input e = T.pack $ unlines $ [ "Rule execution aborted due to exception" , "" , "Rule: " <> show key - , "Target: " <> fromNormalizedFilePath file + , "Input: " <> show input , "Message: " <> show e ] <> [ unlines @@ -1386,6 +1449,20 @@ prettyBuildSessionFinishException exc = case fromException exc of Just ctx -> pretty ctx Just AsyncCancelled -> viaShow AsyncCancelled -- We don't want to see the stack trace for a cancelled build session +isSafeDependencyRule :: forall k. Typeable k => 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 @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. @@ -1419,13 +1496,13 @@ traceA (A Succeeded{}) = "Success" updateFileDiagnostics :: MonadIO m => Recorder (WithPriority Log) - -> NormalizedFilePath + -> SomeFileInput -> Maybe Int32 -> Key -> ShakeExtras -> [FileDiagnostic] -- ^ current results -> m () -updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do +updateFileDiagnostics recorder input ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current @@ -1458,6 +1535,8 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) return action where + fp = inputFilePath input + diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c & L.relatedInformation ?~ @@ -1545,15 +1624,21 @@ updatePositionMappingHelper ver changes mappingForUri = snd $ -- | sends a signal whenever shake session is run/restarted -- being used in cabal and hlint plugin tests to know when its time -- to look for file diagnostics -kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action () +kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [SomeInput] -> Proxy s -> Action () kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ - toJSON $ map fromNormalizedFilePath files + toJSON $ mapMaybe inputFile files + where + inputFile input = + case inputFingerprint input of + InputFile file -> Just $ fromNormalizedFilePath file + _ -> Nothing -- | 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 v) => Proxy s0 -> Proxy s1 -> [RuleInput k] -> k -> Action () +runWithSignal msgStart msgEnd input rule = do + let inputs = map toInput input ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras - kickSignal testing lspEnv files msgStart - void $ uses rule files - kickSignal testing lspEnv files msgEnd + kickSignal testing lspEnv inputs msgStart + void $ uses rule input + kickSignal testing lspEnv inputs msgEnd diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 34839faaee..f82a3e824a 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -21,6 +21,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Word (Word16) import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Core.RuleInput import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule import Development.IDE.Types.Diagnostics (FileDiagnostic, @@ -28,13 +29,9 @@ import Development.IDE.Types.Diagnostics (FileDiagnostic, import Development.IDE.Types.Location (Uri (..)) import Ide.Logger import Ide.Types (PluginId (..)) -import Language.LSP.Protocol.Types (NormalizedFilePath, - fromNormalizedFilePath) import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, beginSpan, endSpan, setTag, withSpan) - - withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act | userTracingEnabled @@ -91,7 +88,7 @@ otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) otTracedAction :: Show k => k -- ^ The Action's Key - -> NormalizedFilePath -- ^ Path to the file the action was run for + -> SomeInput -- ^ Path to the file the action was run for -> RunMode -> (a -> String) -> (([FileDiagnostic] -> Action ()) -> Action (RunResult a)) -- ^ The action @@ -101,7 +98,7 @@ otTracedAction key file mode result act generalBracket (do sp <- beginSpan (fromString (show key)) - setTag sp "File" (fromString $ fromNormalizedFilePath file) + setTag sp "File" (fromString $ show file) setTag sp "Mode" (fromString $ show mode) return sp ) @@ -139,4 +136,3 @@ otTracedProvider (PluginId pluginName) provider act setTag sp "plugin" (encodeUtf8 pluginName) runInIO act | otherwise = act - diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index 498ea44bee..6f5d007f41 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/ghcide/src/Development/IDE/Core/UseStale.hs @@ -33,6 +33,7 @@ import Development.IDE (Action, IdeRule, rangeToRealSrcSpan, realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as IDE import Development.IDE.GHC.Compat (RealSrcSpan, srcSpanFile) import Development.IDE.GHC.Compat.Util (unpackFS) @@ -144,7 +145,7 @@ 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)) + => k -> RuleInput k -> Action (Maybe (TrackedStale v)) useWithStale key file = do x <- IDE.useWithStale key file pure $ x <&> \(v, pm) -> @@ -153,7 +154,7 @@ 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) + => k -> RuleInput k -> 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/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index 9a4512be86..e82e4abbf7 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs @@ -16,7 +16,6 @@ module Development.IDE.Import.DependencyInformation , PathIdMap (..) , emptyPathIdMap , getPathId - , lookupPathToId , insertImport , pathToId , idToPath @@ -49,6 +48,7 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Tuple.Extra hiding (first, second) +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util (Fingerprint) import qualified Development.IDE.GHC.Compat.Util as Util @@ -82,7 +82,7 @@ type FilePathIdSet = IntSet data PathIdMap = PathIdMap { idToPathMap :: !(FilePathIdMap ArtifactsLocation) - , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId) + , pathToIdMap :: !(HashMap ProjectHaskellInput FilePathId) , nextFreshId :: !Int } deriving (Show, Generic) @@ -94,29 +94,28 @@ emptyPathIdMap = PathIdMap IntMap.empty HMS.empty 0 getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap) getPathId path m@PathIdMap{..} = - case HMS.lookup (artifactFilePath path) pathToIdMap of + case HMS.lookup input pathToIdMap of Nothing -> let !newId = FilePathId nextFreshId in (newId, insertPathId newId ) Just fileId -> (fileId, m) where + input = artifactFilePath path + insertPathId :: FilePathId -> PathIdMap insertPathId fileId = PathIdMap (IntMap.insert (getFilePathId fileId) path idToPathMap) - (HMS.insert (artifactFilePath path) fileId pathToIdMap) + (HMS.insert input fileId pathToIdMap) (succ nextFreshId) insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } -pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId +pathToId :: PathIdMap -> ProjectHaskellInput -> Maybe FilePathId pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path -lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId -lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap - -idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath +idToPath :: PathIdMap -> FilePathId -> ProjectHaskellInput idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation @@ -163,10 +162,10 @@ data DependencyInformation = -- ^ Map from FilePathId to the fingerprint of the immediate reverse dependencies of the module. } deriving (Show, Generic) -lookupFingerprint :: NormalizedFilePath -> DependencyInformation -> FilePathIdMap Fingerprint -> Maybe Fingerprint +lookupFingerprint :: ProjectHaskellInput -> DependencyInformation -> FilePathIdMap Fingerprint -> Maybe Fingerprint lookupFingerprint fileId DependencyInformation {..} depFingerprintMap = do - FilePathId cur_id <- lookupPathToId depPathIdMap fileId + FilePathId cur_id <- pathToId depPathIdMap fileId IntMap.lookup cur_id depFingerprintMap newtype ShowableModule = @@ -183,7 +182,7 @@ instance NFData a => NFData (ShowableModuleEnv a) where instance Show ShowableModule where show = moduleNameString . moduleName . showableModule -reachableModules :: DependencyInformation -> [NormalizedFilePath] +reachableModules :: DependencyInformation -> [ProjectHaskellInput] reachableModules DependencyInformation{..} = map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps @@ -360,9 +359,9 @@ partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest partitionSCC [] = ([], []) -- | Transitive reverse dependencies of a file -transitiveReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] +transitiveReverseDependencies :: ProjectHaskellInput -> DependencyInformation -> Maybe [ProjectHaskellInput] transitiveReverseDependencies file DependencyInformation{..} = do - FilePathId cur_id <- lookupPathToId depPathIdMap file + FilePathId cur_id <- pathToId depPathIdMap file return $ map (idToPath depPathIdMap . FilePathId) (IntSet.toList (go cur_id IntSet.empty)) where go :: Int -> IntSet -> IntSet @@ -373,13 +372,13 @@ transitiveReverseDependencies file DependencyInformation{..} = do in IntSet.foldr go visited' new -- | Immediate reverse dependencies of a file -immediateReverseDependencies :: NormalizedFilePath -> DependencyInformation -> Maybe [NormalizedFilePath] +immediateReverseDependencies :: ProjectHaskellInput -> DependencyInformation -> Maybe [ProjectHaskellInput] immediateReverseDependencies file DependencyInformation{..} = do - FilePathId cur_id <- lookupPathToId depPathIdMap file + FilePathId cur_id <- pathToId depPathIdMap file return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps)) -- | returns all transitive dependencies in topological order. -transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies +transitiveDeps :: DependencyInformation -> ProjectHaskellInput -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do !fileId <- pathToId depPathIdMap file reachableVs <- @@ -404,12 +403,12 @@ transitiveDeps DependencyInformation{..} file = do vs = topSort g -lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath +lookupModuleFile :: Module -> DependencyInformation -> Maybe ProjectHaskellInput lookupModuleFile mod DependencyInformation{..} = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod newtype TransitiveDependencies = TransitiveDependencies - { transitiveModuleDeps :: [NormalizedFilePath] + { transitiveModuleDeps :: [ProjectHaskellInput] -- ^ Transitive module dependencies in topological order. -- The module itself is not included. } deriving (Eq, Show, Generic) @@ -417,7 +416,7 @@ newtype TransitiveDependencies = TransitiveDependencies instance NFData TransitiveDependencies data NamedModuleDep = NamedModuleDep { - nmdFilePath :: !NormalizedFilePath, + nmdFilePath :: !ProjectHaskellInput, nmdModuleName :: !ModuleName, nmdModLocation :: !(Maybe ModLocation) } diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 4d4e0e7e20..4b47a98dd7 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -26,6 +26,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as S +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () @@ -50,7 +51,7 @@ data Import deriving (Show) data ArtifactsLocation = ArtifactsLocation - { artifactFilePath :: !NormalizedFilePath + { artifactFilePath :: !ProjectHaskellInput , artifactModLocation :: !(Maybe ModLocation) , artifactIsSource :: !Bool -- ^ 'True' for a real Haskell source file ('HsSrcFile'); -- 'False' for a boot ('HsBootFile') or signature ('HsigFile') file. @@ -67,13 +68,14 @@ instance NFData Import where rnf (FileImport x) = rnf x rnf PackageImport = () -modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mbMod +modSummaryToArtifactsLocation :: ProjectHaskellInput -> Maybe ModSummary -> ArtifactsLocation +modSummaryToArtifactsLocation input ms = ArtifactsLocation input (ms_location <$> ms) source mbMod where + file = inputFilePath input isSource HsSrcFile = True isSource _ = False source = case ms of - Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp + Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath file Just modSum -> isSource (ms_hsc_src modSum) mbMod = ms_mod <$> ms @@ -237,11 +239,14 @@ locateModule moduleMaps env unit_visibility modName mbPkgName isSource = do hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units - toModLocation uid file = liftIO $ do - loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) - let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes - loc' = if isSource then addBootSuffixLocnOut loc else loc - return $ Right $ FileImport $ ArtifactsLocation file (Just loc') (not isSource) (Just genMod) + toModLocation uid file = + case toProjectHaskellInput file of + Nothing -> moduleNotFound + Just input -> liftIO $ do + loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath (inputFilePath input)) + let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes + loc' = if isSource then addBootSuffixLocnOut loc else loc + return $ Right $ FileImport $ ArtifactsLocation input (Just loc') (not isSource) (Just genMod) lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 0ba6e22530..7f6d925a6d 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -20,10 +20,12 @@ import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Rules as Shake import Development.IDE.Core.Shake (IdeAction, IdeState (..), runIdeAction) import Development.IDE.Types.Location +import GHC.Iface.Ext.Types (Identifier) import Ide.Logger import Ide.Plugin.Error import Ide.Types @@ -50,17 +52,19 @@ hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPos gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation) documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) -gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst) -gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) -hover = request "Hover" getAtPoint (InR Null) foundHover -documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL +gotoDefinition = request "Definition" toSomeHaskellInput getDefinition (InR (InR Null)) (InL . Definition . InR . map fst) +gotoTypeDefinition = request "TypeDefinition" toSomeHaskellInput getTypeDefinition (InR (InR Null)) (InL . Definition . InR . map fst) +gotoImplementation = request "Implementation" toSomeHaskellInput getImplementationDefinition (InR (InR Null)) (InL . Definition . InR) +hover = request "Hover" toSomeHaskellInput getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" toSomeHaskellInput highlightAtPoint (InR Null) InL references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do nfp <- getNormalizedFilePathE uri liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp - InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) + case toSomeHaskellInput nfp of + Nothing -> pure $ InL [] + Just input -> InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint input pos) wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do @@ -73,22 +77,22 @@ foundHover (mbRange, contents) = -- | Respond to and log a hover or go-to-definition request request - :: T.Text - -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) + :: IsFileInput input => T.Text + -> (NormalizedFilePath -> Maybe input) + -> (input -> Position -> IdeAction (Maybe a)) -> b -> (a -> b) -> Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) b -request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do - mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest recorder label getResults ide pos path - Nothing -> pure Nothing +request label classify getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do + mbResult <- case uriToNormalizedFilePath (toNormalizedUri uri) >>= classify of + Just input -> logAndRunRequest recorder label getResults ide pos input + Nothing -> pure Nothing pure $ maybe notFound found mbResult -logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b -logAndRunRequest recorder label getResults ide pos path = do - let filePath = toNormalizedFilePath' path - logWith recorder Debug $ LogRequest label pos filePath - runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) +logAndRunRequest :: IsFileInput input => Recorder (WithPriority Log) -> T.Text -> (input -> Position -> IdeAction (Maybe a)) -> IdeState -> Position -> input -> IO (Maybe a) +logAndRunRequest recorder label getResults ide pos input = do + logWith recorder Debug $ LogRequest label pos (inputFilePath input) + runIdeAction (T.unpack label) (shakeExtras ide) (getResults input pos) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 079fa79cdd..3f71b736a0 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -31,6 +31,7 @@ import Development.IDE.Core.FileStore (registerFileWatches, import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, LogShake) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake @@ -63,8 +64,8 @@ instance Pretty Log where LogWatchedFileEvents msg -> "Watched file events:" <+> pretty msg LogWarnNoWatchedFilesSupport -> "Client does not support watched files. Falling back to OS polling" -whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () -whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' +whenUriFile :: Uri -> (SomeHaskellInput -> IO ()) -> IO () +whenUriFile uri act = whenJust (LSP.uriToFilePath uri >>= toSomeHaskellInput . toNormalizedFilePath') act descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificationHandlers = mconcat @@ -72,28 +73,37 @@ 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 action = addFileOfInterest ide file Modified{firstOpen=True} -- 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 $ do - -- An unsaved file is not on disk, so the session loader never saw - -- it. Register it so imports of it can be resolved. - ks <- updateKnownTargets (shakeExtras ide) [file] [] - (<> ks) <$> addFileOfInterest ide file Modified{firstOpen=True} + let action' = do + ks <- updateKnownTargets (shakeExtras ide) [inputFilePath file] [] + (<> ks) <$> action + case file of + SomeProjectHaskellInput projectFile -> + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False projectFile action' + SomeNonProjectHaskellInput _ -> void (addFileOfInterest ide file ReadOnly) 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 action = addFileOfInterest ide file Modified{firstOpen=False} + case file of + SomeProjectHaskellInput projectFile -> + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False projectFile action + SomeNonProjectHaskellInput _ -> void (addFileOfInterest ide file ReadOnly) 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 action = addFileOfInterest ide file OnDisk + case file of + SomeProjectHaskellInput projectFile -> + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True projectFile action + SomeNonProjectHaskellInput _ -> void (addFileOfInterest ide file ReadOnly) logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ @@ -102,10 +112,10 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = "Closed text document: " <> getUri _uri -- A file that was only ever open in the editor stops existing -- when it is closed - onDisk <- doesFileExist (fromNormalizedFilePath file) + onDisk <- doesFileExist (fromNormalizedFilePath (inputFilePath file)) setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do scheduleGarbageCollection ide - ks <- updateKnownTargets (shakeExtras ide) [] [file | not onDisk] + ks <- updateKnownTargets (shakeExtras ide) [] [inputFilePath file | not onDisk] (<> ks) <$> deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri @@ -117,18 +127,20 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat -- filter also uris that do not map to filenames, since we cannot handle them filesOfInterest <- getFilesOfInterest ide let fileEvents' = - [ (nfp, event) | (FileEvent uri event) <- fileEvents + [ (input, event) | (FileEvent uri event) <- fileEvents , Just fp <- [uriToFilePath uri] , let nfp = toNormalizedFilePath fp - , not $ HM.member nfp filesOfInterest + , let input = toSomeFileInput nfp + , let haskellInput = toSomeHaskellInput nfp + , not $ maybe False (flip HM.member filesOfInterest) haskellInput ] unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) exts <- allExtensions <$> getIdeOptionsIO (shakeExtras ide) let sourceFiles c = - [ nfp | (nfp, c') <- fileEvents', c' == c - , takeExtension (fromNormalizedFilePath nfp) `elem` map ('.':) exts ] + [ inputFilePath input | (input, c') <- fileEvents', c' == c + , takeExtension (fromNormalizedFilePath (inputFilePath input)) `elem` map ('.':) exts ] setSomethingModified (VFSModified vfs) ide msg $ do ks1 <- resetFileStore ide fileEvents' ks2 <- modifyFileExists ide fileEvents' diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index cec445601c..5fbb13148c 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -8,12 +8,14 @@ module Development.IDE.LSP.Outline ) where +import Control.Monad.Except (runExcept) import Control.Monad.IO.Class import Data.Foldable (toList) import Data.Functor import Data.Generics hiding (Prefix) import Data.List.NonEmpty (nonEmpty) import Data.Maybe +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat @@ -27,16 +29,15 @@ import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL, InR), - uriToFilePath) + type (|?) (InL, InR)) moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol 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) + = liftIO $ case runExcept $ classifyAsProjectHaskell uri of + Right input -> do + mb_decls <- 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 } } @@ -63,7 +64,7 @@ moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdent InR (InL allSymbols) - Nothing -> pure $ InL [] + Left _ -> pure $ InL [] documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) @@ -266,4 +267,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..0014adae44 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -27,7 +27,8 @@ import qualified Data.HashMap.Strict as HashMap import Data.List.Extra (intercalate, isPrefixOf, nubOrd, partition) -import Data.Maybe (catMaybes, isJust) +import Data.Maybe (catMaybes, isJust, + mapMaybe) import qualified Data.Text as T import Development.IDE (Action, Priority (Debug), @@ -42,6 +43,7 @@ import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick, setFilesOfInterest) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), @@ -75,6 +77,7 @@ import Development.IDE.Session (SessionLoadingOptions retryOnSqliteBusy) import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, + fromNormalizedFilePath, toNormalizedFilePath') import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, @@ -434,11 +437,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) 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 (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles + let normalizedFiles = map toNormalizedFilePath' absoluteFiles + projectHaskellFiles = mapMaybe toProjectHaskellInput normalizedFiles + haskellFiles = mapMaybe toSomeHaskellInput normalizedFiles + typecheckFiles = map (fromNormalizedFilePath . inputFilePath) projectHaskellFiles + setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) ) haskellFiles + results <- runAction "User TypeCheck" ide $ uses TypeCheck projectHaskellFiles + _results <- runAction "GetHie" ide $ uses GetHieAst haskellFiles + _results <- runAction "GenerateCore" ide $ uses GenerateCore projectHaskellFiles + let (worked, failed) = partition fst $ zip (map isJust results) typecheckFiles 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..0236514054 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) import Control.Lens ((&), (.~), (?~)) +import Control.Monad.Except (runExcept) import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT (ExceptT), withExceptT) @@ -22,6 +23,7 @@ import Development.IDE.Core.Compile import Development.IDE.Core.FileStore (getUriContents) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log, @@ -84,11 +86,12 @@ 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 srcPath = inputFilePath file + fileUri = fromNormalizedUri $ normalizedFilePathToUri srcPath mbPm <- useWithStale GetParsedModule file case mbPm of Just (pm, _) -> do - let cdata = localCompletionsForParsedModule uri pm + let cdata = localCompletionsForParsedModule fileUri pm return ([], Just cdata) _ -> return ([], Nothing) define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> 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 $ inputFilePath file let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports return ([], Just cdata) (_diag, _) -> @@ -126,13 +129,13 @@ dropListFromImportDecl iDecl = let resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_CompletionItemResolve resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = do - file <- getNormalizedFilePathE uri + projectInput <- withExceptT (const PluginStaleResolve) $ classifyAsProjectHaskell uri (sess,_) <- withExceptT (const PluginStaleResolve) $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) - $ useWithStaleFastE GhcSessionDeps file + $ useWithStaleFastE GhcSessionDeps projectInput 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 projectInput let (dm,km) = case mdkm of Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap) Nothing -> (mempty, mempty) @@ -167,52 +170,52 @@ getCompletionsLSP ide plId ,_context=completionContext} = ExceptT $ do contentsMaybe <- liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri - 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 + -- Completions are only available for project Haskell files. + fmap Right $ case (contentsMaybe, runExcept $ classifyAsProjectHaskell uri) of + (Just cnts, Right projectInput) -> do + (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + localCompls <- useWithStaleFast LocalCompletions projectInput + nonLocalCompls <- useWithStaleFast NonLocalCompletions projectInput + pm <- useWithStaleFast GetParsedModule projectInput + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings projectInput + 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 projectInput + 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 projectInput + astres <- case ms of + Just ms' | uses_overloaded_record_dot ms' + -> useWithStaleFast GetHieAst (SomeProjectHaskellInput projectInput) + _ -> 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..cd40b24713 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -9,29 +9,32 @@ module Development.IDE.Plugin.Completions.Types ( ) where import Control.DeepSeq -import qualified Data.Map as Map -import qualified Data.Text as T +import qualified Data.Map as Map +import qualified Data.Text as T import Data.Aeson import Data.Aeson.Types -import Data.Function (on) -import Data.Hashable (Hashable) -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) -import Data.String (IsString (..)) -import Data.Text (Text) +import Data.Function (on) +import Data.Hashable (Hashable) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat -import Development.IDE.Graph (RuleResult) -import Development.IDE.Spans.Common () -import GHC.Generics (Generic) -import qualified GHC.Types.Name.Occurrence as Occ +import Development.IDE.Graph (RuleResult) +import Development.IDE.Spans.Common () +import GHC.Generics (Generic) +import qualified GHC.Types.Name.Occurrence as Occ import Ide.Plugin.Properties -import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) -import qualified Language.LSP.Protocol.Types as J +import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Protocol.Types as J -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions +type instance RuleInput LocalCompletions = ProjectHaskellInput type instance RuleResult NonLocalCompletions = CachedCompletions +type instance RuleInput NonLocalCompletions = ProjectHaskellInput 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..e1f90e795b 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -14,7 +14,8 @@ module Development.IDE.Plugin.Test import Control.Concurrent (threadDelay) import qualified Control.Exception as E import Control.Monad -import Control.Monad.Except (ExceptT (..), throwError) +import Control.Monad.Except (ExceptT (..), runExcept, + throwError) import Control.Monad.IO.Class import Control.Monad.STM import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -30,6 +31,7 @@ import Data.Proxy import Data.String import Data.Text (Text, pack) import Development.IDE.Core.OfInterest (getFilesOfInterest) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake @@ -102,10 +104,12 @@ testRequestHandler _ (BlockSeconds secs) = do liftIO $ sleep secs 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 runExcept $ classifyAsProjectHaskell file of + Left err -> pure $ Left err + Right pHaskell -> do + sess <- runAction "Test - GhcSession" s $ use_ GhcSession pHaskell + 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) @@ -116,13 +120,13 @@ testRequestHandler s WaitForShakeQueue = liftIO $ do return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file - success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp + success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) (toSomeFileInput nfp) let res = WaitForIdeRuleResult <$> success return $ bimap PluginInvalidParams toJSON res testRequestHandler s (WaitForIdeRules k files) = liftIO $ do let nfps = fmap (fromUri . toNormalizedUri) files uniqueCount = Set.size (Set.fromList nfps) - act = runAction ("WaitForIdeRules " <> k <> " " <> show files) s $ parseActions (fromString k) nfps + act = runAction ("WaitForIdeRules " <> k <> " " <> show files) s $ parseActions (fromString k) (toSomeFileInput <$> nfps) success <- if uniqueCount > 0 then (setSessionLoaderPendingBarrier s uniqueCount >> act) @@ -150,7 +154,7 @@ testRequestHandler s GetStoredKeys = do return $ Right $ toJSON $ map show keys testRequestHandler s GetFilesOfInterest = do ff <- liftIO $ getFilesOfInterest s - return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff + return $ Right $ toJSON $ map (fromNormalizedFilePath . inputFilePath) $ HM.keys ff testRequestHandler s GetRebuildsCount = do count <- liftIO $ runAction "get build count" s getRebuildCount return $ Right $ toJSON count @@ -163,27 +167,51 @@ getDatabaseKeys field db = do step <- shakeGetBuildStep db 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 +withSingleProjectFile :: SomeFileInput -> (ProjectHaskellInput -> Action (Either Text Bool)) -> Action (Either Text Bool) +withSingleProjectFile (SomeFileHaskellInput (SomeProjectHaskellInput pFile)) action = action pFile +withSingleProjectFile _ _ = pure $ Right False + +withSingleHaskellFile :: SomeFileInput -> (SomeHaskellInput -> Action (Either Text Bool)) -> Action (Either Text Bool) +withSingleHaskellFile (SomeFileHaskellInput hFile) action = action hFile +withSingleHaskellFile _ _ = pure $ Right False + +parseAction :: CI String -> SomeFileInput -> Action (Either Text Bool) +parseAction "typecheck" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use TypeCheck pFile +parseAction "getLocatedImports" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GetLocatedImports pFile +parseAction "getmodsummary" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GetModSummary pFile +parseAction "getmodsummarywithouttimestamps" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GetModSummaryWithoutTimestamps pFile +parseAction "getparsedmodule" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GetParsedModule pFile +parseAction "ghcsession" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GhcSession pFile +parseAction "ghcsessiondeps" fp = withSingleProjectFile fp $ \pFile -> Right . isJust <$> use GhcSessionDeps pFile +parseAction "gethieast" fp = withSingleHaskellFile fp $ \hFile -> Right . isJust <$> use GetHieAst hFile parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents 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 +withProjectFile :: [SomeFileInput] -> ([ProjectHaskellInput] -> Action (Either Text [Bool])) -> Action (Either Text [Bool]) +withProjectFile fps action + | Just pFiles <- traverse projectFile fps = action pFiles + | otherwise = pure $ Right $ False <$ fps + where + projectFile (SomeFileHaskellInput (SomeProjectHaskellInput pFile)) = Just pFile + projectFile _ = Nothing + +withHaskellFile :: [SomeFileInput] -> ([SomeHaskellInput] -> Action (Either Text [Bool])) -> Action (Either Text [Bool]) +withHaskellFile fps action + | Just hFiles <- traverse haskellFile fps = action hFiles + | otherwise = pure $ Right $ False <$ fps + where + haskellFile (SomeFileHaskellInput hFile) = Just hFile + haskellFile _ = Nothing + +parseActions :: CI String -> [SomeFileInput] -> Action (Either Text [Bool]) +parseActions "typecheck" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses TypeCheck hFile +parseActions "getLocatedImports" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GetLocatedImports hFile +parseActions "getmodsummary" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GetModSummary hFile +parseActions "getmodsummarywithouttimestamps" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GetModSummaryWithoutTimestamps hFile +parseActions "getparsedmodule" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GetParsedModule hFile +parseActions "ghcsession" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GhcSession hFile +parseActions "ghcsessiondeps" fps = withProjectFile fps $ \hFile -> Right . fmap isJust <$> uses GhcSessionDeps hFile +parseActions "gethieast" fps = withHaskellFile fps $ \hFile -> Right . fmap isJust <$> uses GetHieAst hFile parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents fps parseActions other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index cad7fdc65a..93641efabe 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -42,6 +42,7 @@ import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentRange, toCurrentRange) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) import Development.IDE.Core.Service (getDiagnostics) @@ -154,11 +155,12 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif , Just newRange <- [toCurrentRange mp range]] if mode == Always || mode == Exported then do + projectFile <- classifyAsProjectHaskell uri -- In this mode we get the global bindings from the -- GlobalBindingTypeSigs rule. (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - $ useWithStaleE GetGlobalBindingTypeSigs nfp + $ useWithStaleE GetGlobalBindingTypeSigs projectFile -- Depending on whether we only want exported or not we filter our list -- of signatures to get what we want let relevantGlobalSigs = @@ -176,10 +178,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 + projectFile <- classifyAsProjectHaskell uri (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - $ useWithStaleE GetGlobalBindingTypeSigs nfp + $ useWithStaleE GetGlobalBindingTypeSigs projectFile -- 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 +312,7 @@ instance NFData GlobalBindingTypeSigsResult where rnf = rwhnf type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult +type instance RuleInput GetGlobalBindingTypeSigs = ProjectHaskellInput 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..db40585720 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -70,6 +70,7 @@ import Data.Tree import qualified Data.Tree as T import Data.Version (showVersion) import Development.IDE.Core.LookupMod (LookupModule, lookupMod) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (ShakeExtras (..), runIdeAction) import Development.IDE.Types.Shake (WithHieDb) @@ -98,7 +99,7 @@ import qualified Language.LSP.Protocol.Lens as L import System.Directory (doesFileExist) -- | HieFileResult for files of interest, along with the position mappings -newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) +newtype FOIReferences = FOIReferences (HM.HashMap SomeHaskellInput (HieAstResult, PositionMapping)) computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span] computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty @@ -115,7 +116,7 @@ computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty -- | Given a file and position, return the names at a point, the references for -- those names in the FOIs, and a list of file paths we already searched through foiReferencesAtPoint - :: NormalizedFilePath + :: SomeHaskellInput -> Position -> FOIReferences -> ([Name],[Location],[FilePath]) @@ -131,7 +132,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = (mapMaybe (\n -> M.lookup (Right n) rf) names) typerefs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation)) (mapMaybe (`M.lookup` tr) names) - in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) + in (names, adjustedLocs,map (fromNormalizedFilePath . inputFilePath) $ HM.keys asts) getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] getNamesAtPoint hf pos mapping = @@ -146,7 +147,7 @@ toCurrentLocation mapping (Location uri range) = referencesAtPoint :: MonadIO m => WithHieDb - -> NormalizedFilePath -- ^ The file the cursor is in + -> SomeHaskellInput -- ^ The file the cursor is in -> Position -- ^ position in the file -> FOIReferences -- ^ references data for FOIs -> m [Location] @@ -233,7 +234,7 @@ gotoDefinition => WithHieDb -> LookupModule m -> IdeOptions - -> M.Map ModuleName NormalizedFilePath + -> M.Map ModuleName SomeHaskellInput -> HieAstResult -> Position -> MaybeT m [(Location, Identifier)] @@ -258,12 +259,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 @@ -318,12 +319,21 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ | otherwise = do 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) + Just t -> prettyType (Just n) locationsMap t + 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 +353,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 +364,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 @@ -567,7 +590,7 @@ locationsAtPoint => WithHieDb -> LookupModule m -> IdeOptions - -> M.Map ModuleName NormalizedFilePath + -> M.Map ModuleName SomeHaskellInput -> Position -> HieAstResult -> m [(Location, Identifier)] @@ -575,7 +598,7 @@ locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports + modToLocation m = fmap (\fs -> pure (Location (inputUri fs) zeroRange)) $ M.lookup m imports in fmap (nubOrd . concat) $ mapMaybeM (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 96766c4e7c..5eca051b72 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -9,25 +9,29 @@ module Development.IDE.Spans.Pragmas , insertNewPragma , getFirstPragma ) where -import Control.Lens ((&), (.~)) -import Data.Bits (Bits (setBit)) -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import Data.Text (Text, pack) -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 Control.Lens ((&), (.~)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Data.Bits (Bits (setBit)) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Text (Text, pack) +import qualified Data.Text as T +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 (GhcSession (..), IdeState, + getFileContents, hscEnv, + runAction, srcSpanToRange) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput 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.Types (PluginId(..)) -import qualified Data.Text as T -import Development.IDE.Core.PluginUtils -import qualified Language.LSP.Protocol.Lens as L +import Ide.Plugin.Error (PluginError (..), + handleMaybe) +import Ide.Types (PluginId (..)) +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo getNextPragmaInfo dynFlags mbSource = @@ -50,10 +54,10 @@ insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit prag pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -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 +getFirstPragma :: MonadIO m => PluginId -> IdeState -> ProjectHaskellInput -> ExceptT PluginError m NextPragmaInfo +getFirstPragma (PluginId pId) state projectFile = do + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession projectFile + fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents ( SomeFileHaskellInput $ SomeProjectHaskellInput projectFile) 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 edfa72043d..4fb6ec9582 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -51,8 +51,9 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do update <$> Unique.newUnique -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: NormalizedFilePath -> HscEnv -> IO HscEnvEq -newHscEnvEq envRepresentative hscEnv' = do +newHscEnvEq :: NormalizedFilePath -> (HscEnv -> IO ()) -> HscEnv -> IO HscEnvEq +newHscEnvEq envRepresentative 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/ghcide/src/Development/IDE/Types/KnownTargets.hs b/ghcide/src/Development/IDE/Types/KnownTargets.hs index dabaaf04ca..c956e59288 100644 --- a/ghcide/src/Development/IDE/Types/KnownTargets.hs +++ b/ghcide/src/Development/IDE/Types/KnownTargets.hs @@ -16,6 +16,7 @@ import Data.HashMap.Strict import qualified Data.HashMap.Strict as HMap import Data.HashSet import qualified Data.HashSet as HSet +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat (ModuleName) import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location @@ -100,7 +101,7 @@ instance Hashable KnownTargets where emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets HMap.empty HSet.empty HSet.empty -data Target = TargetModule ModuleName | TargetFile NormalizedFilePath +data Target = TargetModule ModuleName | TargetFile ProjectHaskellInput deriving ( Eq, Ord, Generic, Show ) deriving anyclass (Hashable, NFData) diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index cc8f84e3b6..474f2489b7 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} @@ -23,12 +24,12 @@ import Data.Hashable import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes (FileVersion) import Development.IDE.Graph (Key, RuleResult, newKey, pattern Key) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location import GHC.Generics import HieDb.Types (HieDb) import qualified StmContainers.Map as STM @@ -75,31 +76,32 @@ isBadDependency x | Just (_ :: BadDependency) <- fromException x = True | otherwise = False -toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key -toKey = (newKey.) . curry Q +toKey :: (Shake.ShakeValue k, IsInput (RuleInput k)) => k -> RuleInput k -> Key +toKey k input = newKey (Q k (toInput input)) -fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) +fromKey :: Typeable k => Key -> Maybe (k, SomeInput) fromKey (Key k) - | Just (Q (k', f)) <- cast k = Just (k', f) + | Just (Q k' f) <- cast k = Just (k', f) | otherwise = Nothing -- | fromKeyType (Q (k,f)) = (typeOf k, f) -fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath) +fromKeyType :: Key -> Maybe (SomeTypeRep, SomeInput) fromKeyType (Key k) | App tc a <- typeOf k , Just HRefl <- tc `eqTypeRep` (typeRep @Q) - , Q (_, f) <- k + , Q _ f <- k = Just (SomeTypeRep a, f) | otherwise = Nothing -toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key -toNoFileKey k = newKey $ Q (k, emptyFilePath) +toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k, RuleInput k ~ NoInput ) => k -> Key +toNoFileKey k = newKey (Q k (toInput NoInput)) -newtype Q k = Q (k, NormalizedFilePath) - deriving newtype (Eq, Hashable, NFData) +data Q k = Q !k !SomeInput + deriving stock (Eq, Generic) + deriving anyclass (Hashable, NFData) instance Show k => Show (Q k) where - show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file + show (Q k input) = show k ++ "; " ++ show input -- | Invariant: the @v@ must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 703b5f9589..d70938012e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2116,6 +2116,7 @@ test-suite ghcide-tests , lsp-types , mtl , network-uri + , process , QuickCheck , random , regex-tdfa ^>=1.3.1 @@ -2151,6 +2152,7 @@ test-suite ghcide-tests CPPTests CradleTests DependentFileTest + Dependency DiagnosticTests EpsPollutionTests ExceptionTests diff --git a/hls-plugin-api/src/Ide/Plugin/Error.hs b/hls-plugin-api/src/Ide/Plugin/Error.hs index b323079aff..815e011bd1 100644 --- a/hls-plugin-api/src/Ide/Plugin/Error.hs +++ b/hls-plugin-api/src/Ide/Plugin/Error.hs @@ -66,6 +66,11 @@ data PluginError -- It will be logged with Warning and takes medium precedence (2) in being -- returned as a response to the client. | PluginInvalidParams T.Text + -- | Plugin received a request for an URI it doesn't support. + -- For example, in a haskell plugin, code actions were requested for non-haskell files. + -- + -- TODO: we should record the supported uri types + | PluginUnsupportedUriType Uri -- |PluginInvalidUserState should be thrown when a function that your plugin -- depends on fails. This should only be used when the function fails -- because the user's code is in an invalid state. @@ -109,31 +114,36 @@ instance Pretty PluginError where PluginStaleResolve -> "Stale Resolve" PluginRuleFailed rule -> "Rule Failed:" <+> pretty rule PluginInvalidParams text -> "Invalid Params:" <+> pretty text + PluginUnsupportedUriType uri -> "Unsupported URI type:" <+> + pretty (show uri) PluginInvalidUserState text -> "Invalid User State:" <+> pretty text PluginRequestRefused msg -> "Request Refused: " <+> pretty msg -- |Converts to ErrorCode used in LSP ResponseErrors toErrorCode :: PluginError -> (LSPErrorCodes |? ErrorCodes) -toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError -toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams -toErrorCode (PluginInvalidUserState _) = InL LSPErrorCodes_RequestFailed +toErrorCode (PluginInternalError _) = InR ErrorCodes_InternalError +toErrorCode (PluginInvalidParams _) = InR ErrorCodes_InvalidParams +-- TODO: should be a custom error code +toErrorCode (PluginUnsupportedUriType _) = InR ErrorCodes_InvalidParams +toErrorCode (PluginInvalidUserState _) = InL LSPErrorCodes_RequestFailed -- PluginRequestRefused should never be a argument to `toResponseError`, as -- it should be dealt with in `extensiblePlugins`, but this is here to make -- this function complete -toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound -toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed -toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified +toErrorCode (PluginRequestRefused _) = InR ErrorCodes_MethodNotFound +toErrorCode (PluginRuleFailed _) = InL LSPErrorCodes_RequestFailed +toErrorCode PluginStaleResolve = InL LSPErrorCodes_ContentModified -- |Converts to a logging priority. In addition to being used by the logger, -- `combineResponses` currently uses this to choose which response to return, -- so care should be taken in changing it. toPriority :: PluginError -> Priority -toPriority (PluginInternalError _) = Error -toPriority (PluginInvalidParams _) = Warning -toPriority (PluginInvalidUserState _) = Debug -toPriority (PluginRequestRefused _) = Debug -toPriority (PluginRuleFailed _) = Debug -toPriority PluginStaleResolve = Debug +toPriority (PluginInternalError _) = Error +toPriority (PluginInvalidParams _) = Warning +toPriority (PluginUnsupportedUriType _) = Warning +toPriority (PluginInvalidUserState _) = Debug +toPriority (PluginRequestRefused _) = Debug +toPriority (PluginRuleFailed _) = Debug +toPriority PluginStaleResolve = Debug handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 7abbbaae20..ef39eb4e29 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -42,6 +42,10 @@ module Ide.Types , PluginNotificationHandler(..), mkPluginNotificationHandler , PluginNotificationHandlers(..) , PluginRequestMethod(..) +, SourceFileOrigin(..) +, dependenciesDirectory +, hlsDirectory +, getSourceFileOrigin , getProcessID, getPid , getVirtualFileFromVFS , installSigUsr1Handler @@ -81,7 +85,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 @@ -106,6 +110,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) @@ -398,7 +403,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) @@ -488,7 +512,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..970fbb27b5 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 @@ -13,6 +13,7 @@ import Development.IDE (GetParsedModule (GetParsedMod define, realSrcSpanToRange, use) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (getSrcSpan) import Development.IDE.GHC.Util (getExtensions) @@ -52,6 +53,7 @@ data CollectLiterals = CollectLiterals instance Hashable CollectLiterals instance NFData CollectLiterals +type instance RuleInput CollectLiterals = ProjectHaskellInput type instance RuleResult CollectLiterals = CollectLiteralsResult data CollectLiteralsResult = CLR @@ -70,8 +72,8 @@ instance Show CollectLiteralsResult where instance NFData CollectLiteralsResult collectLiteralsRule :: Recorder (WithPriority Log) -> Rules () -collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do - pm <- use GetParsedModule nfp +collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals input -> do + pm <- use GetParsedModule input -- get the current extensions active and transform them into FormatTypes let exts = map GhcExtension . getExtensions <$> pm -- collect all the literals for a file @@ -81,25 +83,25 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do - nfp <- getNormalizedFilePathE (docId ^. L.uri) - CLR{..} <- requestLiterals pId state nfp - pragma <- getFirstPragma pId state nfp + input <- classifyAsProjectHaskell (docId ^. L.uri) + CLR{..} <- requestLiterals pId state input + pragma <- getFirstPragma pId state input -- remove any invalid literals (see validTarget comment) let litsInRange = RangeMap.filterByRange currRange literals -- generate alternateFormats and zip with the literal that generated the alternates literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange -- make a code action for every literal and its' alternates (then flatten the result) - actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs + actions = concatMap (\(lit, alts) -> map (mkCodeAction input lit enabledExtensions pragma) alts) literalPairs pure $ InL actions where - mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction - mkCodeAction nfp lit enabled npi af@(alt, ExtensionNeeded exts) = InR CodeAction { + mkCodeAction :: ProjectHaskellInput -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction + mkCodeAction input lit enabled npi af@(alt, ExtensionNeeded exts) = InR CodeAction { _title = mkCodeActionTitle lit af enabled , _kind = Just $ CodeActionKind_Custom "quickfix.literals.style" , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ mkWorkspaceEdit nfp edits + , _edit = Just $ mkWorkspaceEdit input edits , _command = Nothing , _data_ = Nothing } @@ -109,10 +111,10 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do ext': exts -> [insertNewPragma npi ext' | needsExtension enabled ext'] <> pragmaEdit exts [] -> [] - mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit - mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing + mkWorkspaceEdit :: ProjectHaskellInput -> [TextEdit] -> WorkspaceEdit + mkWorkspaceEdit input edits = WorkspaceEdit changes Nothing Nothing where - changes = Just $ Map.singleton (filePathToUri $ fromNormalizedFilePath nfp) edits + changes = Just $ Map.singleton (inputUri input) edits mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text mkCodeActionTitle lit (alt, ExtensionNeeded exts) ghcExts @@ -128,7 +130,7 @@ mkCodeActionTitle lit (alt, ExtensionNeeded exts) ghcExts needsExtension :: [GhcExtension] -> Extension -> Bool needsExtension ghcExts ext = ext `notElem` map unExt ghcExts -requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult +requestLiterals :: MonadIO m => PluginId -> IdeState -> ProjectHaskellInput -> ExceptT PluginError m CollectLiteralsResult requestLiterals (PluginId pId) state = runActionE (unpack pId <> ".CollectLiterals") state . useE CollectLiterals diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index dadc5503fc..22f983e410 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -19,6 +19,7 @@ import qualified Data.Text as T import Development.IDE as D import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (restartShakeSession) import Development.IDE.Graph (Key) import Development.IDE.LSP.HoverDefinition (foundHover) @@ -48,7 +49,6 @@ import qualified Ide.Plugin.Cabal.OfInterest as OfInterest import Ide.Plugin.Cabal.Orphans () import Ide.Plugin.Cabal.Outline import qualified Ide.Plugin.Cabal.Rules as Rules -import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL import qualified Language.LSP.Protocol.Message as LSP @@ -59,14 +59,14 @@ import qualified Text.Fuzzy.Parallel as Fuzzy import Text.Regex.TDFA data Log - = LogModificationTime NormalizedFilePath FileVersion + = LogModificationTime CabalInput FileVersion | LogRule Rules.Log | LogOfInterest OfInterest.Log | LogDocOpened Uri | LogDocModified Uri | LogDocSaved Uri | LogDocClosed Uri - | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogFOI (HashMap CabalInput FileOfInterestStatus) | LogCompletionContext Types.Context Position | LogCompletions Types.Log | LogCabalAdd CabalAdd.Log @@ -77,7 +77,7 @@ instance Pretty Log where LogRule log' -> pretty log' LogOfInterest log' -> pretty log' LogModificationTime nfp modTime -> - "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) + "Modified:" <+> pretty (fromNormalizedFilePath (inputFilePath nfp)) <+> pretty (show modTime) LogDocOpened uri -> "Opened text document:" <+> pretty (getUri uri) LogDocModified uri -> @@ -166,8 +166,12 @@ descriptor recorder plId = ruleRecorder = cmapWithPrio LogRule recorder ofInterestRecorder = cmapWithPrio LogOfInterest recorder - whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () - whenUriFile uri act = whenJust (uriToFilePath uri) $ act . toNormalizedFilePath' + whenUriFile :: Uri -> (CabalInput -> IO ()) -> IO () + whenUriFile uri act = whenJust (uriToNormalizedFilePath (toNormalizedUri uri) >>= toCabalInput) act + +toCabalFilePathInput :: FilePath -> Maybe (FilePath, CabalInput) +toCabalFilePathInput path = + fmap ((,) path) (toCabalInput (toNormalizedFilePath path)) {- | Helper function to restart the shake session, specifically for modifying .cabal files. No special logic, just group up a bunch of functions you need for the base @@ -178,20 +182,21 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> CabalInput -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath (inputFilePath file) ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession - return (toKey GetModificationTime file:keys) + return (toKey GetModificationTime (SomeFileCabalInput file):keys) -- | Just like 'restartCabalShakeSession', but records that the 'file' has been changed on disk. -- So, any action that can only work with on-disk modifications may depend on the 'GetPhysicalModificationTime' -- rule to get re-run if the file changes on disk. -restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () +restartCabalShakeSessionPhysical :: ShakeExtras -> VFS.VFS -> CabalInput -> String -> IO [Key] -> IO () restartCabalShakeSessionPhysical shakeExtras vfs file actionMsg actionBetweenSession = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath (inputFilePath file) ++ " " ++ actionMsg) [] $ do keys <- actionBetweenSession - return (toKey GetModificationTime file:toKey GetPhysicalModificationTime file:keys) + let input = SomeFileCabalInput file + return (toKey GetModificationTime input:toKey GetPhysicalModificationTime input:keys) -- ---------------------------------------------------------------- -- Code Actions @@ -215,27 +220,27 @@ use some sort of fuzzy matching in the future, see issue #4357. fieldSuggestCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics = diags}) = do mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri - case (,) <$> mContents <*> uriToFilePath' uri of + case (,) <$> mContents <*> (uriToFilePath' uri >>= toCabalFilePathInput) of Nothing -> pure $ InL [] - Just (fileContents, path) -> do + Just (fileContents, (path, cabalInput)) -> 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 + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ cabalInput case mFields of Nothing -> pure $ InL [] Just (cabalFields, _) -> do let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags - results <- forM fields (getSuggestion fileContents path cabalFields) + results <- forM fields (getSuggestion fileContents path cabalInput cabalFields) pure $ InL $ map InR $ concat results where - getSuggestion fileContents fp cabalFields (fieldName, Diagnostic{_range = _range@(Range (Position lineNr col) _)}) = do + getSuggestion fileContents fp cabalInput cabalFields (fieldName, Diagnostic{_range = _range@(Range (Position lineNr col) _)}) = do let -- Compute where we would anticipate the cursor to be. fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName)) lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo - completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields $ + completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo cabalInput cabalFields $ CompleterTypes.Matcher $ Fuzzy.levenshteinScored Fuzzy.defChunkSize let completionTexts = fmap (^. JL.label) completions @@ -249,15 +254,15 @@ cabalAddDependencyCodeAction _ state plId (CodeActionParams _ _ (TextDocumentIde _ -> do haskellFilePath <- uriToFilePathE uri mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath - case mbCabalFile of + case mbCabalFile >>= toCabalFilePathInput of Nothing -> pure $ InL [] - Just cabalFilePath -> do + Just (cabalFilePath, cabalInput) -> do 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 @@ -279,15 +284,15 @@ cabalAddModuleCodeAction recorder state plId (CodeActionParams _ _ (TextDocument do haskellFilePath <- uriToFilePathE uri mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath - case mbCabalFile of + case mbCabalFile >>= toCabalFilePathInput of Nothing -> pure $ InL [] - Just cabalFilePath -> do + Just (cabalFilePath, cabalInput) -> do verTextDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $ lift $ getVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath) - (gpd, _) <- runActionE "cabal.cabal-add" state $ useWithStaleE ParseCabalFile $ toNormalizedFilePath cabalFilePath + (gpd, _) <- runActionE "cabal.cabal-add" state $ useWithStaleE ParseCabalFile cabalInput actions <- CabalAdd.collectModuleInsertionOptions (cmapWithPrio LogCabalAdd recorder) @@ -306,13 +311,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 + input <- classifyAsCabal uri + cabalFields <- runActionE "cabal.cabal-hover" ide $ useE ParseCabalFields input 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 input let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd case filterVersion cursorText of Nothing -> pure $ InR Null @@ -357,18 +362,18 @@ completion recorder ide _ complParams = do let TextDocumentIdentifier uri = complParams ^. JL.textDocument position = complParams ^. JL.position mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri - case (,) <$> mContents <*> uriToFilePath' uri of - Just (cnts, path) -> do + case (,) <$> mContents <*> (uriToFilePath' uri >>= toCabalFilePathInput) of + Just (cnts, (path, cabalInput)) -> 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 + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields cabalInput 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 $ + res = computeCompletionsAt recorder ide cabalPrefInfo cabalInput fields $ CompleterTypes.Matcher $ Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults liftIO $ fmap InL res @@ -378,11 +383,11 @@ computeCompletionsAt :: Recorder (WithPriority Log) -> IdeState -> Types.CabalPrefixInfo - -> FilePath + -> CabalInput -> [Syntax.Field Syntax.Position] -> CompleterTypes.Matcher T.Text -> IO [CompletionItem] -computeCompletionsAt recorder ide prefInfo fp fields matcher = do +computeCompletionsAt recorder ide prefInfo input fields matcher = do runMaybeT (context fields) >>= \case Nothing -> pure [] Just ctx -> do @@ -394,9 +399,9 @@ 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 + mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile input pure $ fmap fst mGPD - , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp + , getCabalCommonSections = 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..51aa3cb0fc 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,7 @@ 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.RuleInput import Development.IDE.Core.Rules (IdeState) import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (useWithStale) @@ -187,10 +188,11 @@ mkCabalAddConfig :: ExceptT PluginError m WorkspaceEdit mkCabalAddConfig recorder env cabalFilePath mkConfig = do let (state, caps, verTxtDocId) = env + let input = CabalInput (toNormalizedFilePath cabalFilePath) (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 (SomeFileCabalInput input) + inFields <- useWithStale ParseCabalFields input + inPackDescr <- useWithStale ParseCabalFile input 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..608b75ab2e 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 @@ -9,6 +9,7 @@ import Control.Lens ((^.)) import Data.Hashable import qualified Data.Text as T import Development.IDE as D +import Development.IDE.Core.RuleInput import qualified Distribution.Fields as Syntax import qualified Distribution.PackageDescription as PD import qualified Distribution.Parsec.Position as Syntax @@ -40,6 +41,7 @@ instance Pretty Log where LogMapLookUpOfKnownKeyFailed key -> "Lookup of key in map failed even though it should exist" <+> pretty key LogCompletionContext ctx -> "Completion context is:" <+> pretty ctx +type instance RuleInput ParseCabalFile = CabalInput type instance RuleResult ParseCabalFile = PD.GenericPackageDescription data ParseCabalFile = ParseCabalFile @@ -49,6 +51,7 @@ instance Hashable ParseCabalFile instance NFData ParseCabalFile +type instance RuleInput ParseCabalFields = CabalInput type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position] data ParseCabalFields = ParseCabalFields @@ -58,6 +61,7 @@ instance Hashable ParseCabalFields instance NFData ParseCabalFields +type instance RuleInput ParseCabalCommonSections = CabalInput type instance RuleResult ParseCabalCommonSections = [Syntax.Field Syntax.Position] data ParseCabalCommonSections = ParseCabalCommonSections 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..ec7bfbe9fc 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs @@ -14,6 +14,7 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as T import Development.IDE as D import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import qualified Distribution.Fields as Syntax import Distribution.PackageDescription (Benchmark (..), BuildInfo (..), @@ -36,7 +37,6 @@ import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommon ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types import Ide.Plugin.Cabal.Orphans () -import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL import qualified Language.LSP.Protocol.Message as LSP @@ -54,19 +54,19 @@ import System.FilePath (joinPath, -- TODO: Resolve more cases for go-to definition. gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition gotoDefinition ide _ msgParam = do - nfp <- getNormalizedFilePathE uri - cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields nfp + input <- classifyAsCabal uri + cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields input -- 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 input 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 input case mGPD of Nothing -> pure Nothing - Just (gpd, _) -> liftIO $ gotoModulesDefinition nfp gpd cursor fieldsOfInterest + Just (gpd, _) -> liftIO $ gotoModulesDefinition input gpd cursor fieldsOfInterest let defs = Maybe.catMaybes [ mCommonSectionsDef , mModuleDef @@ -114,12 +114,12 @@ gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest = do -- -- See resolving @Config@ module in tests. gotoModulesDefinition - :: NormalizedFilePath -- ^ Normalized FilePath to the cabal file + :: CabalInput -- ^ Typed input for the cabal file -> GenericPackageDescription -> Syntax.Position -- ^ Cursor position -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor -> IO (Maybe Definition) -gotoModulesDefinition nfp gpd cursor fieldsOfInterest = do +gotoModulesDefinition input gpd cursor fieldsOfInterest = do let mCursorText = CabalFields.findTextWord cursor fieldsOfInterest moduleNames = CabalFields.getModulesNames fieldsOfInterest mModuleName = find (isModuleName mCursorText) moduleNames @@ -131,7 +131,7 @@ gotoModulesDefinition nfp gpd cursor fieldsOfInterest = do (flattenPackageDescription gpd)) mBuildTargetNames sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos - potentialPaths = map (\dir -> takeDirectory (fromNormalizedFilePath nfp) dir toHaskellFile moduleName) sourceDirs + potentialPaths = map (\dir -> takeDirectory (fromNormalizedFilePath (inputFilePath input)) dir toHaskellFile moduleName) sourceDirs allPaths <- liftIO $ filterM doesFileExist potentialPaths -- Don't provide the range, since there is little benefit for it let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 5429ac0bb9..00a15ca443 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -14,6 +14,7 @@ where import Control.Lens ((&), (.~)) import qualified Data.Text as T import Development.IDE (FileDiagnostic) +import Development.IDE.Core.RuleInput import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, ideErrorWithSource) import Distribution.Fields (showPError, showPWarning) @@ -22,29 +23,28 @@ import Ide.PluginUtils (extendNextLine) import Language.LSP.Protocol.Lens (range) import Language.LSP.Protocol.Types (Diagnostic (..), DiagnosticSeverity (..), - NormalizedFilePath, Position (Position), Range (Range), fromNormalizedFilePath) -- | Produce a diagnostic for a fatal Cabal parser error. -fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic +fatalParseErrorDiagnostic :: CabalInput -> T.Text -> FileDiagnostic fatalParseErrorDiagnostic fp msg = mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine Syntax.zeroPos) msg -- | Produce a diagnostic from a Cabal parser error -errorDiagnostic :: NormalizedFilePath -> Syntax.PError -> FileDiagnostic +errorDiagnostic :: CabalInput -> Syntax.PError -> FileDiagnostic errorDiagnostic fp err@(Syntax.PError pos _) = mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg where - msg = T.pack $ showPError (fromNormalizedFilePath fp) err + msg = T.pack $ showPError (fromNormalizedFilePath (inputFilePath fp)) err -- | Produce a diagnostic from a Cabal parser warning -warningDiagnostic :: NormalizedFilePath -> Syntax.PWarning -> FileDiagnostic +warningDiagnostic :: CabalInput -> Syntax.PWarning -> FileDiagnostic warningDiagnostic fp warning@(Syntax.PWarning _ pos _) = mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg where - msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning + msg = T.pack $ showPWarning (fromNormalizedFilePath (inputFilePath fp)) warning -- | The Cabal parser does not output a _range_ for a warning/error, -- only a single source code 'Lib.Position'. @@ -72,7 +72,7 @@ positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral -- | Create a 'FileDiagnostic' mkDiag - :: NormalizedFilePath + :: CabalInput -- ^ Cabal file path -> T.Text -- ^ Where does the diagnostic come from? @@ -87,7 +87,7 @@ mkDiag file diagSource sev loc msg = ideErrorWithSource (Just diagSource) (Just sev) - file + (inputFilePath file) msg Nothing & fdLspDiagnosticL . range .~ loc 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..c11f845cc3 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/OfInterest.hs @@ -16,6 +16,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Proxy import qualified Data.Text () import Development.IDE as D +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) import Development.IDE.Types.Shake (toKey) @@ -25,7 +26,7 @@ import Ide.Plugin.Cabal.Orphans () data Log = LogShake Shake.Log - | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) + | LogFOI (HashMap CabalInput FileOfInterestStatus) deriving (Show) instance Pretty Log where @@ -45,7 +46,7 @@ such as generating diagnostics, re-parsing, etc... We need to store the open files to parse them again if we restart the shake session. Restarting of the shake session happens whenever these files are modified. -} -newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) +newtype OfInterestCabalVar = OfInterestCabalVar (Var (HashMap CabalInput FileOfInterestStatus)) instance Shake.IsIdeGlobal OfInterestCabalVar @@ -54,6 +55,7 @@ data IsCabalFileOfInterest = IsCabalFileOfInterest instance Hashable IsCabalFileOfInterest instance NFData IsCabalFileOfInterest +type instance RuleInput IsCabalFileOfInterest = CabalInput type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus @@ -80,13 +82,14 @@ ofInterestRules recorder = do summarize (IsCabalFOI OnDisk) = BS.singleton 1 summarize (IsCabalFOI (Modified False)) = BS.singleton 2 summarize (IsCabalFOI (Modified True)) = BS.singleton 3 + summarize (IsCabalFOI ReadOnly) = BS.singleton 4 -getCabalFilesOfInterestUntracked :: Action (HashMap NormalizedFilePath FileOfInterestStatus) +getCabalFilesOfInterestUntracked :: Action (HashMap CabalInput FileOfInterestStatus) getCabalFilesOfInterestUntracked = do OfInterestCabalVar var <- Shake.getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> CabalInput -> FileOfInterestStatus -> IO [Key] addFileOfInterest recorder state f v = do OfInterestCabalVar var <- Shake.getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do @@ -100,12 +103,12 @@ addFileOfInterest recorder state f v = do where log' = logWith recorder -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> CabalInput -> IO [Key] deleteFileOfInterest recorder state f = do OfInterestCabalVar var <- Shake.getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f log' Debug $ LogFOI files - return [toKey IsFileOfInterest f] + return [toKey IsCabalFileOfInterest f] where log' = logWith recorder 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..6e8a88a992 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Cabal.Outline where @@ -11,11 +10,11 @@ import Control.Monad.IO.Class import Data.Maybe import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules import Development.IDE.Core.Shake (IdeState (shakeExtras), runIdeAction, useWithStaleFast) -import Development.IDE.Types.Location (toNormalizedFilePath') import Distribution.Fields.Field (Field (Field, Section), Name (Name)) import Distribution.Parsec.Position (Position) @@ -31,9 +30,9 @@ import qualified Language.LSP.Protocol.Types as LSP 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 LSP.uriToNormalizedFilePath (LSP.toNormalizedUri uri) >>= toCabalInput 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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs index f2b3d74639..0ac08889f8 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Parse.hs @@ -16,6 +16,7 @@ import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.RuleInput import qualified Distribution.Fields.Parser as Syntax import qualified Distribution.Parsec.Position as Syntax @@ -27,7 +28,7 @@ parseCabalFileContents bs = runParseResult (parseGenericPackageDescription bs) readCabalFields :: - NormalizedFilePath -> + CabalInput -> BS.ByteString -> Either FileDiagnostic [Syntax.Field Syntax.Position] readCabalFields file contents = do 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..129bb08902 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,7 @@ 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.RuleInput import qualified Development.IDE.Core.Shake as Shake import qualified Distribution.CabalSpecVersion as Cabal import qualified Distribution.Fields as Syntax @@ -32,7 +33,7 @@ import Ide.Types import Text.Regex.TDFA data Log - = LogModificationTime NormalizedFilePath FileVersion + = LogModificationTime CabalInput FileVersion | LogShake Shake.Log | LogOfInterest OfInterest.Log | LogDocSaved Uri @@ -43,7 +44,7 @@ instance Pretty Log where LogShake log' -> pretty log' LogOfInterest log' -> pretty log' LogModificationTime nfp modTime -> - "Modified:" <+> pretty (fromNormalizedFilePath nfp) <+> pretty (show modTime) + "Modified:" <+> pretty (fromNormalizedFilePath (inputFilePath nfp)) <+> pretty (show modTime) LogDocSaved uri -> "Saved text document:" <+> pretty (getUri uri) @@ -59,13 +60,13 @@ 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 + (t, mCabalSource) <- use_ GetFileContents (SomeFileCabalInput file) log' Debug $ LogModificationTime 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 (inputFilePath file) case Parse.readCabalFields file contents of Left _ -> @@ -91,13 +92,13 @@ 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 + (t, mCabalSource) <- use_ GetFileContents (SomeFileCabalInput file) log' Debug $ LogModificationTime 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 (inputFilePath file) -- Instead of fully reparsing the sources to get a 'GenericPackageDescription', -- we would much rather re-use the already parsed results of 'ParseCabalFields'. diff --git a/plugins/hls-cabal-plugin/test/Context.hs b/plugins/hls-cabal-plugin/test/Context.hs index 00d13b08f8..82c39ab37b 100644 --- a/plugins/hls-cabal-plugin/test/Context.hs +++ b/plugins/hls-cabal-plugin/test/Context.hs @@ -7,6 +7,7 @@ module Context where import qualified Data.Text as T import qualified Data.Text.Encoding as Text +import Development.IDE.Core.RuleInput import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import Ide.Plugin.Cabal import Ide.Plugin.Cabal.Completion.Completer.Paths @@ -207,7 +208,7 @@ getContextTests = where callGetContext :: Position -> T.Text -> T.Text -> IO Context callGetContext pos pref ls = do - case Parse.readCabalFields "not-real" (Text.encodeUtf8 ls) of + case Parse.readCabalFields (CabalInput "not-real.cabal") (Text.encodeUtf8 ls) of Left err -> fail $ show err Right fields -> do getContext mempty (simpleCabalPrefixInfoFromPos pos pref) fields 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..89caf94c0b 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.RuleInput import Development.IDE.Core.Shake import Development.IDE.GHC.Compat as Compat import Development.IDE.Spans.AtPoint @@ -33,7 +34,6 @@ import GHC.Iface.Ext.Utils (getNameBinding) import HieDb (Symbol (Symbol)) import qualified Ide.Plugin.CallHierarchy.Query as Q import Ide.Plugin.CallHierarchy.Types -import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -44,22 +44,22 @@ import Text.Read (readMaybe) -- | Render prepare call hierarchy request. prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = do - nfp <- getNormalizedFilePathE (param ^. (L.textDocument . L.uri)) + input <- classifyAsSomeHaskell (param ^. (L.textDocument . L.uri)) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state - $ prepareCallHierarchyItem nfp (param ^. L.position) + $ prepareCallHierarchyItem input (param ^. L.position) pure $ InL items -prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] -prepareCallHierarchyItem nfp pos = use GetHieAst nfp <&> \case +prepareCallHierarchyItem :: SomeHaskellInput -> Position -> Action [CallHierarchyItem] +prepareCallHierarchyItem input pos = use GetHieAst input <&> \case Nothing -> mempty - Just (HAR _ hf _ _ _) -> prepareByAst hf pos nfp + Just (HAR _ hf _ _ _) -> prepareByAst input hf pos -prepareByAst :: HieASTs a -> Position -> NormalizedFilePath -> [CallHierarchyItem] -prepareByAst hf pos nfp = +prepareByAst :: SomeHaskellInput -> HieASTs a -> Position -> [CallHierarchyItem] +prepareByAst input hf pos = case listToMaybe $ pointCommand hf pos extract of Nothing -> mempty - Just infos -> mapMaybe (construct nfp hf) infos + Just infos -> mapMaybe (construct input hf) infos extract :: HieAST a -> [(Identifier, [ContextInfo], Span)] extract ast = let span = nodeSpan ast @@ -77,8 +77,8 @@ patternBindInfo ctxs = listToMaybe [ctx | ctx@PatternBind{} <- ctxs] tyDeclInfo ctxs = listToMaybe [TyDecl | TyDecl <- ctxs] matchBindInfo ctxs = listToMaybe [MatchBind | MatchBind <- ctxs] -construct :: NormalizedFilePath -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem -construct nfp hf (ident, contexts, ssp) +construct :: SomeHaskellInput -> HieASTs a -> (Identifier, [ContextInfo], Span) -> Maybe CallHierarchyItem +construct input hf (ident, contexts, ssp) | isInternalIdentifier ident = Nothing | Just (RecField RecFieldDecl _) <- recFieldInfo contexts @@ -123,7 +123,7 @@ construct nfp hf (ident, contexts, ssp) -- as this is the call-hierarchy plugin skUnknown = SymbolKind_Function - mkCallHierarchyItem' = mkCallHierarchyItem nfp + mkCallHierarchyItem' = mkCallHierarchyItem input isInternalIdentifier = \case Left _ -> False @@ -133,16 +133,16 @@ construct nfp hf (ident, contexts, ssp) Left _ -> Nothing Right name -> case getNameBinding name (getAsts hf) of Nothing -> Nothing - Just sp -> listToMaybe $ prepareByAst hf (realSrcSpanToRange sp ^. L.start) nfp + Just sp -> listToMaybe $ prepareByAst input hf (realSrcSpanToRange sp ^. L.start) -mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem -mkCallHierarchyItem nfp ident kind span selSpan = +mkCallHierarchyItem :: SomeHaskellInput -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem +mkCallHierarchyItem input ident kind span selSpan = CallHierarchyItem (T.pack $ optimizeDisplay $ identifierName ident) kind Nothing (Just $ T.pack $ identifierToDetail ident) - (fromNormalizedUri $ normalizedFilePathToUri nfp) + (fromNormalizedUri $ normalizedFilePathToUri (inputFilePath input)) (realSrcSpanToRange span) (realSrcSpanToRange selSpan) (toJSON . show <$> mkSymbol ident) @@ -228,21 +228,24 @@ mkCallHierarchyCall mk v@Vertex{..} = do (fromIntegral $ cael - 1) (fromIntegral $ caec - 1) - prepareCallHierarchyItem nfp pos >>= - \case - [item] -> pure $ Just $ mk item [range] - _ -> do - ShakeExtras{withHieDb} <- getShakeExtras - sps <- liftIO (withHieDb (`Q.getSymbolPosition` v)) - case sps of - (x:_) -> do - items <- prepareCallHierarchyItem - nfp - (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) - case items of - [item] -> pure $ Just $ mk item [range] - _ -> pure Nothing - [] -> pure Nothing + case toSomeHaskellInput nfp of + Nothing -> pure Nothing + Just input -> + prepareCallHierarchyItem input pos >>= + \case + [item] -> pure $ Just $ mk item [range] + _ -> do + ShakeExtras{withHieDb} <- getShakeExtras + sps <- liftIO (withHieDb (`Q.getSymbolPosition` v)) + case sps of + (x:_) -> do + items <- prepareCallHierarchyItem + input + (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) + case items of + [item] -> pure $ Just $ mk item [range] + _ -> pure Nothing + [] -> pure Nothing -- | Unified queries include incoming calls and outgoing calls. queryCalls :: @@ -252,9 +255,9 @@ queryCalls :: -> ([a] -> [a]) -> Action [a] queryCalls item queryFunc makeFunc merge - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do + | Just input <- uriToNormalizedFilePath (toNormalizedUri uri) >>= toSomeHaskellInput = do ShakeExtras{withHieDb} <- getShakeExtras - maySymbol <- getSymbol nfp + maySymbol <- getSymbol input case maySymbol of Nothing -> pure mempty Just symbol -> do @@ -272,8 +275,8 @@ queryCalls item queryFunc makeFunc merge A.Error _ -> getSymbolFromAst nfp pos 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 :: SomeHaskellInput -> Position -> Action (Maybe Symbol) + getSymbolFromAst input pos_ = use GetHieAst input <&> \case Nothing -> Nothing Just (HAR _ hf _ _ _) -> do case listToMaybe $ pointCommand hf pos_ extract of diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 0c9817394c..48d4452d13 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -27,6 +27,7 @@ import Development.IDE (FileDiagnostic, fdStructuredMessageL, logWith, realSrcSpanToRange) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes (GetParsedModule (GetParsedModule)) import Development.IDE.GHC.Compat hiding (vcat) import Development.IDE.GHC.Compat.Error (_MismatchMessage, @@ -47,8 +48,7 @@ import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) import GHC.Utils.Outputable (vcat) #endif import qualified Ide.Logger as Logger -import Ide.Plugin.Error (PluginError, - getNormalizedFilePathE) +import Ide.Plugin.Error (PluginError) import Ide.Types (Config, HandlerM, PluginDescriptor (..), PluginId (PluginId), @@ -89,14 +89,14 @@ codeActionHandler -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionHandler recorder plId ideState _ CodeActionParams{_textDocument, _range} = do let TextDocumentIdentifier uri = _textDocument - nfp <- getNormalizedFilePathE uri - decls <- getDecls plId ideState nfp + input <- classifyAsProjectHaskell uri + decls <- getDecls plId ideState input - fileDiags <- activeDiagnosticsInRange (shakeExtras ideState) nfp _range - actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags - pure $ InL $ catMaybes actions + activeDiagnosticsInRange (shakeExtras ideState) (inputFilePath input) _range >>= \fileDiags -> do + actions <- lift $ mapM (generateAction recorder plId uri decls) fileDiags + pure (InL (catMaybes actions)) -getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m [LHsDecl GhcPs] +getDecls :: MonadIO m => PluginId -> IdeState -> ProjectHaskellInput -> ExceptT PluginError m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = runActionE (T.unpack changeTypeSignatureId <> ".GetParsedModule") state . fmap (hsmodDecls . unLoc . pm_parsed_source) diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 59f7b4e61e..56f75ecec5 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -25,6 +25,7 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Error (TcRnMessage (..), _TcRnMessage, @@ -46,7 +47,7 @@ import Language.LSP.Protocol.Types addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do caps <- lift pluginGetClientCapabilities - nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + nfp <- classifyAsProjectHaskell (verTxtDocId ^. L.uri) pm <- runActionE "classplugin.addMethodPlaceholders.GetParsedModule" state $ useE GetParsedModule nfp (hsc_dflags . hscEnv -> df) <- runActionE "classplugin.addMethodPlaceholders.GhcSessionDeps" state @@ -84,8 +85,8 @@ addMethodPlaceholders _ state _ param@AddMinimalMethodsParams{..} = do codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId - nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) - activeDiagnosticsInRange (shakeExtras state) nfp caRange + nfp <- classifyAsProjectHaskell (verTxtDocId ^. L.uri) + activeDiagnosticsInRange (shakeExtras state) (inputFilePath nfp) caRange >>= \fileDiags -> do actions <- join <$> mapM (mkActions nfp verTxtDocId) (methodDiags fileDiags) pure $ InL actions @@ -94,7 +95,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId caRange _) = do mapMaybe (\d -> (d,) <$> isClassMethodWarning (d ^. fdStructuredMessageL)) fileDiags mkActions - :: NormalizedFilePath + :: ProjectHaskellInput -> VersionedTextDocumentIdentifier -> (FileDiagnostic, ClassMinimalDef) -> ExceptT PluginError (HandlerM Ide.Plugin.Config.Config) [Command |? CodeAction] diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 3143f5ff5c..17c18a3180 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -12,6 +12,7 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) @@ -28,7 +29,7 @@ import Language.LSP.Protocol.Types -- lenses matched to a unique id codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLens state _plId clp = do - nfp <- getNormalizedFilePathE $ clp ^. L.textDocument . L.uri + nfp <- classifyAsProjectHaskell $ clp ^. L.textDocument . L.uri (InstanceBindLensResult (InstanceBindLens{lensRange}), pm) <- runActionE "classplugin.GetInstanceBindLens" state -- Using stale results means that we can almost always return a @@ -42,7 +43,7 @@ codeLens state _plId clp = do -- The code lens resolve method matches a title to each unique id codeLensResolve:: ResolveFunction IdeState Int Method_CodeLensResolve codeLensResolve state plId cl uri uniqueID = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri (InstanceBindLensResult (InstanceBindLens{lensDetails}), pm) <- runActionE "classplugin.GetInstanceBindLens" state $ useWithStaleE GetInstanceBindLens nfp @@ -68,7 +69,7 @@ codeLensResolve state plId cl uri uniqueID = do -- specified unique id. codeLensCommandHandler :: PluginId -> CommandFunction IdeState InstanceBindLensCommand codeLensCommandHandler plId state _ InstanceBindLensCommand{commandUri, commandEdit} = do - nfp <- getNormalizedFilePathE commandUri + nfp <- classifyAsProjectHaskell commandUri (InstanceBindLensResult (InstanceBindLens{lensEnabledExtensions}), _) <- runActionE "classplugin.GetInstanceBindLens" state $ useWithStaleE GetInstanceBindLens nfp 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..fee68fb2b1 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -19,6 +19,7 @@ import qualified Data.Text as T import Data.Unique (hashUnique, newUnique) import Development.IDE import Development.IDE.Core.PluginUtils (useMT) +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (newUnique, (<+>)) import Development.IDE.GHC.Compat.Util (bagToList) @@ -75,6 +76,7 @@ instance Show ClassInstancesResult where instance NFData ClassInstancesResult where rnf = rwhnf +type instance RuleInput GetClassInstances = ProjectHaskellInput type instance RuleResult GetClassInstances = ClassInstancesResult -- |The necessary data to execute our code lens @@ -114,6 +116,7 @@ instance Show InstanceBindLensResult where instance NFData InstanceBindLensResult where rnf = rwhnf +type instance RuleInput GetInstanceBindLens = ProjectHaskellInput type instance RuleResult GetInstanceBindLens = InstanceBindLensResult data Log 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..913bf2e542 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -8,6 +8,7 @@ import Data.Char (isAlpha) import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util (fsLit) import Development.IDE.Spans.Pragmas (getNextPragmaInfo, @@ -42,14 +43,14 @@ toMethodName n -- if the module parsed success. insertPragmaIfNotPresent :: (MonadIO m) => IdeState - -> NormalizedFilePath + -> ProjectHaskellInput -> Extension -> ExceptT PluginError m [TextEdit] 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 (SomeFileHaskellInput $ SomeProjectHaskellInput 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.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index 52bcc2226b..a8821f2c3a 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -27,6 +27,7 @@ import Development.IDE (Action, import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) +import Development.IDE.Core.RuleInput import Ide.Logger (Pretty (..)) import Ide.Plugin.CodeRange.Rules (CodeRange (..), GetCodeRange (..), @@ -43,8 +44,7 @@ import Language.LSP.Protocol.Message (Method (Method_TextDocume SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) import Language.LSP.Protocol.Types (FoldingRange (..), FoldingRangeParams (..), - NormalizedFilePath, Null, - Position (..), + Null, Position (..), Range (_start), SelectionRange (..), SelectionRangeParams (..), @@ -68,14 +68,14 @@ instance Pretty Log where foldingRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentFoldingRange foldingRangeHandler _ ide _ FoldingRangeParams{..} = do - filePath <- getNormalizedFilePathE uri + filePath <- classifyAsProjectHaskell uri foldingRanges <- runActionE "FoldingRange" ide $ getFoldingRanges filePath pure . InL $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument -getFoldingRanges :: NormalizedFilePath -> ExceptT PluginError Action [FoldingRange] +getFoldingRanges :: ProjectHaskellInput -> ExceptT PluginError Action [FoldingRange] getFoldingRanges file = do codeRange <- useE GetCodeRange file pure $ findFoldingRanges codeRange @@ -83,7 +83,7 @@ getFoldingRanges file = do selectionRangeHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentSelectionRange selectionRangeHandler _ ide _ SelectionRangeParams{..} = do do - filePath <- getNormalizedFilePathE uri + filePath <- classifyAsProjectHaskell uri mapExceptT liftIO $ getSelectionRanges ide filePath positions where uri :: Uri @@ -93,7 +93,7 @@ selectionRangeHandler _ ide _ SelectionRangeParams{..} = do positions = _positions -getSelectionRanges :: IdeState -> NormalizedFilePath -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null) +getSelectionRanges :: IdeState -> ProjectHaskellInput -> [Position] -> ExceptT PluginError IO ([SelectionRange] |? Null) getSelectionRanges ide file positions = do (codeRange, positionMapping) <- runIdeActionE "SelectionRange" (shakeExtras ide) $ useWithStaleFastE GetCodeRange file -- 'positionMapping' should be applied to the input before using them 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..ed3849babd 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 @@ -37,6 +37,7 @@ import qualified Data.Map.Strict as Map import Data.Vector (Vector) import qualified Data.Vector as V import Development.IDE +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (toIdeResult) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat.Util @@ -161,16 +162,17 @@ data GetCodeRange = GetCodeRange instance Hashable GetCodeRange instance NFData GetCodeRange +type instance RuleInput GetCodeRange = ProjectHaskellInput type instance RuleResult GetCodeRange = CodeRange codeRangeRule :: Recorder (WithPriority Log) -> Rules () codeRangeRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do + define (cmapWithPrio LogShake recorder) $ \GetCodeRange input -> 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 (SomeProjectHaskellInput input) ast <- maybeToExceptT LogNoAST . MaybeT . pure $ - getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath) file + getAsts hieAst Map.!? (coerce . mkFastString . fromNormalizedFilePath . inputFilePath) input 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 a698f25ad9..ac3c1c712a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs @@ -43,6 +43,7 @@ import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE.Core.FileStore (getUriContents, setSomethingModified) import Development.IDE.Core.Rules (IdeState, runAction) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (use_, uses_, VFSModified (VFSUnmodified), useWithSeparateFingerprintRule_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) @@ -51,7 +52,6 @@ import Development.IDE.GHC.Util (evalGhcEnv, modifyDynFlags) import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps) -import Development.IDE.Types.Location (toNormalizedFilePath') import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, @@ -162,11 +162,11 @@ mkRangeCommands recorder st plId textDocument = do let TextDocumentIdentifier uri = textDocument fp <- uriToFilePathE uri - let nfp = toNormalizedFilePath' fp - isLHS = isLiterate fp + projectFile <- classifyAsProjectHaskell uri + let isLHS = isLiterate fp dbg $ LogCodeLensFp fp (comments, _) <- - runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp + runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments projectFile dbg $ LogCodeLensComments comments -- Extract 'EvalExpr's from source code @@ -217,20 +217,20 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = let TextDocumentIdentifier{_uri} = module_ fp <- uriToFilePathE _uri - let nfp = toNormalizedFilePath' fp + projectFile <- classifyAsProjectHaskell _uri mdlText <- moduleText st _uri -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ (setSomethingModified VFSUnmodified st "Eval" $ do - queueForEvaluation st nfp - return [toKey IsEvaluating nfp] + queueForEvaluation st projectFile + return [toKey IsEvaluating projectFile] ) (setSomethingModified VFSUnmodified st "Eval" $ do - unqueueForEvaluation st nfp - return [toKey IsEvaluating nfp] + unqueueForEvaluation st projectFile + return [toKey IsEvaluating projectFile] ) - (initialiseSessionForEval (needsQuickCheck evalExprs) st nfp) + (initialiseSessionForEval (needsQuickCheck evalExprs) st projectFile) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId @@ -254,21 +254,21 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- also be loaded into the environment. -- -- The interactive context and interactive dynamic flags are also set appropiately. -initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv -initialiseSessionForEval needs_quickcheck st nfp = do +initialiseSessionForEval :: Bool -> IdeState -> ProjectHaskellInput -> IO HscEnv +initialiseSessionForEval needs_quickcheck st projectFile = do (ms, env1) <- runAction "runEvalCmd" st $ do - ms <- msrModSummary <$> use_ GetModSummary nfp - deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + ms <- msrModSummary <$> use_ GetModSummary projectFile + deps_hsc <- hscEnv <$> use_ GhcSessionDeps projectFile - linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph nfp <*> pure nfp - linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) + linkables_needed <- transitiveDeps <$> useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph projectFile <*> pure projectFile + linkables <- uses_ GetLinkable (projectFile : 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 projectFile 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..fcb5218a00 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -17,7 +17,6 @@ import Development.IDE (GetParsedModuleWithCommen IdeState, LinkableType (BCOLinkable), NeedsCompilation (NeedsCompilation), - NormalizedFilePath, RuleBody (RuleNoDiagnostics), Rules, defineEarlyCutoff, encodeLinkableType, @@ -25,6 +24,7 @@ import Development.IDE (GetParsedModuleWithCommen realSrcSpanToRange, useWithStale_, use_) import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (needsCompilationRule) import Development.IDE.Core.Shake (IsIdeGlobal, RuleBody (RuleWithCustomNewnessCheck), @@ -48,15 +48,15 @@ rules recorder = do isEvaluatingRule recorder addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) -newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath)) +newtype EvaluatingVar = EvaluatingVar (IORef (HashSet ProjectHaskellInput)) instance IsIdeGlobal EvaluatingVar -queueForEvaluation :: IdeState -> NormalizedFilePath -> IO () +queueForEvaluation :: IdeState -> ProjectHaskellInput -> IO () queueForEvaluation ide nfp = do EvaluatingVar var <- getIdeGlobalState ide atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ())) -unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO () +unqueueForEvaluation :: IdeState -> ProjectHaskellInput -> IO () unqueueForEvaluation ide nfp = do EvaluatingVar var <- getIdeGlobalState ide -- remove the module from the Evaluating state, so that next time it won't evaluate to True @@ -80,12 +80,12 @@ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () -evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do - (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp +evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments input -> do + (pm, posMap) <- useWithStale_ GetParsedModuleWithComments input let comments = foldMap (\case L (RealSrcSpanAlready real) bdy | FastString.unpackFS (srcSpanFile real) == - fromNormalizedFilePath nfp + fromNormalizedFilePath (inputFilePath input) , let ran0 = realSrcSpanToRange real , Just curRan <- toCurrentRange posMap ran0 -> 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..ea8e271196 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -43,7 +43,8 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.String (IsString (..)) import qualified Data.Text as T -import Development.IDE (Range, RuleResult) +import Development.IDE +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as Shake import qualified Development.IDE.GHC.Compat.Core as Core import Development.IDE.Graph.Classes @@ -174,6 +175,7 @@ data IsEvaluating = IsEvaluating instance Hashable IsEvaluating instance NFData IsEvaluating +type instance RuleInput IsEvaluating = ProjectHaskellInput type instance RuleResult IsEvaluating = Bool data GetEvalComments = GetEvalComments @@ -181,6 +183,7 @@ data GetEvalComments = GetEvalComments instance Hashable GetEvalComments instance NFData GetEvalComments +type instance RuleInput GetEvalComments = ProjectHaskellInput type instance RuleResult GetEvalComments = Comments data Comments = Comments { lineComments :: Map Range RawLineComment 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..783671c913 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -20,6 +20,7 @@ import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (addPersistentRule) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat @@ -27,7 +28,6 @@ import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.LSP.Notifications (ghcideNotificationsPluginPriority) import Development.IDE.Spans.AtPoint import GHC.Generics (Generic) -import Ide.Plugin.Error import Ide.Types hiding (pluginId) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -43,10 +43,10 @@ descriptor recorder pluginId = (defaultPluginDescriptor pluginId "Provides fixit hover :: PluginMethodHandler IdeState Method_TextDocumentHover hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri runIdeActionE "ExplicitFixity" (shakeExtras state) $ do (FixityMap fixmap, _) <- useWithStaleFastE GetFixity nfp - (HAR{hieAst}, mapping) <- useWithStaleFastE GetHieAst nfp + (HAR{hieAst}, mapping) <- useWithStaleFastE GetHieAst (SomeProjectHaskellInput nfp) let ns = getNamesAtPoint hieAst pos mapping fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns pure $ maybeToNull $ toHover fs @@ -63,10 +63,11 @@ hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = do fixityText :: (Name, Fixity) -> T.Text #if MIN_VERSION_GLASGOW_HASKELL(9,12,0,0) fixityText (name, Fixity precedence direction) = + printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" #else fixityText (name, Fixity _ precedence direction) = -#endif printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" +#endif newtype FixityMap = FixityMap (M.Map Name Fixity) instance Show FixityMap where @@ -91,6 +92,7 @@ data GetFixity = GetFixity deriving (Show, Eq, Generic) instance Hashable GetFixity instance NFData GetFixity +type instance RuleInput GetFixity = ProjectHaskellInput type instance RuleResult GetFixity = FixityMap -- | Convert a HieAST to FixityTree with fixity info gathered @@ -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 (SomeProjectHaskellInput 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..f4ad0cebb7 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -43,12 +43,12 @@ import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleInput import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.Error (PluginError (..), - getNormalizedFilePathE, handleMaybe) import qualified Ide.Plugin.RangeMap as RM (RangeMap, filterByRange, @@ -145,7 +145,7 @@ runImportCommand _ _ _ rd = do -- > Refine imports to import Control.Monad.IO.Class (liftIO) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do - nfp <- getNormalizedFilePathE _uri + nfp <- classifyAsProjectHaskell _uri (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let lens = [ generateLens _uri newRange int -- provide ExplicitImport only if the client does not support inlay hints @@ -169,7 +169,7 @@ lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_ lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri (ImportActionsResult{forResolve}, _) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid let updatedCodeLens = cl & L.command ?~ mkCommand plId target @@ -196,7 +196,7 @@ inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = if isInlayHintsSupported state then do - nfp <- getNormalizedFilePathE _uri + nfp <- classifyAsProjectHaskell _uri (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let inlayHints = [ inlayHint | (range, (int, _)) <- forLens @@ -243,7 +243,7 @@ inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentif -- that specific import, and one code action to refine all imports. codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) = do - nfp <- getNormalizedFilePathE _uri + nfp <- classifyAsProjectHaskell _uri (ImportActionsResult{forCodeActions}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp newRange <- toCurrentRangeE pm range let relevantCodeActions = RM.filterByRange newRange forCodeActions @@ -286,17 +286,17 @@ resolveWTextEdit :: IdeState -> IAResolveData -> ExceptT PluginError (HandlerM C -- Providing the edit for the command, or the resolve for the code action is -- completely generic, as all we need is the unique id and the text edit. resolveWTextEdit ideState (ResolveOne uri int) = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp iEdit <- handleMaybe PluginStaleResolve $ forResolve IM.!? int pure $ mkWorkspaceEdit uri [iEdit] pm resolveWTextEdit ideState (ExplicitAll uri) = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp let edits = [ ie | ie@ImportEdit{ieResType = ExplicitImport} <- IM.elems forResolve] pure $ mkWorkspaceEdit uri edits pm resolveWTextEdit ideState (RefineAll uri) = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri (ImportActionsResult{forResolve}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp let edits = [ re | re@ImportEdit{ieResType = RefineImport} <- IM.elems forResolve] pure $ mkWorkspaceEdit uri edits pm @@ -319,6 +319,7 @@ instance Hashable ImportActions instance NFData ImportActions type instance RuleResult ImportActions = ImportActionsResult +type instance RuleInput ImportActions = ProjectHaskellInput data ResultType = ExplicitImport | RefineImport deriving Eq @@ -380,8 +381,8 @@ minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogSha for currIm $ \path -> do -- second layer is from the imports of first layer to their imports ImportMap importIm <- MaybeT $ use GetImportMap path - for importIm $ \imp_path -> do - imp_hir <- MaybeT $ use GetModIface imp_path + for importIm $ \impPath -> do + imp_hir <- MaybeT $ use GetModIface impPath return $ mi_exports $ hirModIface imp_hir -- Use the GHC api to extract the "minimal" imports diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 1c1286819d..feb39a9a7f 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 @@ -49,6 +49,7 @@ import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentPosition, toCurrentRange) +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (FieldLabel (flSelector), @@ -103,7 +104,6 @@ import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), - getNormalizedFilePathE, handleMaybe) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap @@ -180,7 +180,7 @@ getConversionType = \case codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do - nfp <- getNormalizedFilePathE (docId ^. L.uri) + nfp <- classifyAsProjectHaskell (docId ^. L.uri) CRR {crCodeActions, crCodeActionResolve, enabledExtensions} <- runActionE "ExplicitFields.CodeAction" ideState $ useE CollectRecords nfp -- All we need to build a code action is the list of extensions, and a int to -- allow us to resolve it later. @@ -209,7 +209,7 @@ codeActionProvider ideState _ (CodeActionParams _ _ docId range _) = do codeActionResolveProvider :: ResolveFunction IdeState Int 'Method_CodeActionResolve codeActionResolveProvider ideState pId ca uri uid = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri pragma <- getFirstPragma pId ideState nfp (CRR {crCodeActionResolve, nameMap, enabledExtensions}, pprCtx) <- runActionE "ExplicitFields.CodeActionResolve" ideState $ do cr <- useE CollectRecords nfp @@ -237,7 +237,7 @@ codeActionResolveProvider ideState pId ca uri uid = do inlayHintDotdotProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri pragma <- getFirstPragma pId state nfp runIdeActionE "ExplicitFields.InlayHintDotDot" (shakeExtras state) $ do (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp @@ -251,7 +251,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen , uid <- RangeMap.elementsInRange range crCodeActions , Just record <- [IntMap.lookup uid crCodeActionResolve] ] -- Get the definition of each dotdot of record - locations = [ fmap (,record) (getDefinition nfp pos) + locations = [ fmap (,record) (getDefinition (SomeProjectHaskellInput nfp) pos) | record <- records , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ] defnLocsList <- lift $ sequence locations @@ -292,7 +292,7 @@ inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumen inlayHintPosRecProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do - nfp <- getNormalizedFilePathE uri + nfp <- classifyAsProjectHaskell uri runIdeActionE "ExplicitFields.InlayHintPosRec" (shakeExtras state) $ do (CRR {crCodeActions, nameMap, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp (typechecked, _) <- useWithStaleFastE TypeCheck nfp @@ -429,6 +429,7 @@ instance NFData RecordAppExpr instance Show CollectRecordsResult where show _ = "" +type instance RuleInput CollectRecords = ProjectHaskellInput type instance RuleResult CollectRecords = CollectRecordsResult data CollectNames = CollectNames @@ -445,6 +446,7 @@ instance NFData CollectNamesResult instance Show CollectNamesResult where show _ = "" +type instance RuleInput CollectNames = ProjectHaskellInput type instance RuleResult CollectNames = CollectNamesResult data Saturated = Saturated | Unsaturated diff --git a/plugins/hls-export-plugin/src/Ide/Plugin/Export.hs b/plugins/hls-export-plugin/src/Ide/Plugin/Export.hs index 24323b7497..ce4a61cec3 100644 --- a/plugins/hls-export-plugin/src/Ide/Plugin/Export.hs +++ b/plugins/hls-export-plugin/src/Ide/Plugin/Export.hs @@ -12,12 +12,12 @@ import qualified Data.Text as T import Data.Text.Utf16.Rope.Mixed (Rope) import Development.IDE import Development.IDE.Core.PluginUtils (runActionE, useE) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (getDiagnostics) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Error (_TcRnUnusedTopBind, msgEnvelopeErrorL) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) -import Ide.Plugin.Error (getNormalizedFilePathE) import Ide.Plugin.Export.Cursor import Ide.Plugin.Export.ExactPrint import Ide.Plugin.Export.Exports @@ -38,15 +38,17 @@ descriptor plId = quickCodeActionHandlers :: PluginMethodHandler IdeState Method_TextDocumentCodeAction quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do let uri = doc ^. L.uri - nfp <- getNormalizedFilePathE uri + input <- classifyAsProjectHaskell uri (ps, isCpp, mUnder, msrc) <- runActionE "Export.getInputs" state $ do - pm <- useE GetParsedModuleWithComments nfp + pm <- useE GetParsedModuleWithComments input let ps = pm_parsed_source pm isCpp = xopt LangExt.Cpp (ms_hspp_opts (pm_mod_summary pm)) mUnder = if isExplicit ps then locateUnderCursor (range ^. L.start) ps else Nothing -- Only a CPP module about to be offered an action needs the buffer (to find -- directives in the export list), so skip the fetch otherwise. - msrc <- if isJust mUnder && isCpp then snd <$> useE GetFileContents nfp else pure Nothing + msrc <- if isJust mUnder && isCpp + then snd <$> useE GetFileContents (SomeFileHaskellInput $ SomeProjectHaskellInput input) + else pure Nothing pure (ps, isCpp, mUnder, msrc) case mUnder of -- A CPP module whose buffer we could not read may have directives in the @@ -55,7 +57,7 @@ quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do Just under | not (isCpp && isNothing msrc) -> do -- The names GHC flags as defined-but-unused. Attach the action to the -- unused diagnostics as well. - unusedDiags <- liftIO $ unusedTopBindDiagnostics state nfp + unusedDiags <- liftIO $ unusedTopBindDiagnostics state input pure . InL . map InR $ [ ca | Just (verb, title, edits) <- @@ -70,10 +72,10 @@ quickCodeActionHandlers state _plId (CodeActionParams _ _ doc range _) = do _ -> pure (InL []) -- | The LSP diagnostics for names GHC reports as unused top-level definitions. -unusedTopBindDiagnostics :: IdeState -> NormalizedFilePath -> IO [Diagnostic] -unusedTopBindDiagnostics state nfp = do +unusedTopBindDiagnostics :: IdeState -> ProjectHaskellInput -> IO [Diagnostic] +unusedTopBindDiagnostics state input = do diags <- atomically $ getDiagnostics state - pure [ fdLspDiagnostic d | d <- diags, fdFilePath d == nfp, isUnusedTopBind d ] + pure [ fdLspDiagnostic d | d <- diags, fdFilePath d == inputFilePath input, isUnusedTopBind d ] where isUnusedTopBind = has (fdStructuredMessageL . _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnUnusedTopBind) diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 23a00372b4..6f86528257 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -26,6 +26,7 @@ import qualified Data.Text as T import Data.Version (showVersion) import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat as Compat hiding (Cpp, Warning, hang, vcat) @@ -75,9 +76,10 @@ properties = provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState provider recorder plId ideState token typ contents fp fo = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput fp fileOpts <- maybe [] (convertDynFlags . hsc_dflags . hscEnv) - <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession fp) + <$> liftIO (runAction "Fourmolu" ideState $ use GhcSession input) 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-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 2e7996db0b..b2de7fc64b 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -22,6 +22,7 @@ import Development.IDE.GHC.Compat import Data.Maybe (mapMaybe) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.Spans.Pragmas (getFirstPragma, insertNewPragma) import GHC.Generics (Generic) @@ -53,39 +54,40 @@ toGADTSyntaxCommandId = "GADT.toGADT" -- | A command replaces H98 data decl with GADT decl in place toGADTCommand :: PluginId -> CommandFunction IdeState ToGADTParams toGADTCommand pId@(PluginId pId') state _ ToGADTParams{..} = withExceptT handleGhcidePluginError $ do - nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE uri - (decls, exts) <- getInRangeH98DeclsAndExts state range nfp + input <- withExceptT GhcidePluginErrors $ classifyAsProjectHaskell uri + (decls, exts) <- getInRangeH98DeclsAndExts state range input (L ann decl) <- case decls of [d] -> pure d _ -> throwError $ UnexpectedNumberOfDeclarations (Prelude.length decls) deps <- withExceptT GhcidePluginErrors $ runActionE (T.unpack pId' <> ".GhcSessionDeps") state - $ useE GhcSessionDeps nfp + $ useE GhcSessionDeps input (hsc_dflags . hscEnv -> df) <- pure deps txt <- withExceptT (PrettyGadtError . T.pack) $ liftEither $ T.pack <$> (prettyGADTDecl df . h98ToGADTDecl) decl range <- liftEither $ maybeToEither FailedToFindDataDeclRange $ srcSpanToRange $ locA ann - pragma <- withExceptT GhcidePluginErrors $ getFirstPragma pId state nfp + pragma <- withExceptT GhcidePluginErrors + $ getFirstPragma pId state input let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit - (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) + (ApplyWorkspaceEditParams Nothing (workSpaceEdit input (TextEdit range txt : insertEdit))) (\_ -> pure ()) pure $ InR Null where - workSpaceEdit nfp edits = WorkspaceEdit + workSpaceEdit input edits = WorkspaceEdit (pure $ Map.fromList - [(filePathToUri $ fromNormalizedFilePath nfp, + [(inputUri input, edits)]) Nothing Nothing codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT handleGhcidePluginError $ do - nfp <- withExceptT GhcidePluginErrors $ getNormalizedFilePathE (doc ^. L.uri) - (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp + input <- withExceptT GhcidePluginErrors $ classifyAsProjectHaskell (doc ^. L.uri) + (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range input let actions = map (mkAction . printOutputable . tyClDeclLName . unLoc) inRangeH98Decls pure $ InL actions where @@ -108,7 +110,7 @@ codeActionHandler state plId (CodeActionParams _ _ doc range _) = withExceptT ha getInRangeH98DeclsAndExts :: (MonadIO m) => IdeState -> Range - -> NormalizedFilePath + -> ProjectHaskellInput -> ExceptT GadtPluginError m ([LTyClDecl GP], [Extension]) getInRangeH98DeclsAndExts state range nfp = do pm <- withExceptT GhcidePluginErrors diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 210e9f3910..d768851dcc 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -50,6 +50,7 @@ import Development.IDE hiding getExtensions) import Development.IDE.Core.Compile (sourceParser) import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics) @@ -186,6 +187,7 @@ data GetHlintDiagnostics = GetHlintDiagnostics instance Hashable GetHlintDiagnostics instance NFData GetHlintDiagnostics +type instance RuleInput GetHlintDiagnostics = ProjectHaskellInput type instance RuleResult GetHlintDiagnostics = () -- | Hlint rules to generate file diagnostics based on hlint hints @@ -201,14 +203,14 @@ 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 (inputFilePath file) ideas, Just ()) defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags action $ do - files <- Map.keys <$> getFilesOfInterestUntracked + files <- mapMaybe (toProjectHaskellInput . inputFilePath) . Map.keys <$> getFilesOfInterestUntracked Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics where @@ -287,8 +289,8 @@ rules recorder plugin = do } srcSpanToRange (UnhelpfulSpan _) = noRange -getIdeas :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action (Either ParseError [Idea]) -getIdeas recorder nfp = do +getIdeas :: Recorder (WithPriority Log) -> ProjectHaskellInput -> Action (Either ParseError [Idea]) +getIdeas recorder input = do logWith recorder Debug $ LogGetIdeas nfp (flags, classify, hint) <- useNoFile_ GetHlintSettings @@ -298,21 +300,22 @@ getIdeas recorder nfp = do fmap applyHints' (moduleEx flags) - where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) + where nfp = inputFilePath input + moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) moduleEx flags = do - mbpm <- getParsedModuleWithComments nfp + mbpm <- getParsedModuleWithComments input -- If ghc was not able to parse the module, we disable hlint diagnostics if isNothing mbpm then return Nothing else do flags' <- setExtensions flags - contents <- getFileContents nfp + contents <- getFileContents (toSomeFileInput nfp) let fp = fromNormalizedFilePath nfp let contents' = T.unpack . Rope.toText <$> contents Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do - hlintExts <- getExtensions nfp + hlintExts <- getExtensions input logWith recorder Debug $ LogUsingExtensions nfp (fmap show hlintExts) return $ flags { enabledExtensions = hlintExts } @@ -321,15 +324,15 @@ 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 nfp = do +getExtensions :: ProjectHaskellInput -> Action [Extension] +getExtensions input = do dflags <- getFlags let hscExts = EnumSet.toList (extensionFlags dflags) let hscExts' = mapMaybe (GhclibParserEx.readExtension . show) hscExts return hscExts' where getFlags :: Action DynFlags getFlags = do - modsum <- use_ GetModSummary nfp + modsum <- use_ GetModSummary input return $ ms_hspp_opts $ msrModSummary modsum -- --------------------------------------------------------------------- @@ -344,6 +347,7 @@ instance NFData ParseFlags where rnf = rwhnf instance Show Hint where show = const "" instance Show ParseFlags where show = const "" +type instance RuleInput GetHlintSettings = NoInput type instance RuleResult GetHlintSettings = (ParseFlags, [Classify], Hint) -- --------------------------------------------------------------------- @@ -408,7 +412,7 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve resolveProvider recorder ideState _plId ca uri resolveValue = do - file <- getNormalizedFilePathE uri + file <- classifyAsProjectHaskell uri case resolveValue of (ApplyHint verTxtDocId oneHint) -> do edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId @@ -470,10 +474,11 @@ mkSuppressHintTextEdits dynFlags fileContents hint = textEdit : lineSplitTextEditList -- --------------------------------------------------------------------- -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 - (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps nfp +ignoreHint :: Recorder (WithPriority Log) -> IdeState -> ProjectHaskellInput -> VersionedTextDocumentIdentifier -> HintTitle -> IO (Either PluginError WorkspaceEdit) +ignoreHint _recorder ideState input verTxtDocId ignoreHintTitle = runExceptT $ do + let nfp = inputFilePath input + (_, fileContents) <- runActionE "Hlint.GetFileContents" ideState $ useE GetFileContents (toSomeFileInput nfp) + (msr, _) <- runActionE "Hlint.GetModSummaryWithoutTimestamps" ideState $ useWithStaleE GetModSummaryWithoutTimestamps input case fileContents of Just contents -> do let dynFlags = ms_hspp_opts $ msrModSummary msr @@ -507,27 +512,28 @@ data OneHint = , oneHintTitle :: HintTitle } deriving (Generic, Eq, Show, ToJSON, FromJSON) -applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit) +applyHint :: Recorder (WithPriority Log) -> IdeState -> ProjectHaskellInput -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit) #if !APPLY_REFACT applyHint _ _ _ _ _ = -- https://github.com/ndmitchell/hlint/pull/1594#issuecomment-2338898673 evaluate $ error "Cannot apply refactoring: apply-refact does not work on GHC 9.10" #else -applyHint recorder ide nfp mhint verTxtDocId = +applyHint recorder ide input mhint verTxtDocId = runExceptT $ do + let nfp = inputFilePath input let runAction' :: Action a -> IO a runAction' = runAction "applyHint" ide 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 + 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 (toSomeFileInput 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 +551,7 @@ applyHint recorder ide nfp mhint verTxtDocId = liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do hClose h writeFileUTF8NoNewLineTranslation temp oldContent - exts <- runAction' $ getExtensions nfp + exts <- runAction' $ getExtensions input -- We have to reparse extensions to remove the invalid ones let (enabled, disabled, _invalid) = Refact.parseExtensions $ map show exts let refactExts = map show $ enabled ++ disabled diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs index a73e958913..b6c28a33e0 100644 --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -17,6 +17,7 @@ import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Traversable (for) import Development.IDE hiding (line) import Development.IDE.Core.PluginUtils (runActionE, useE) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake (toKnownFiles) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Text (lineAt) @@ -45,6 +46,7 @@ data GetNotesInFile = MkGetNotesInFile -- The GetNotesInFile action scans the source file and extracts a map of note -- definitions (note name -> position) and a map of note references -- (note name -> [position]). +type instance RuleInput GetNotesInFile = SomeFileInput type instance RuleResult GetNotesInFile = (HM.HashMap Text Position, HM.HashMap Text [Position]) data GetNotes = MkGetNotes @@ -52,6 +54,7 @@ data GetNotes = MkGetNotes deriving anyclass (Hashable, NFData) -- 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 RuleInput GetNotes = SomeFileInput type instance RuleResult GetNotes = HashMap Text (NormalizedFilePath, Position) data GetNoteReferences = MkGetNoteReferences @@ -59,6 +62,7 @@ data GetNoteReferences = MkGetNoteReferences deriving anyclass (Hashable, NFData) -- 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 RuleInput GetNoteReferences = SomeFileInput type instance RuleResult GetNoteReferences = HashMap Text [(NormalizedFilePath, Position)] instance Pretty Log where @@ -87,17 +91,17 @@ descriptor recorder plId = (defaultPluginDescriptor plId "Provides goto definiti findNotesRules :: Recorder (WithPriority Log) -> Rules () findNotesRules recorder = do defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotesInFile nfp -> do - findNotesInFile nfp recorder + findNotesInFile (inputFilePath nfp) recorder 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 (nfp,) . fst) <$> use MkGetNotesInFile (toSomeFileInput nfp)) (map inputFilePath (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 - references <- fmap snd <$> use MkGetNotesInFile nfp + definedReferences <- catMaybes <$> for (map inputFilePath (HS.toList targets)) (\nfp -> do + references <- fmap snd <$> use MkGetNotesInFile (toSomeFileInput nfp) pure $ fmap (HM.map (fmap (nfp,))) references ) pure $ Just $ List.foldl' (HM.unionWith (<>)) HM.empty definedReferences @@ -106,12 +110,14 @@ err :: MonadError PluginError m => Text -> Maybe a -> m a err s = maybe (throwError $ PluginInternalError s) pure getNote :: NormalizedFilePath -> IdeState -> Position -> ExceptT PluginError (HandlerM c) (Maybe Text) -getNote nfp state (Position l c) = do - contents <- - err "Error getting file contents" - =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp)) - line <- err "Line not found in file" (lineAt (fromIntegral l) contents) - pure $ listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line +getNote nfp state (Position l c) + | getSourceFileOrigin nfp == FromDependency = pure Nothing + | otherwise = do + contents <- + err "Error getting file contents" + =<< liftIO (runAction "notes.getfileContents" state (getFileContents (toSomeFileInput nfp))) + line <- err "Line not found in file" (lineAt (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 @@ -130,7 +136,7 @@ listReferences state _ param case noteOpt of Nothing -> pure (InR Null) Just note -> do - notes <- runActionE "notes.definedNoteReferencess" state $ useE MkGetNoteReferences nfp + notes <- runActionE "notes.definedNoteReferencess" state $ useE MkGetNoteReferences (toSomeFileInput nfp) case HM.lookup note notes of Nothing -> pure (InL []) Just poss -> pure $ InL $ mapMaybe (\(noteFp, pos@(Position l' _)) -> @@ -151,7 +157,7 @@ jumpToNote state _ param case noteOpt of Nothing -> pure (InR (InR Null)) Just note -> do - notes <- runActionE "notes.definedNotes" state $ useE MkGetNotes nfp + notes <- runActionE "notes.definedNotes" state $ useE MkGetNotes (toSomeFileInput nfp) case HM.lookup note notes of Nothing -> pure (InR (InR Null)) Just (noteFp, pos) -> pure $ InL $ Definition $ InL $ @@ -161,20 +167,22 @@ jumpToNote state _ param 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 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 - content <- case contentOpt of - Just x -> pure $ Rope.toText x - Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file - let noteMatches = (A.! 1) <$> matchAllText noteRegex content - notes = toPositions noteMatches content - logWith recorder Debug $ LogNotesFound file (HM.toList notes) - let refMatches = (A.! 1) <$> matchAllText noteRefRegex content - refs = toPositions refMatches content - logWith recorder Debug $ LogNoteReferencesFound file (HM.toList refs) - pure $ Just (HM.mapMaybe (fmap fst . List.uncons) notes, refs) +findNotesInFile file recorder + | getSourceFileOrigin file == FromDependency = pure (Just (HM.empty, HM.empty)) + | otherwise = 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 (toSomeFileInput file) + content <- case contentOpt of + Just x -> pure $ Rope.toText x + Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file + let noteMatches = (A.! 1) <$> matchAllText noteRegex content + notes = toPositions noteMatches content + logWith recorder Debug $ LogNotesFound file (HM.toList notes) + let refMatches = (A.! 1) <$> matchAllText noteRefRegex content + refs = toPositions refMatches content + logWith recorder Debug $ LogNoteReferencesFound file (HM.toList refs) + pure $ Just (HM.mapMaybe (fmap fst . List.uncons) notes, refs) where uint = fromIntegral . toInteger -- the regex library returns the character index of the match. However @@ -284,7 +292,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 (toSomeFileInput nfp)) -- compute precise hover range for highlighting corresponding Note Reference on Hover let lineText = @@ -294,7 +302,7 @@ hoverNote state _ params mbRange = findNoteRange lineText note line - notes <- runActionE "notes.hover" state $ useE MkGetNotes nfp + notes <- runActionE "notes.hover" state $ useE MkGetNotes (toSomeFileInput nfp) case HM.lookup note notes of Nothing -> pure $ InL $ Hover (InL $ MarkupContent MarkupKind_Markdown "_No declaration available_") mbRange @@ -323,62 +331,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 (toSomeFileInput 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..152fc150ac 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -24,11 +24,13 @@ import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) import qualified Development.IDE.GHC.Compat as D import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type -import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams), + handleMaybe) import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types hiding (Config) @@ -65,9 +67,10 @@ properties = provider :: Recorder (WithPriority LogEvent) -> PluginId -> FormattingHandler IdeState provider recorder plId ideState token typ contents fp _ = ExceptT $ pluginWithIndefiniteProgress title token Cancellable $ \_updater -> runExceptT $ do + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput fp fileOpts <- maybe [] (fromDyn . hsc_dflags . hscEnv) - <$> liftIO (runAction "Ormolu" ideState $ use GhcSession fp) + <$> liftIO (runAction "Ormolu" ideState $ use GhcSession input) 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..95fa6cc5bf 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 @@ -25,12 +25,11 @@ import qualified Data.Map as Map import Data.Maybe (mapMaybe, maybeToList) import Data.Text (Text) import Data.Unique (hashUnique, newUnique) -import Development.IDE (IdeState, - NormalizedFilePath, - Pretty (..), Range, - Recorder (..), Rules, - WithPriority (..), +import Development.IDE (IdeState, Pretty (..), + Range, Recorder (..), + Rules, WithPriority (..), realSrcSpanToRange) +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import Development.IDE.Core.Shake (define, useWithStale) @@ -47,11 +46,10 @@ import Development.IDE.GHC.Compat (Extension (OverloadedReco getLoc, hs_valds, parenthesizeHsExpr, pattern RealSrcSpan, - unLoc + unLoc) #if __GLASGOW_HASKELL__ >= 913 - , unLocWithUserRdr +import Development.IDE.GHC.Compat (unLocWithUserRdr) #endif - ) import Development.IDE.GHC.Util (getExtensions, printOutputable) import Development.IDE.Graph (RuleResult) @@ -64,7 +62,6 @@ import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) import Ide.Plugin.Error (PluginError (..), - getNormalizedFilePathE, handleMaybe) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap @@ -127,6 +124,7 @@ instance NFData CollectRecordSelectorsResult instance Show CollectRecordSelectorsResult where show _ = "" +type instance RuleInput CollectRecordSelectors = ProjectHaskellInput type instance RuleResult CollectRecordSelectors = CollectRecordSelectorsResult -- |Where we store our collected record selectors @@ -171,17 +169,17 @@ descriptor recorder plId = resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve resolveProvider ideState plId ca uri (ORDRD _ int) = do - nfp <- getNormalizedFilePathE uri - CRSR _ crsDetails exts <- collectRecSelResult ideState nfp - pragma <- getFirstPragma plId ideState nfp + input <- classifyAsProjectHaskell uri + CRSR _ crsDetails exts <- collectRecSelResult ideState input + pragma <- getFirstPragma plId ideState input rse <- handleMaybe PluginStaleResolve $ IntMap.lookup int crsDetails pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState _ (CodeActionParams _ _ caDocId caRange _) = do - nfp <- getNormalizedFilePathE (caDocId ^. L.uri) - CRSR crsMap _ exts <- collectRecSelResult ideState nfp + input <- classifyAsProjectHaskell (caDocId ^. L.uri) + CRSR crsMap _ exts <- collectRecSelResult ideState input let mkCodeAction (crsM, nse) = InR CodeAction { -- We pass the record selector to the title function, so that -- we can have the name of the record selector in the title of @@ -297,11 +295,13 @@ getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True) -- "selector selector2.record2" #if __GLASGOW_HASKELL__ >= 911 getRecSels e@(unLoc -> HsApp _ se@(unLoc -> XExpr (HsRecSelRn _)) re) = + ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re + | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) #else getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) = -#endif ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#endif -- Record selection where the field is being applied with the "$" operator: -- "selector $ record" #if __GLASGOW_HASKELL__ >= 913 @@ -322,7 +322,7 @@ getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) #endif getRecSels _ = ([], False) -collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath +collectRecSelResult :: MonadIO m => IdeState -> ProjectHaskellInput -> ExceptT PluginError m CollectRecordSelectorsResult collectRecSelResult ideState = runActionE "overloadedRecordDot.collectRecordSelectors" ideState diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index c16688999a..e76b27eec0 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -30,6 +30,7 @@ import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Error (GhcHint (SuggestExtension), LanguageExtensionHint (..), @@ -39,7 +40,6 @@ import Development.IDE.Plugin.Completions (ghcideCompletionsPlug import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope) import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import qualified Development.IDE.Spans.Pragmas as Pragmas -import Ide.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP @@ -86,27 +86,27 @@ mkCodeActionProvider :: (Maybe DynFlags -> FileDiagnostic -> [PragmaEdit]) -> Pl 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 <- classifyAsProjectHaskell (verTxtDocId ^. L.uri) -- 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 (SomeFileHaskellInput $ SomeProjectHaskellInput input) + 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 >>= \fileDiags -> do - let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags - pure $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> nubOrdOn snd actions + fileDiags <- activeDiagnosticsInRange (shakeExtras state) (inputFilePath input) caRange + let actions = concatMap (mkSuggest parsedModuleDynFlags) fileDiags + pure (LSP.InL (fmap (pragmaEditToAction uri nextPragmaInfo) (nubOrdOn snd actions))) mkCodeActionProvider96 :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction mkCodeActionProvider96 mkSuggest state _plId (LSP.CodeActionParams _ _ LSP.TextDocumentIdentifier{ _uri = uri } _ (LSP.CodeActionContext diags _monly _)) = do - normalizedFilePath <- getNormalizedFilePathE uri + input <- classifyAsProjectHaskell uri -- 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 (SomeFileHaskellInput $ SomeProjectHaskellInput input) + 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..d12685aefe 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,7 @@ 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.RuleInput import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), GetHieAst (GetHieAst), HieAstResult (HAR, refMap), @@ -59,7 +60,6 @@ import GHC.Iface.Ext.Types (ContextInfo (..), Identifier, IdentifierDetails (..), Span) import GHC.Iface.Ext.Utils (RefMap) import Ide.Plugin.Error (PluginError (PluginRuleFailed), - getNormalizedFilePathE, handleMaybe) import Ide.Types (PluginDescriptor (pluginHandlers), PluginId, @@ -227,12 +227,12 @@ usedIdentifiersToTextEdits range nameToImportedByMap source usedIdentifiers -- at the origin of the code action. 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 <- classifyAsProjectHaskell (documentId ^. L.uri) + 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 (SomeProjectHaskellInput input)) + (_, sourceM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents (SomeFileHaskellInput (SomeProjectHaskellInput input))) source <- handleMaybe (PluginRuleFailed "GetFileContents") sourceM let globalRdrEnv = tcg_rdr_env tmrTypechecked nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index 076ba03a06..0d6de995e1 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -51,6 +51,7 @@ import Control.Monad.Trans.Except import Control.Monad.Zip import Data.Bifunctor import Data.Bool (bool) +import Development.IDE.Core.RuleInput import qualified Data.DList as DL import Data.Either.Extra (mapLeft) import Data.Functor.Classes @@ -144,6 +145,7 @@ data GetAnnotatedParsedSource = GetAnnotatedParsedSource instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource +type instance RuleInput GetAnnotatedParsedSource = ProjectHaskellInput type instance RuleResult GetAnnotatedParsedSource = ParsedSource instance Show (HsModule GhcPs) where 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 05cb956dad..7e71c3bf22 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -23,6 +23,7 @@ import Control.Arrow (second, import Control.Concurrent.STM.Stats (atomically) import Control.Lens hiding (List, uncons, use) +import Control.Monad.Except (runExcept) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT (ExceptT)) @@ -43,6 +44,7 @@ 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.RuleInput import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -103,8 +105,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspa TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit, _range), WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), - type (|?) (InL, InR), - uriToFilePath) + type (|?) (InL, InR)) import qualified Language.LSP.Protocol.Types as TE (TextEdit (..)) import qualified Text.Fuzzy.Parallel as TFP import Text.Regex.TDFA ((=~~)) @@ -160,9 +161,10 @@ codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri liftIO $ do - let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + let mbInput = either (const Nothing) Just $ runExcept $ classifyAsProjectHaskell uri + mbFile = inputFilePath <$> mbInput allDiags <- atomically $ 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 @@ -251,16 +253,16 @@ extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..} - | Just fp <- uriToFilePath doc, - nfp <- toNormalizedFilePath' fp = + | Right input <- runExcept $ classifyAsProjectHaskell doc + , nfp <- inputFilePath input = do (ModSummaryResult {..}, ps, contents) <- MaybeT $ liftIO $ runAction "extend import" ideState $ runMaybeT $ do -- 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 (SomeFileHaskellInput $ SomeProjectHaskellInput input) 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 4bff75ecff..d195c72aaa 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 @@ -14,6 +14,7 @@ where import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.Except (ExceptT (..), + runExcept, runExceptT) import Control.Monad.Reader import Control.Monad.Trans.Maybe @@ -28,6 +29,7 @@ import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PluginUtils (activeDiagnosticsInRange) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint @@ -55,9 +57,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 + | Right input <- runExcept $ classifyAsProjectHaskell uri + , nfp <- inputFilePath input = do + let runRule key ruleInput = runAction ("GhcideCodeActions." <> show key) state $ use key ruleInput + someHaskellInput = SomeProjectHaskellInput input + someFileInput = SomeFileHaskellInput someHaskellInput + caaGhcSession <- onceIO $ runRule GhcSession input caaExportsMap <- onceIO $ caaGhcSession >>= \case @@ -67,18 +72,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 $ runRule GetParsedModuleWithComments input caaContents <- onceIO $ - runRule GetFileContents <&> \case + runRule GetFileContents someFileInput <&> \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 $ runRule GetAnnotatedParsedSource input + caaTmr <- onceIO $ runRule TypeCheck input + caaHar <- onceIO $ runRule GetHieAst someHaskellInput + caaBindings <- onceIO $ runRule GetBindings input + caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs input diags <- 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..a2aa45a5c8 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,12 +5,14 @@ module Development.IDE.Plugin.CodeAction.RuleTypes import Control.DeepSeq (NFData) import Data.Hashable (Hashable) +import Development.IDE.Core.RuleInput import Development.IDE.Graph (RuleResult) import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq) import GHC.Generics (Generic) -- Rule type for caching Package Exports +type instance RuleInput PackageExports = NoInput type instance RuleResult PackageExports = ExportsMap newtype PackageExports = PackageExports HscEnvEq diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index e45fd1a47b..12dfc0b6e8 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -30,6 +30,7 @@ import Development.IDE (Recorder, WithPriority, usePropertyAction) import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log) import Development.IDE.Core.Shake hiding (Log) @@ -89,8 +90,8 @@ descriptor recorder pluginId = mkExactprintPluginDescriptor exactPrintRecorder $ prepareRenameProvider :: PluginMethodHandler IdeState Method_TextDocumentPrepareRename prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) pos _progressToken) = do - nfp <- getNormalizedFilePathE uri - HAR{hieAst} <- handleGetHieAst state nfp + input <- classifyAsProjectHaskell uri + HAR{hieAst} <- handleGetHieAst state input let spansWithNamesUnderCursor = [ srcSpan | (names, srcSpan) <- getNamesSpansAtPoint' hieAst pos @@ -109,9 +110,9 @@ prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifi renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do - nfp <- getNormalizedFilePathE uri - directOldNames <- getNamesAtPos state nfp pos - directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames + input <- classifyAsProjectHaskell uri + directOldNames <- getNamesAtPos state input pos + directRefs <- concat <$> mapM (refsAtName state input) directOldNames {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have indirect references through punned names. To find the transitive closure, we do a pass of @@ -128,11 +129,11 @@ renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) p -- There were no Names at given position (e.g. rename triggered within a comment or on a keyword) [] -> throwError $ PluginInvalidParams "No symbol to rename at given position" _ -> do - refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames + refs <- HS.fromList . concat <$> mapM (refsAtName state input) oldNames -- Validate rename crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties - unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames + unless crossModuleEnabled $ failWhenImportOrExport state input refs oldNames when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax" -- Perform rename @@ -147,13 +148,13 @@ renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) p -- | Limit renaming across modules. failWhenImportOrExport :: IdeState -> - NormalizedFilePath -> + ProjectHaskellInput -> HashSet Location -> [Name] -> ExceptT PluginError (HandlerM config) () -failWhenImportOrExport state nfp refLocs names = do +failWhenImportOrExport state input refLocs names = do pm <- runActionE "Rename.GetParsedModule" state - (useE GetParsedModule nfp) + (useE GetParsedModule input) let hsMod = unLoc $ pm_parsed_source pm case (unLoc <$> hsmodName hsMod, hsmodExports hsMod) of (mbModName, _) | not $ any (\n -> nameIsLocalOrFrom (replaceModName n mbModName) n) names @@ -174,9 +175,9 @@ getSrcEdit :: ExceptT PluginError (HandlerM config) WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do ccs <- lift pluginGetClientCapabilities - nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) + input <- classifyAsProjectHaskell (verTxtDocId ^. L.uri) annAst <- runActionE "Rename.GetAnnotatedParsedSource" state - (useE GetAnnotatedParsedSource nfp) + (useE GetAnnotatedParsedSource input) let ps = annAst src = T.pack $ exactPrint ps res = T.pack $ exactPrint (updatePs ps) @@ -216,12 +217,12 @@ replaceRefs newName refs = everywhere $ refsAtName :: MonadIO m => IdeState -> - NormalizedFilePath -> + ProjectHaskellInput -> Name -> ExceptT PluginError m [Location] -refsAtName state nfp name = do +refsAtName state input name = do ShakeExtras{withHieDb} <- liftIO $ runAction "Rename.HieDb" state getShakeExtras - ast <- handleGetHieAst state nfp + ast <- handleGetHieAst state input dbRefs <- case nameModule_maybe name of Nothing -> pure [] Just mod -> liftIO $ mapMaybe rowToLoc <$> withHieDb (\hieDb -> @@ -233,7 +234,7 @@ refsAtName state nfp name = do (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) - [fromNormalizedFilePath nfp] + [fromNormalizedFilePath (inputFilePath input)] ) pure $ nameLocs name ast ++ dbRefs @@ -245,21 +246,21 @@ nameLocs name (HAR _ _ rm _ _) = --------------------------------------------------------------------------------------------------- -- Util -getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name] -getNamesAtPos state nfp pos = do - HAR{hieAst} <- handleGetHieAst state nfp +getNamesAtPos :: MonadIO m => IdeState -> ProjectHaskellInput -> Position -> ExceptT PluginError m [Name] +getNamesAtPos state input pos = do + HAR{hieAst} <- handleGetHieAst state input pure $ getNamesAtPoint' hieAst pos handleGetHieAst :: MonadIO m => IdeState -> - NormalizedFilePath -> + ProjectHaskellInput -> ExceptT PluginError m HieAstResult -handleGetHieAst state nfp = +handleGetHieAst state input = -- We explicitly do not want to allow a stale version here - we only want to rename if -- the module compiles, otherwise we can't guarantee that we'll rename everything, -- which is bad (see https://github.com/haskell/haskell-language-server/issues/3799) - fmap removeGenerated $ runActionE "Rename.GetHieAst" state $ useE GetHieAst nfp + fmap removeGenerated $ runActionE "Rename.GetHieAst" state $ useE GetHieAst (SomeProjectHaskellInput input) {- Note [Generated references] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -308,8 +309,8 @@ unsafeSrcSpanToLoc srcSpan = Nothing -> error "Invalid conversion from UnhelpfulSpan to Location" Just location -> location -locToFilePos :: Monad m => Location -> ExceptT PluginError m (NormalizedFilePath, Position) -locToFilePos (Location uri (Range pos _)) = (,pos) <$> getNormalizedFilePathE uri +locToFilePos :: Monad m => Location -> ExceptT PluginError m (ProjectHaskellInput, Position) +locToFilePos (Location uri (Range pos _)) = (,pos) <$> classifyAsProjectHaskell uri replaceModName :: Name -> Maybe ModuleName -> Module replaceModName name mbModName = 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..06464067af 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename/ModuleName.hs @@ -46,6 +46,7 @@ import Development.IDE (GetParsedModule (GetParse import Development.IDE.Core.FileStore (getFileContents) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, hsmodName, importPaths, @@ -101,18 +102,18 @@ data Action = Replace -- | Required action (that can be converted to either CodeLenses or CodeActions) action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (HandlerM c) [Action] action recorder state uri = do - nfp <- getNormalizedFilePathE uri + input <- classifyAsProjectHaskell uri fp <- uriToFilePathE uri - contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents nfp + contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents (SomeFileHaskellInput $ SomeProjectHaskellInput input) let emptyModule = maybe True (T.null . T.strip . Rope.toText) contents - correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp + correctNames <- mapExceptT liftIO $ pathModuleNames recorder state input fp logWith recorder Debug (CorrectNames correctNames) let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames logWith recorder Debug (BestName bestName) - statedNameMaybe <- liftIO $ codeModuleName state nfp + statedNameMaybe <- liftIO $ codeModuleName state input logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe) case (bestName, statedNameMaybe) of (Just bestName, Just (nameRange, statedName)) @@ -127,11 +128,11 @@ action recorder state uri = do -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other. -pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text] -pathModuleNames recorder state normFilePath filePath +pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> ProjectHaskellInput -> FilePath -> ExceptT PluginError IO [T.Text] +pathModuleNames recorder state input filePath | firstLetter isLower $ takeFileName filePath = return ["Main"] | otherwise = do - (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath + (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession input srcPaths <- liftIO $ evalGhcEnv (hscEnv session) $ importPaths <$> getSessionDynFlags logWith recorder Debug (SrcPaths srcPaths) @@ -164,9 +165,9 @@ pathModuleNames recorder state normFilePath filePath . dropExtension -- | 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 +codeModuleName :: IdeState -> ProjectHaskellInput -> IO (Maybe (Range, T.Text)) +codeModuleName state input = runMaybeT $ do + (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 7270f819f9..8111231212 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 @@ -38,6 +38,7 @@ import Development.IDE (Action, toNormalizedFilePath') import Development.IDE.Core.PluginUtils (runActionE, useE, useWithStaleE) +import Development.IDE.Core.RuleInput import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) import Development.IDE.Core.Shake (ShakeExtras (..), @@ -50,7 +51,6 @@ import GHC.Iface.Ext.Types (HieASTs (getAsts), pattern HiePath) import Ide.Logger (logWith) import Ide.Plugin.Error (PluginError (PluginInternalError), - getNormalizedFilePathE, handleMaybe, handleMaybeM) import Ide.Plugin.SemanticTokens.Mappings @@ -62,8 +62,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message (MessageResult, Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta)) -import Language.LSP.Protocol.Types (NormalizedFilePath, - SemanticTokens, +import Language.LSP.Protocol.Types (SemanticTokens, type (|?) (InL, InR)) import Prelude hiding (span) import qualified StmContainers.Map as STM @@ -75,7 +74,7 @@ $mkSemanticConfigFunctions ---- the api ----------------------- -computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action SemanticTokens +computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> ProjectHaskellInput -> ExceptT PluginError Action SemanticTokens computeSemanticTokens recorder pid _ nfp = do config <- lift $ useSemanticConfigAction pid logWith recorder Debug (LogConfig config) @@ -88,7 +87,7 @@ semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanti where computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) computeSemanticTokensFull = do - nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + nfp <- classifyAsProjectHaskell (param ^. L.textDocument . L.uri) items <- computeSemanticTokens recorder pid state nfp lift $ setSemanticTokens nfp items return $ InL items @@ -96,11 +95,11 @@ semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanti semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta semanticTokensFullDelta recorder state pid param = do - nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + nfp <- classifyAsProjectHaskell (param ^. L.textDocument . L.uri) let previousVersionFromParam = param ^. L.previousResultId runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp where - computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) + computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> ProjectHaskellInput -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do semanticTokens <- computeSemanticTokens recorder pid state nfp previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp @@ -128,15 +127,15 @@ 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 + (HAR {..}) <- withExceptT LogDependencyError $ useE GetHieAst (SomeProjectHaskellInput nfp) (DKMap {getTyThingMap}, _) <- withExceptT LogDependencyError $ useWithStaleE GetDocMap nfp -- On Windows, 'nfp' contains escaped backslashes \\\\. For files that use -- the CPP extension, 'hieAst' contains forward slashes '/', because the C -- preprocessor conflicts with backslashes. We need to "renormalize" it, -- so both paths have uniform separators let renormalize = \(HiePath p) -> HiePath . mkFastString . fromNormalizedFilePath . toNormalizedFilePath' . unpackFS $ p - ast <- handleMaybe (LogNoAST $ show nfp) $ (M.mapKeys renormalize $ getAsts hieAst) M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp - virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp + ast <- handleMaybe (LogNoAST $ show nfp) $ (M.mapKeys renormalize $ getAsts hieAst) M.!? (HiePath . mkFastString . fromNormalizedFilePath) (inputFilePath nfp) + virtualFile <- handleMaybeM LogNoVF $ getVirtualFile (SomeFileHaskellInput (SomeProjectHaskellInput nfp)) let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast @@ -166,8 +165,8 @@ getAndIncreaseSemanticTokensId = do i <- stateTVar semanticTokensId (\val -> (val, val+1)) return $ T.pack $ show i -getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens) -getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache +getPreviousSemanticTokens :: ProjectHaskellInput -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup (SomeProjectHaskellInput uri) . semanticTokensCache -setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action () -setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache +setSemanticTokens :: ProjectHaskellInput -> SemanticTokens -> Action () +setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens (SomeProjectHaskellInput uri) . semanticTokensCache 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..e1389bb45b 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 @@ -7,18 +7,19 @@ module Ide.Plugin.SemanticTokens.Types where -import Control.DeepSeq (NFData (rnf), rwhnf) -import qualified Data.Array as A -import Data.Default (Default (def)) -import Data.Text (Text) -import Development.IDE (Pretty (pretty), RuleResult) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat hiding (loc) -import Development.IDE.Graph.Classes (Hashable) -import GHC.Generics (Generic) -import GHC.Iface.Ext.Types (TypeIndex) -import Ide.Plugin.Error (PluginError) -import Language.Haskell.TH.Syntax (Lift) +import Control.DeepSeq (NFData (rnf), rwhnf) +import qualified Data.Array as A +import Data.Default (Default (def)) +import Data.Text (Text) +import Development.IDE (Pretty (pretty), RuleResult) +import Development.IDE.Core.RuleInput +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat hiding (loc) +import Development.IDE.Graph.Classes (Hashable) +import GHC.Generics (Generic) +import GHC.Iface.Ext.Types (TypeIndex) +import Ide.Plugin.Error (PluginError) +import Language.Haskell.TH.Syntax (Lift) import Language.LSP.Protocol.Types @@ -130,6 +131,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 = ProjectHaskellInput 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..6d8e3ab143 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.RuleInput import Development.IDE.GHC.Compat (FastStringCompat, Name, RealSrcSpan, getSourceNodeIds, @@ -52,7 +53,6 @@ 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.Types (PluginDescriptor (pluginHandlers), PluginId, PluginMethodHandler, @@ -108,10 +108,10 @@ Here is a brief description of the algorithm of finding relevant bits from HIE A -} signatureHelpProvider :: PluginMethodHandler IdeState Method_TextDocumentSignatureHelp signatureHelpProvider ideState _pluginId (SignatureHelpParams (TextDocumentIdentifier uri) position _mProgreeToken mSignatureHelpContext) = do - nfp <- getNormalizedFilePathE uri + input <- classifyAsProjectHaskell uri results <- runIdeActionE "signatureHelp.ast" (shakeExtras ideState) $ do -- see Note [Stale Results in Signature Help] - (HAR {hieAst, hieKind}, positionMapping) <- useWithStaleFastE GetHieAst nfp + (HAR {hieAst, hieKind}, positionMapping) <- useWithStaleFastE GetHieAst (SomeProjectHaskellInput input) case fromCurrentPosition positionMapping position of Nothing -> pure [] Just oldPosition -> do @@ -127,7 +127,7 @@ 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 + 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..27f848ba9c 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -26,7 +26,7 @@ import Control.Monad.IO.Unlift (MonadIO (..), askRunInIO) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), - runExceptT) + runExcept, runExceptT) import Control.Monad.Trans.Maybe import Data.Aeson hiding (Null) import qualified Data.Bifunctor as B (first) @@ -40,6 +40,7 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util @@ -61,7 +62,8 @@ import Data.Foldable (Foldable (foldl')) import GHC.Data.Bag (Bag) #if MIN_VERSION_ghc(9,13,0) -import GHC.Parser.Annotation (EpAnn (..), EpToken (..)) +import GHC.Parser.Annotation (EpAnn (..), + EpToken (..)) #elif MIN_VERSION_ghc(9,9,0) import GHC.Parser.Annotation (EpAnn (..)) #else @@ -99,10 +101,10 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do rio <- askRunInIO let reportEditor :: ReportEditor reportEditor msgTy msgs = liftIO $ rio $ pluginSendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) - expandManually :: NormalizedFilePath -> ExceptT PluginError IO WorkspaceEdit - expandManually fp = do + expandManually :: ProjectHaskellInput -> ExceptT PluginError IO WorkspaceEdit + expandManually input = do 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." @@ -114,8 +116,8 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do , "trying to expand manually, but note that it is less rigorous." ] pm <- runActionE "expandTHSplice.fallback.GetParsedModule" ideState $ - useE GetParsedModule fp - (ps, hscEnv, _dflags) <- setupHscEnv ideState fp pm + useE GetParsedModule input + (ps, hscEnv, _dflags) <- setupHscEnv ideState input pm manualCalcEdit clientCapabilities @@ -128,8 +130,8 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do _eStyle params - withTypeChecked fp TcModuleResult {..} = do - (ps, _hscEnv, dflags) <- setupHscEnv ideState fp tmrParsed + withTypeChecked input TcModuleResult {..} = do + (ps, _hscEnv, dflags) <- setupHscEnv ideState input tmrParsed let Splices {..} = tmrTopLevelSplices let exprSuperSpans = listToMaybe $ findSubSpansDesc srcSpan exprSplices @@ -175,13 +177,13 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do res <- liftIO $ runMaybeT $ do - fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri (verTxtDocId ^. J.uri) + input <- MaybeT $ pure $ either (const Nothing) Just $ runExcept $ classifyAsProjectHaskell (verTxtDocId ^. J.uri) eedits <- - ( lift . runExceptT . withTypeChecked fp + ( lift . runExceptT . withTypeChecked input =<< MaybeT - (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck fp) + (runAction "expandTHSplice.TypeCheck" ideState $ use TypeCheck input) ) - <|> lift (runExceptT $ expandManually fp) + <|> lift (runExceptT $ expandManually input) case eedits of Left err -> do @@ -205,12 +207,12 @@ expandTHSplice _eStyle ideState _ params@ExpandSpliceParams {..} = ExceptT $ do setupHscEnv :: IdeState - -> NormalizedFilePath + -> ProjectHaskellInput -> ParsedModule -> ExceptT PluginError IO (ParsedSource, HscEnv, DynFlags) -setupHscEnv ideState fp pm = do +setupHscEnv ideState input pm = do hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ - useE GhcSessionDeps fp + useE GhcSessionDeps input let ps = annotateParsedSource pm hscEnv0 = hscEnv hscEnvEq modSum = pm_mod_summary pm @@ -461,11 +463,11 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do verTxtDocId <- liftIO $ runAction "splice.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do - fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri + input <- MaybeT $ pure $ either (const Nothing) Just $ runExcept $ classifyAsProjectHaskell theUri ParsedModule {..} <- MaybeT . runAction "splice.codeAction.GitHieAst" state $ - use GetParsedModule fp - let spn = rangeToRealSrcSpan fp ran + use GetParsedModule input + let spn = rangeToRealSrcSpan (inputFilePath input) ran mouterSplice = something' (detectSplice spn) pm_parsed_source mcmds <- forM mouterSplice $ \(spliceSpan, spliceContext) -> diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 77c9817dba..383cd5c2f8 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -2,46 +2,49 @@ {-# LANGUAGE PatternSynonyms #-} module Ide.Plugin.Stan (descriptor, Log) where -import Control.DeepSeq (NFData) -import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (toList) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import Data.Maybe (mapMaybe) -import qualified Data.Text as T +import Control.DeepSeq (NFData) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Foldable (toList) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Development.IDE -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, - configHasDiagnostics, - configInitialGenericConfig, - defaultConfigDescriptor, - defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Types as LSP -import Stan (createCabalExtensionsMap, - getStanConfig) -import Stan.Analysis (Analysis (..), runAnalysis) -import Stan.Category (Category (..)) -import Stan.Cli (StanArgs (..)) -import Stan.Config (Config, ConfigP (..), applyConfig) -import Stan.Config.Pretty (prettyConfigCli) -import Stan.Core.Id (Id (..)) -import Stan.EnvVars (EnvVars (..), envVarsToText) -import Stan.Inspection (Inspection (..)) -import Stan.Inspection.All (inspectionsIds, inspectionsMap) -import Stan.Observation (Observation (..)) -import Stan.Report.Settings (OutputSettings (..), - ToggleSolution (..), - Verbosity (..)) -import Stan.Toml (usedTomlFiles) -import System.Directory (makeRelativeToCurrentDirectory) -import Trial (Fatality, Trial (..), fiasco, - pattern FiascoL, pattern ResultL, - prettyTrial, prettyTrialWith) +import Development.IDE.Core.RuleInput +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, configHasDiagnostics, + configInitialGenericConfig, + defaultConfigDescriptor, + defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Types as LSP +import Stan (createCabalExtensionsMap, + getStanConfig) +import Stan.Analysis (Analysis (..), runAnalysis) +import Stan.Category (Category (..)) +import Stan.Cli (StanArgs (..)) +import Stan.Config (Config, ConfigP (..), + applyConfig) +import Stan.Config.Pretty (prettyConfigCli) +import Stan.Core.Id (Id (..)) +import Stan.EnvVars (EnvVars (..), envVarsToText) +import Stan.Inspection (Inspection (..)) +import Stan.Inspection.All (inspectionsIds, inspectionsMap) +import Stan.Observation (Observation (..)) +import Stan.Report.Settings (OutputSettings (..), + ToggleSolution (..), + Verbosity (..)) +import Stan.Toml (usedTomlFiles) +import System.Directory (makeRelativeToCurrentDirectory) +import Trial (Fatality, Trial (..), fiasco, + pattern FiascoL, + pattern ResultL, prettyTrial, + prettyTrialWith) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId desc) @@ -101,15 +104,17 @@ instance Hashable GetStanDiagnostics instance NFData GetStanDiagnostics +type instance RuleInput GetStanDiagnostics = ProjectHaskellInput type instance RuleResult GetStanDiagnostics = () rules :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plId = do define (cmapWithPrio LogShake recorder) $ - \GetStanDiagnostics file -> do + \GetStanDiagnostics input -> do + let file = inputFilePath input config <- getPluginConfigAction plId if plcGlobalOn config && plcDiagnosticsOn config then do - maybeHie <- getHieFile file + maybeHie <- getHieFile (SomeProjectHaskellInput input) case maybeHie of Nothing -> return ([], Nothing) Just hie -> do @@ -163,7 +168,7 @@ rules recorder plId = do action $ do files <- getFilesOfInterestUntracked - void $ uses GetStanDiagnostics $ HM.keys files + void $ uses GetStanDiagnostics $ mapMaybe toProjectHaskellInput (inputFilePath <$> HM.keys files) where analysisToDiagnostics :: NormalizedFilePath -> Analysis -> [FileDiagnostic] analysisToDiagnostics file = mapMaybe (observationToDianostic file) . toList . analysisObservations diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index cbd23a7419..632559e70c 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -16,11 +16,13 @@ import qualified Data.Text as T import Development.IDE hiding (getExtensions, pluginHandlers) import Development.IDE.Core.PluginUtils +import Development.IDE.Core.RuleInput import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), extensionFlags) import qualified Development.IDE.GHC.Compat.Util as Util import GHC.LanguageExtensions.Type -import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams), + handleMaybe) import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.Stylish @@ -51,7 +53,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) -- If the provider fails an error is returned that can be displayed to the user. provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState provider recorder ide _token typ contents fp _opts = do - (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp + input <- handleMaybe (PluginInvalidParams "Expected project Haskell file") $ toProjectHaskellInput fp + (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary input let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file mergedConfig <- liftIO $ getMergedConfig dyn config diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 874792784f..3b0de0553c 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -6,18 +6,20 @@ module Config (tests) where import Control.DeepSeq 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, - getPluginConfigAction, ideErrorText, - uses_) -import Development.IDE.Test (ExpectedDiagnostic, expectDiagnostics) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as Map +import Development.IDE (RuleResult, action, define, + getFilesOfInterestUntracked, + getPluginConfigAction, + ideErrorText, uses_) +import Development.IDE.Core.RuleInput +import Development.IDE.Test (ExpectedDiagnostic, + expectDiagnostics) import GHC.Generics import Ide.Plugin.Config import Ide.Types -import Language.LSP.Test as Test -import System.FilePath (()) +import Language.LSP.Test as Test +import System.FilePath (()) import Test.Hls {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -88,7 +90,7 @@ genericConfigTests = testGroup "generic plugin config" files <- getFilesOfInterestUntracked void $ uses_ GetTestDiagnostics $ HM.keys files define mempty $ \GetTestDiagnostics file -> do - let diags = [ideErrorText file "testplugin"] + let diags = [ideErrorText (inputFilePath file) "testplugin"] return (diags,Nothing) } -- A config that disables the plugin initially @@ -104,6 +106,7 @@ data GetTestDiagnostics = GetTestDiagnostics deriving (Eq, Show, Generic) instance Hashable GetTestDiagnostics instance NFData GetTestDiagnostics +type instance RuleInput GetTestDiagnostics = SomeHaskellInput type instance RuleResult GetTestDiagnostics = () expectDiagnosticsFail