ghcide 2.1.0.0 → 2.2.0.0
raw patch · 65 files changed
+1663/−1379 lines, 65 filesdep ~hls-graphdep ~hls-plugin-apidep ~lspPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hls-graph, hls-plugin-api, lsp, lsp-test, lsp-types
API changes (from Hackage documentation)
- Development.IDE: [$sel:clientSettings:IdeConfiguration] :: IdeConfiguration -> Hashed (Maybe Value)
- Development.IDE: [$sel:workspaceFolders:IdeConfiguration] :: IdeConfiguration -> HashSet NormalizedUri
- Development.IDE.Core.IdeConfiguration: [$sel:clientSettings:IdeConfiguration] :: IdeConfiguration -> Hashed (Maybe Value)
- Development.IDE.Core.IdeConfiguration: [$sel:workspaceFolders:IdeConfiguration] :: IdeConfiguration -> HashSet NormalizedUri
- Development.IDE.Core.PluginUtils: uriToFilePathMT :: Monad m => Uri -> MaybeT m FilePath
- Development.IDE.Core.Shake: instance GHC.Base.Semigroup (m a) => GHC.Base.Semigroup (Control.Monad.Trans.Reader.ReaderT r m a)
+ Development.IDE: [clientSettings] :: IdeConfiguration -> Hashed (Maybe Value)
+ Development.IDE: [workspaceFolders] :: IdeConfiguration -> HashSet NormalizedUri
+ Development.IDE.Core.IdeConfiguration: [clientSettings] :: IdeConfiguration -> Hashed (Maybe Value)
+ Development.IDE.Core.IdeConfiguration: [workspaceFolders] :: IdeConfiguration -> HashSet NormalizedUri
+ Development.IDE.GHC.Orphans: instance Control.DeepSeq.NFData (Development.IDE.GHC.Compat.Core.UniqFM GHC.Types.Name.Name [GHC.Types.Name.Name])
+ Development.IDE.GHC.Orphans: instance Control.DeepSeq.NFData (Language.Haskell.Syntax.Pat.Pat (GHC.Hs.Extension.GhcPass 'GHC.Hs.Extension.Renamed))
+ Development.IDE.GHC.Orphans: instance GHC.Base.Semigroup (m a) => GHC.Base.Semigroup (Control.Monad.Trans.Reader.ReaderT r m a)
+ Development.IDE.Plugin.TypeLenses: instance Data.Aeson.Types.FromJSON.FromJSON Development.IDE.Plugin.TypeLenses.TypeLensesResolve
+ Development.IDE.Plugin.TypeLenses: instance Data.Aeson.Types.ToJSON.ToJSON Development.IDE.Plugin.TypeLenses.TypeLensesResolve
+ Development.IDE.Plugin.TypeLenses: instance GHC.Generics.Generic Development.IDE.Plugin.TypeLenses.TypeLensesResolve
+ Development.IDE.Session: instance GHC.Show.Show Development.IDE.Session.MultiCradleErr
- Development.IDE.LSP.HoverDefinition: references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences
+ Development.IDE.LSP.HoverDefinition: references :: PluginMethodHandler IdeState Method_TextDocumentReferences
- Development.IDE.LSP.HoverDefinition: wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol
+ Development.IDE.LSP.HoverDefinition: wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol
- Development.IDE.LSP.LanguageServer: runLanguageServer :: forall config a m. Show config => Recorder (WithPriority Log) -> Options -> Handle -> Handle -> config -> (config -> Value -> Either Text config) -> (MVar () -> IO (LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LanguageContextEnv config, a)), Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO ()
+ Development.IDE.LSP.LanguageServer: runLanguageServer :: forall config a m. Show config => Recorder (WithPriority Log) -> Options -> Handle -> Handle -> config -> (config -> Value -> Either Text config) -> (config -> m config ()) -> (MVar () -> IO (LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LanguageContextEnv config, a)), Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO ()
- Development.IDE.LSP.Outline: moduleOutline :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol
+ Development.IDE.LSP.Outline: moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol
- Development.IDE.LSP.Server: notificationHandler :: forall (m :: Method ClientToServer Notification) c. HasTracing (MessageParams m) => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c)
+ Development.IDE.LSP.Server: notificationHandler :: forall m c. PluginMethod Notification m => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c)
- Development.IDE.LSP.Server: requestHandler :: forall (m :: Method ClientToServer Request) c. HasTracing (MessageParams m) => SMethod m -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c)
+ Development.IDE.LSP.Server: requestHandler :: forall m c. PluginMethod Request m => SMethod m -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c)
- Development.IDE.Plugin.Completions.Types: properties :: Properties '[ 'PropertyKey "autoExtendOn" 'TBoolean, 'PropertyKey "snippetsOn" 'TBoolean]
+ Development.IDE.Plugin.Completions.Types: properties :: Properties '[ 'PropertyKey "autoExtendOn" TBoolean, 'PropertyKey "snippetsOn" TBoolean]
- Development.IDE.Plugin.TypeLenses: suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(Text, [TextEdit])]
+ Development.IDE.Plugin.TypeLenses: suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(Text, TextEdit)]
Files
- ghcide.cabal +32/−7
- session-loader/Development/IDE/Session.hs +118/−55
- src/Development/IDE/Core/Actions.hs +1/−1
- src/Development/IDE/Core/Compile.hs +124/−83
- src/Development/IDE/Core/FileExists.hs +2/−2
- src/Development/IDE/Core/FileStore.hs +14/−23
- src/Development/IDE/Core/FileUtils.hs +1/−0
- src/Development/IDE/Core/IdeConfiguration.hs +2/−3
- src/Development/IDE/Core/OfInterest.hs +1/−1
- src/Development/IDE/Core/PluginUtils.hs +25/−1
- src/Development/IDE/Core/PositionMapping.hs +5/−5
- src/Development/IDE/Core/Preprocessor.hs +33/−31
- src/Development/IDE/Core/ProgressReporting.hs +10/−10
- src/Development/IDE/Core/RuleTypes.hs +32/−1
- src/Development/IDE/Core/Rules.hs +60/−62
- src/Development/IDE/Core/Service.hs +3/−3
- src/Development/IDE/Core/Shake.hs +60/−63
- src/Development/IDE/Core/Tracing.hs +0/−4
- src/Development/IDE/GHC/CPP.hs +15/−9
- src/Development/IDE/GHC/Compat.hs +82/−83
- src/Development/IDE/GHC/Compat/Core.hs +159/−204
- src/Development/IDE/GHC/Compat/Env.hs +54/−42
- src/Development/IDE/GHC/Compat/Iface.hs +19/−12
- src/Development/IDE/GHC/Compat/Logger.hs +14/−5
- src/Development/IDE/GHC/Compat/Outputable.hs +38/−30
- src/Development/IDE/GHC/Compat/Parser.hs +32/−27
- src/Development/IDE/GHC/Compat/Plugins.hs +35/−19
- src/Development/IDE/GHC/Compat/Units.hs +49/−46
- src/Development/IDE/GHC/Compat/Util.hs +23/−16
- src/Development/IDE/GHC/CoreFile.hs +32/−29
- src/Development/IDE/GHC/Error.hs +4/−4
- src/Development/IDE/GHC/Orphans.hs +39/−25
- src/Development/IDE/GHC/Util.hs +17/−33
- src/Development/IDE/Import/DependencyInformation.hs +20/−13
- src/Development/IDE/Import/FindImports.hs +21/−15
- src/Development/IDE/LSP/HoverDefinition.hs +2/−2
- src/Development/IDE/LSP/LanguageServer.hs +16/−20
- src/Development/IDE/LSP/Notifications.hs +5/−10
- src/Development/IDE/LSP/Outline.hs +27/−17
- src/Development/IDE/LSP/Server.hs +3/−3
- src/Development/IDE/Main.hs +69/−52
- src/Development/IDE/Main/HeapStats.hs +1/−1
- src/Development/IDE/Monitoring/EKG.hs +1/−0
- src/Development/IDE/Monitoring/OpenTelemetry.hs +2/−2
- src/Development/IDE/Plugin/Completions.hs +22/−15
- src/Development/IDE/Plugin/Completions/Logic.hs +65/−55
- src/Development/IDE/Plugin/Completions/Types.hs +13/−6
- src/Development/IDE/Plugin/HLS.hs +14/−23
- src/Development/IDE/Plugin/HLS/GhcIde.hs +4/−4
- src/Development/IDE/Plugin/Test.hs +0/−1
- src/Development/IDE/Plugin/TypeLenses.hs +128/−97
- src/Development/IDE/Spans/AtPoint.hs +25/−23
- src/Development/IDE/Spans/Documentation.hs +15/−17
- src/Development/IDE/Spans/Pragmas.hs +16/−15
- src/Development/IDE/Types/Exports.hs +10/−13
- src/Development/IDE/Types/HscEnvEq.hs +1/−1
- src/Development/IDE/Types/Location.hs +11/−7
- src/Development/IDE/Types/Options.hs +3/−2
- src/Generics/SYB/GHC.hs +1/−1
- test/exe/AsyncTests.hs +2/−2
- test/exe/ClientSettingsTests.hs +4/−3
- test/exe/CodeLensTests.hs +20/−12
- test/exe/InitializeResponseTests.hs +1/−1
- test/exe/TestUtils.hs +4/−2
- test/src/Development/IDE/Test.hs +2/−5
ghcide.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-version: 2.1.0.0+version: 2.2.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors@@ -35,6 +35,11 @@ default: False manual: True +flag pedantic+ description: Enable -Werror+ default: False+ manual: True+ library default-language: Haskell2010 build-depends:@@ -65,12 +70,12 @@ haddock-library >= 1.8 && < 1.12, hashable, hie-compat ^>= 0.3.0.0,- hls-plugin-api == 2.1.0.0,+ hls-plugin-api == 2.2.0.0, lens, list-t, hiedb == 0.4.3.*,- lsp-types ^>= 2.0.1.0,- lsp ^>= 2.1.0.0 ,+ lsp-types ^>= 2.0.2.0,+ lsp ^>= 2.2.0.0 , mtl, optparse-applicative, parallel,@@ -81,7 +86,7 @@ row-types, text-rope, safe-exceptions,- hls-graph == 2.1.0.0,+ hls-graph == 2.2.0.0, sorted-list, sqlite-simple, stm,@@ -221,7 +226,6 @@ ghc-options: -Wall- -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -fno-ignore-asserts@@ -229,6 +233,27 @@ if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if flag(pedantic)+ -- We eventually want to build with Werror fully, but we haven't+ -- finished purging the warnings, so some are set to not be errors+ -- for now+ ghc-options: -Werror + -Wwarn=unused-packages+ -Wwarn=unrecognised-pragmas+ -Wwarn=dodgy-imports+ -Wwarn=missing-signatures+ -Wwarn=duplicate-exports+ -Wwarn=dodgy-exports+ -Wwarn=incomplete-patterns+ -Wwarn=overlapping-patterns+ -Wwarn=incomplete-record-updates+ + -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it+ -- then. The above comment goes for here too -- this should be understood to+ -- be temporary until we can remove these warnings.+ if impl(ghc >= 9.2) && flag(pedantic)+ ghc-options: -Wwarn=ambiguous-fields+ if impl(ghc >= 9) ghc-options: -Wunused-packages @@ -346,7 +371,7 @@ hls-plugin-api, lens, list-t,- lsp-test ^>= 0.15.0.1,+ lsp-test ^>= 0.16.0.0, mtl, monoid-subclasses, network-uri,
session-loader/Development/IDE/Session.hs view
@@ -34,13 +34,14 @@ import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B+import Data.Char (isLower) import Data.Default import Data.Either.Extra import Data.Function-import Data.Hashable+import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM-import Data.IORef import Data.List+import Data.List.Extra (dropPrefix, split) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy@@ -49,11 +50,11 @@ import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, Priority,- withHieDb)+ knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule,- Var, Warning)+ Var, Warning, getOptions) import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId)@@ -68,6 +69,7 @@ import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios+import qualified HIE.Bios.Cradle as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios@@ -108,6 +110,12 @@ import qualified System.Random as Random import System.Random (RandomGen) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,4,0)+import Data.IORef+#endif+ data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void)@@ -145,21 +153,21 @@ , "Cradle:" <+> viaShow cradle ] LogGetInitialGhcLibDirDefaultCradleNone -> "Couldn't load cradle. Cradle not found."- LogHieDbRetry delay maxDelay maxRetryCount e ->+ LogHieDbRetry delay maxDelay retriesRemaining e -> nest 2 $ vcat [ "Retrying hiedb action..." , "delay:" <+> pretty delay , "maximum delay:" <+> pretty maxDelay- , "retries remaining:" <+> pretty maxRetryCount+ , "retries remaining:" <+> pretty retriesRemaining , "SQLite error:" <+> pretty (displayException e) ]- LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e ->+ LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e -> nest 2 $ vcat [ "Retries exhausted for hiedb action." , "base delay:" <+> pretty baseDelay , "maximum delay:" <+> pretty maxDelay- , "retries remaining:" <+> pretty maxRetryCount+ , "retries remaining:" <+> pretty retriesRemaining , "Exception:" <+> pretty (displayException e) ] LogHieDbWriterThreadSQLiteError e -> nest 2 $@@ -196,7 +204,7 @@ "Cradle:" <+> viaShow cradle LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> viaShow componentCache- LogHieBios log -> pretty log+ LogHieBios msg -> pretty msg -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String@@ -260,17 +268,16 @@ getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) getInitialGhcLibDirDefault recorder rootDir = do- let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir libDirRes <- getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do- log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle+ logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do- log Warning LogGetInitialGhcLibDirDefaultCradleNone+ logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir@@ -298,28 +305,26 @@ -> g -- ^ random number generator -> m a -- ^ action that may throw exception -> m a-retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do+retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do result <- tryJust exceptionPred action case result of Left e- | maxRetryCount > 0 -> do+ | maxTimesRetry > 0 -> do -- multiply by 2 because baseDelay is midpoint of uniform range let newBaseDelay = min maxDelay (baseDelay * 2) let (delay, newRng) = Random.randomR (0, newBaseDelay) rng- let newMaxRetryCount = maxRetryCount - 1+ let newMaxTimesRetry = maxTimesRetry - 1 liftIO $ do- log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e)+ logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e) threadDelay delay- retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action+ retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action | otherwise -> do liftIO $ do- log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e)+ logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e) throwIO e Right b -> pure b- where- log = logWith recorder -- | in microseconds oneSecond :: Int@@ -374,21 +379,19 @@ withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) where- log = logWith recorder- writerThread :: WithHieDb -> IndexQueue -> IO () writerThread withHieDbRetryable chan = do -- Clear the index of any files that might have been deleted since the last run _ <- withHieDbRetryable deleteMissingRealFiles _ <- withHieDbRetryable garbageCollectTypeNames forever $ do- k <- atomically $ readTQueue chan+ l <- atomically $ readTQueue chan -- TODO: probably should let exceptions be caught/logged/handled by top level handler- k withHieDbRetryable+ l withHieDbRetryable `Safe.catch` \e@SQLError{} -> do- log Error $ LogHieDbWriterThreadSQLiteError e- `Safe.catchAny` \e -> do- log Error $ LogHieDbWriterThreadException e+ logWith recorder Error $ LogHieDbWriterThreadSQLiteError e+ `Safe.catchAny` \f -> do+ logWith recorder Error $ LogHieDbWriterThreadException f getHieDbLoc :: FilePath -> IO FilePath@@ -517,7 +520,7 @@ -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information.- + new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component@@ -529,7 +532,7 @@ #if MIN_VERSION_ghc(9,3,0) let (df2, uids) = (rawComponentDynFlags, []) #else- let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags+ let (df2, uids) = _removeInplacePackages fakeUid inplace rawComponentDynFlags #endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files]@@ -551,11 +554,11 @@ -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand- log Info $ LogMakingNewHscEnv inplace- hscEnv <- emptyHscEnv ideNc libDir+ logWith recorder Info $ LogMakingNewHscEnv inplace+ hscEnvB <- emptyHscEnv ideNc libDir !newHscEnv <- -- Add the options for the current component to the HscEnv- evalGhcEnv hscEnv $ do+ evalGhcEnv hscEnvB $ do _ <- setSessionDynFlags #if !MIN_VERSION_ghc(9,3,0) $ setHomeUnitId_ fakeUid@@ -592,7 +595,7 @@ res <- loadDLL hscEnv "libm.so.6" case res of Nothing -> pure ()- Just err -> log Error $ LogDLLLoadError err+ Just err -> logWith recorder Error $ LogDLLLoadError err -- Make a map from unit-id to DynFlags, this is used when trying to@@ -634,21 +637,22 @@ let cs_exist = catMaybes (zipWith (<$) cfps' mmt) modIfaces <- uses GetModIface cs_exist -- update exports map- extras <- getShakeExtras+ shakeExtras <- getShakeExtras let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces- liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>)+ liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return (second Map.keys res) let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do- lfp <- flip makeRelative cfp <$> getCurrentDirectory- log Info $ LogCradlePath lfp+ lfpLog <- flip makeRelative cfp <$> getCurrentDirectory+ logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $- log Warning $ LogCradleNotFound lfp+ logWith recorder Warning $ LogCradleNotFound lfpLog cradle <- loadCradle hieYaml dir+ -- TODO: Why are we repeating the same command we have on line 646? lfp <- flip makeRelative cfp <$> getCurrentDirectory when optTesting $ mRunLspT lspEnv $@@ -664,7 +668,7 @@ addTag "result" (show res) return res - log Debug $ LogSessionLoadingResult eopts+ logWith recorder Debug $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv.@@ -681,7 +685,7 @@ Left err -> do dep_info <- getDependencyInfo (maybeToList hieYaml) let ncfp = toNormalizedFilePath' cfp- let res = (map (renderCradleError ncfp) err, Nothing)+ let res = (map (renderCradleError cradle ncfp) err, Nothing) void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) void $ modifyVar' filesMap $ HM.insert ncfp hieYaml@@ -724,11 +728,9 @@ opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do -- If the cradle is not finished, then wait for it to finish. void $ wait as- as <- async $ getOptions file- return (as, wait as)+ asyncRes <- async $ getOptions file+ return (asyncRes, wait asyncRes) pure opts- where- log = logWith recorder -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the@@ -784,14 +786,14 @@ -> DependencyInfo -> IO [TargetDetails] -- For a target module we consider all the import paths-fromTargetId is exts (GHC.TargetModule mod) env dep = do- let fps = [i </> moduleNameSlashes mod -<.> ext <> boot+fromTargetId is exts (GHC.TargetModule modName) env dep = do+ let fps = [i </> moduleNameSlashes modName -<.> ext <> boot | ext <- exts , i <- is , boot <- ["", "-boot"] ] locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps- return [TargetDetails (TargetModule mod) env dep locs]+ return [TargetDetails (TargetModule modName) env dep locs] -- For a 'TargetFile' we consider all the possible module names fromTargetId _ _ (GHC.TargetFile f _) env deps = do nf <- toNormalizedFilePath' <$> makeAbsolute f@@ -924,10 +926,71 @@ & maybe id setODir oCacheDir -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic-renderCradleError nfp (CradleError _ _ec t) =- ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines (map T.pack t))+renderCradleError :: Cradle a -> NormalizedFilePath -> CradleError -> FileDiagnostic+renderCradleError cradle nfp (CradleError _ _ec ms) =+ ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage+ where + userFriendlyMessage :: [String]+ userFriendlyMessage+ | HieBios.isCabalCradle cradle = fromMaybe ms fileMissingMessage+ | otherwise = ms++ fileMissingMessage :: Maybe [String]+ fileMissingMessage =+ multiCradleErrMessage <$> parseMultiCradleErr ms++-- | Information included in Multi Cradle error messages+data MultiCradleErr = MultiCradleErr+ { mcPwd :: FilePath+ , mcFilePath :: FilePath+ , mcPrefixes :: [(FilePath, String)]+ } deriving (Show)++-- | Attempt to parse a multi-cradle message+parseMultiCradleErr :: [String] -> Maybe MultiCradleErr+parseMultiCradleErr ms = do+ _ <- lineAfter "Multi Cradle: "+ wd <- lineAfter "pwd: "+ fp <- lineAfter "filepath: "+ ps <- prefixes+ pure $ MultiCradleErr wd fp ps++ where+ lineAfter :: String -> Maybe String+ lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms++ prefixes :: Maybe [(FilePath, String)]+ prefixes = do+ pure $ mapMaybe tuple ms++ tuple :: String -> Maybe (String, String)+ tuple line = do+ line' <- surround '(' line ')'+ [f, s] <- pure $ split (==',') line'+ pure (f, s)++ -- extracts the string surrounded by required characters+ surround :: Char -> String -> Char -> Maybe String+ surround start s end = do+ guard (listToMaybe s == Just start)+ guard (listToMaybe (reverse s) == Just end)+ pure $ drop 1 $ take (length s - 1) s++multiCradleErrMessage :: MultiCradleErr -> [String]+multiCradleErrMessage e =+ [ "Loading the module '" <> moduleFileName <> "' failed. It may not be listed in your .cabal file!"+ , "Perhaps you need to add `"<> moduleName <> "` to other-modules or exposed-modules."+ , "For more information, visit: https://cabal.readthedocs.io/en/3.4/developing-packages.html#modules-included-in-the-package"+ , ""+ ] <> map prefix (mcPrefixes e)+ where+ localFilePath f = dropWhile (==pathSeparator) $ dropPrefix (mcPwd e) f+ moduleFileName = localFilePath $ mcFilePath e+ moduleName = intercalate "." $ map dropExtension $ dropWhile isSourceFolder $ splitDirectories moduleFileName+ isSourceFolder p = all isLower $ take 1 p+ prefix (f, r) = f <> " - " <> r+ -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])@@ -995,11 +1058,11 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs where- tryIO :: IO a -> IO (Either IOException a)- tryIO = Safe.try+ safeTryIO :: IO a -> IO (Either IOException a)+ safeTryIO = Safe.try do_one :: FilePath -> IO (FilePath, Maybe UTCTime)- do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)+ do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) -- | This function removes all the -package flags which refer to packages we -- are going to deal with ourselves. For example, if a executable depends@@ -1009,12 +1072,12 @@ -- There are several places in GHC (for example the call to hptInstances in -- tcRnImports) which assume that all modules in the HPT have the same unit -- ID. Therefore we create a fake one and give them all the same unit id.-removeInplacePackages+_removeInplacePackages --Only used in ghc < 9.4 :: UnitId -- ^ fake uid to use for our internal component -> [UnitId] -> DynFlags -> (DynFlags, [UnitId])-removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $+_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ df { packageFlags = ps }, uids) where (uids, ps) = Compat.filterInplaceUnits us (packageFlags df)
src/Development/IDE/Core/Actions.hs view
@@ -67,7 +67,7 @@ !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Loacation, determine if we have the PositionMapping+-- | For each Location, determine if we have the PositionMapping -- for the correct file. If not, get the correct position mapping -- and then apply the position mapping to the location. toCurrentLocations
src/Development/IDE/Core/Compile.hs view
@@ -39,14 +39,15 @@ , shareUsages ) where +import Prelude hiding (mod) import Control.Monad.IO.Class import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse)-import Control.DeepSeq (NFData (..), force, liftRnf,- rnf, rwhnf)+import Control.DeepSeq (NFData (..), force,+ rnf) import Control.Exception (evaluate) import Control.Exception.Safe-import Control.Lens hiding (List, (<.>))+import Control.Lens hiding (List, (<.>), pre) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except@@ -62,13 +63,10 @@ import Data.Generics.Schemes import qualified Data.HashMap.Strict as HashMap import Data.IntMap (IntMap)-import qualified Data.IntMap.Strict as IntMap import Data.IORef import Data.List.Extra-import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy(Proxy))-import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime (..))@@ -96,11 +94,10 @@ import Development.IDE.Types.Options import GHC (ForeignHValue, GetDocsFailure (..),- GhcException (..), parsedSource) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized-import HieDb+import HieDb hiding (withHieDb) import qualified Language.LSP.Server as LSP import Language.LSP.Protocol.Types (DiagnosticTag (..)) import qualified Language.LSP.Protocol.Types as LSP@@ -108,44 +105,56 @@ import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin)-import Unsafe.Coerce +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,1)+import HscTypes+import TcSplice+#endif+ #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice+#endif +#if MIN_VERSION_ghc(9,0,1) && !MIN_VERSION_ghc(9,2,1)+import GHC.Driver.Types+#endif++#if !MIN_VERSION_ghc(9,2,0)+import qualified Data.IntMap.Strict as IntMap+#endif++#if MIN_VERSION_ghc(9,2,0)+import qualified GHC as G+#endif++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC (ModuleGraph)+#endif+ #if MIN_VERSION_ghc(9,2,1) import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.TypeEnv-#else-import GHC.Driver.Types #endif -#else-import HscTypes-import TcSplice+#if !MIN_VERSION_ghc(9,3,0)+import Data.Map (Map)+import GHC (GhcException (..))+import Unsafe.Coerce #endif -#if MIN_VERSION_ghc(9,2,0)-import GHC (Anchor (anchor),- EpaComment (EpaComment),- EpaCommentTok (EpaBlockComment, EpaLineComment),- ModuleGraph, epAnnComments,- mgLookupModule,- mgModSummaries,- priorComments)-import qualified GHC as G-import GHC.Hs (LEpaComment)-import qualified GHC.Types.Error as Error-import Development.IDE.Import.DependencyInformation+#if MIN_VERSION_ghc(9,3,0)+import qualified Data.Set as Set #endif #if MIN_VERSION_ghc(9,5,0)-import GHC.Driver.Config.CoreToStg.Prep-import GHC.Core.Lint.Interactive+import GHC.Driver.Config.CoreToStg.Prep+import GHC.Core.Lint.Interactive #endif ---Simple constansts to make sure the source is consistently named+--Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck" sourceParser :: T.Text@@ -178,7 +187,7 @@ newtype TypecheckHelpers = TypecheckHelpers- { getLinkables :: ([NormalizedFilePath] -> IO [LinkableResult]) -- ^ hls-graph action to get linkables for files+ { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files } typecheckModule :: IdeDefer@@ -193,14 +202,14 @@ (initPlugins hsc modSummary) case initialized of Left errs -> return (errs, Nothing)- Right (modSummary', hsc) -> do+ Right (modSummary', hscEnv) -> do (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak -> let- session = tweak (hscSetFlags dflags hsc)+ session = tweak (hscSetFlags dflags hscEnv) -- TODO: maybe settings ms_hspp_opts is unnecessary? mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} in- catchSrcErrors (hsc_dflags hsc) sourceTypecheck $ do+ catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings@@ -335,8 +344,8 @@ ; moduleLocs <- readIORef (hsc_FC hsc_env) #endif ; lbs <- getLinkables [toNormalizedFilePath' file- | mod <- mods_transitive_list- , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod+ | installedMod <- mods_transitive_list+ , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod file = case ifr of InstalledFound loc _ -> fromJust $ ml_hs_file loc@@ -366,8 +375,8 @@ -- We shouldn't get boot files here, but to be safe, never map them to an installed module -- because boot files don't have linkables we can load, and we will fail if we try to look -- for them- nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod IsBoot) uid)) = Nothing- nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod+ nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing+ nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName nodeKeyToInstalledModule _ = Nothing moduleToNodeKey :: Module -> NodeKey moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)@@ -434,8 +443,8 @@ hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env ((tc_gbl_env', mrn_info), splices, mod_env)- <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp ->- do hscTypecheckRename hsc_env_tmp ms $+ <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->+ do hscTypecheckRename hscEnvTmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod }@@ -508,7 +517,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm- tcGblEnv = tmrTypechecked tcm (details, guts) <- do -- write core file@@ -553,9 +561,9 @@ -- The serialized file however is much more compact and only requires a few -- hundred megabytes of memory total even in a large project with 1000s of -- modules- (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp+ (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp pure $ assert (core_hash1 == core_hash2)- $ Just (core_file, fingerprintToBS core_hash2)+ $ Just (coreFile, fingerprintToBS core_hash2) -- Verify core file by roundtrip testing and comparison IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se@@ -594,8 +602,8 @@ (prepd_binds', _) #endif <- corePrep unprep_binds' data_tycons- let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds- binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'+ let binds = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds+ binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds' -- diffBinds is unreliable, sometimes it goes down the wrong track. -- This fixes the order of the bindings so that it is less likely to do so.@@ -849,9 +857,9 @@ where dflags = hsc_dflags hscEnv #if MIN_VERSION_ghc(9,0,0)- run ts =+ run _ts = -- ts is only used in GHC 9.2 #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)- fmap (join . snd) . liftIO . initDs hscEnv ts+ fmap (join . snd) . liftIO . initDs hscEnv _ts #else id #endif@@ -910,8 +918,8 @@ -- 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- pending <- readTVar indexPending- pure $ case HashMap.lookup srcPath pending of+ pendingOps <- readTVar indexPending+ pure $ case HashMap.lookup srcPath pendingOps of Nothing -> False -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash@@ -957,8 +965,8 @@ progressPct :: LSP.UInt progressPct = floor $ 100 * progressFrac - whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $- LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $+ whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $+ LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ toJSON $ case style of Percentage -> LSP.WorkDoneProgressReport@@ -998,8 +1006,8 @@ whenJust mdone $ \done -> modifyVar_ indexProgressToken $ \tok -> do whenJust (lspEnv se) $ \env -> LSP.runLspT env $- whenJust tok $ \tok ->- LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $+ whenJust tok $ \token ->+ LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ toJSON $ LSP.WorkDoneProgressEnd { _kind = LSP.AString @"end"@@ -1079,7 +1087,7 @@ -- Prefer non-boot files over non-boot files -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816 -- if a boot file shadows over a non-boot file- combineModuleLocations a@(InstalledFound ml m) b | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a+ combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a combineModuleLocations _ b = b concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache@@ -1128,11 +1136,12 @@ -> UTCTime -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult-getModSummaryFromImports env fp modTime contents = do-- (contents, opts, env, src_hash) <- preprocessor env fp contents+-- modTime is only used in GHC < 9.4+getModSummaryFromImports env fp _modTime mContents = do+-- src_hash is only used in GHC >= 9.4+ (contents, opts, ppEnv, _src_hash) <- preprocessor env fp mContents - let dflags = hsc_dflags env+ let dflags = hsc_dflags ppEnv -- The warns will hopefully be reported when we actually parse the module (_warns, L main_loc hsmod) <- parseHeader dflags fp contents@@ -1146,7 +1155,8 @@ (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it.- (ordinary_imps, ghc_prim_imports)+ -- ghc_prim_imports is only used in GHC >= 9.4+ (ordinary_imps, _ghc_prim_imports) = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) ord_idecls@@ -1166,11 +1176,11 @@ msrImports = implicit_imports ++ imps #if MIN_VERSION_ghc (9,3,0)- rn_pkg_qual = renameRawPkgQual (hsc_unit_env env)+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv) rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) srcImports = rn_imps $ map convImport src_idecls textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps)- ghc_prim_import = not (null ghc_prim_imports)+ ghc_prim_import = not (null _ghc_prim_imports) #else srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps)@@ -1188,7 +1198,7 @@ then mkHomeModLocation dflags (pathToModuleName fp) fp else mkHomeModLocation dflags mod fp - let modl = mkHomeModule (hscHomeUnit env) mod+ let modl = mkHomeModule (hscHomeUnit ppEnv) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary2 = ModSummary@@ -1197,10 +1207,10 @@ #if MIN_VERSION_ghc(9,3,0) , ms_dyn_obj_date = Nothing , ms_ghc_prim_import = ghc_prim_import- , ms_hs_hash = src_hash+ , ms_hs_hash = _src_hash #else- , ms_hs_date = modTime+ , ms_hs_date = _modTime #endif , ms_hsc_src = sourceType -- The contents are used by the GetModSummary rule@@ -1216,7 +1226,7 @@ } msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2- (msrModSummary, msrHscEnv) <- liftIO $ initPlugins env msrModSummary2+ (msrModSummary, msrHscEnv) <- liftIO $ initPlugins ppEnv msrModSummary2 return ModSummaryResult{..} where -- Compute a fingerprint from the contents of `ModSummary`,@@ -1304,7 +1314,7 @@ let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages- let (warns, errs) = renderMessages msgs+ let (warns, errors) = renderMessages msgs -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser@@ -1315,8 +1325,8 @@ -- further errors/warnings can be collected). Fatal -- errors are those from which a parse tree just can't -- be produced.- unless (null errs) $- throwE $ diagFromErrMsgs sourceParser dflags errs+ unless (null errors) $+ throwE $ diagFromErrMsgs sourceParser dflags errors -- To get the list of extra source files, we take the list@@ -1468,19 +1478,21 @@ -- The source is modified if it is newer than the destination (iface file) -- A more precise check for the core file is performed later- let sourceMod = case mb_dest_version of+ let _sourceMod = case mb_dest_version of -- sourceMod is only used in GHC < 9.4 Nothing -> SourceModified -- destination file doesn't exist, assume modified source Just dest_version | source_version <= dest_version -> SourceUnmodified | otherwise -> SourceModified - old_iface <- case mb_old_iface of+ -- old_iface is only used in GHC >= 9.4+ _old_iface <- case mb_old_iface of Just iface -> pure (Just iface) Nothing -> do- let ncu = hsc_NC sessionWithMsDynFlags- read_dflags = hsc_dflags sessionWithMsDynFlags+ -- ncu and read_dflags are only used in GHC >= 9.4+ let _ncu = hsc_NC sessionWithMsDynFlags+ _read_dflags = hsc_dflags sessionWithMsDynFlags #if MIN_VERSION_ghc(9,3,0)- read_result <- liftIO $ readIface read_dflags ncu mod iface_file+ read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file #else read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags $ readIface mod iface_file@@ -1495,11 +1507,11 @@ -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) #if MIN_VERSION_ghc(9,3,0)- <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case+ <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case UpToDateItem x -> pure (UpToDate, Just x) OutOfDateItem reason x -> pure (NeedsRecompile reason, x) #else- <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface+ <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface #endif let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do@@ -1521,10 +1533,10 @@ Just msg -> do_regenerate msg Nothing | isJust linkableNeeded -> handleErrs $ do- (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $+ (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ readBinCoreFile (mkUpdater $ hsc_NC session) core_file if cf_iface_hash == getModuleHash iface- then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash)))+ then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash))) else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) where handleErrs = flip catches@@ -1578,6 +1590,7 @@ _ -> pure $ Just $ recompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) +recompBecause :: String -> RecompileRequired recompBecause = #if MIN_VERSION_ghc(9,3,0) NeedsRecompile .@@ -1622,15 +1635,15 @@ }) core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file -- Implicit binds aren't saved, so we need to regenerate them ourselves.- let implicit_binds = concatMap getImplicitBinds tyCons+ let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6 tyCons = typeEnvTyCons (md_types details) #if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, the implicit binds are tidied and part of core_binds pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #elif MIN_VERSION_ghc(9,3,0)- pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing []+ pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #else- pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing []+ pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] #endif coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo)@@ -1689,8 +1702,7 @@ #else Map.findWithDefault mempty name amap)) #endif- return $ map (first $ T.unpack . printOutputable)- $ res+ return $ map (first $ T.unpack . printOutputable) res where compiled n = -- TODO: Find a more direct indicator.@@ -1706,7 +1718,7 @@ -> IO (Maybe TyThing) lookupName _ name | Nothing <- nameModule_maybe name = pure Nothing-lookupName hsc_env name = handle $ do+lookupName hsc_env name = exceptionHandle $ do #if MIN_VERSION_ghc(9,2,0) mb_thing <- liftIO $ lookupType hsc_env name #else@@ -1726,7 +1738,7 @@ Util.Succeeded x -> return (Just x) _ -> return Nothing where- handle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing+ exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing pathToModuleName :: FilePath -> ModuleName pathToModuleName = mkModuleName . map rep@@ -1734,3 +1746,32 @@ rep c | isPathSeparator c = '_' rep ':' = '_' rep c = c++{- Note [Guidelines For Using CPP In GHCIDE Import Statements]+ GHCIDE's interface with GHC is extensive, and unfortunately, because we have+ to work with multiple versions of GHC, we have several files that need to use+ a lot of CPP. In order to simplify the CPP in the import section of every file+ we have a few specific guidelines for using CPP in these sections.++ - We don't want to nest CPP clauses, nor do we want to use else clauses. Both+ nesting and else clauses end up drastically complicating the code, and require+ significant mental stack to unwind.++ - CPP clauses should be placed at the end of the imports section. The clauses+ should be ordered by the GHC version they target from earlier to later versions,+ with negative if clauses coming before positive if clauses of the same + version. (If you think about which GHC version a clause activates for this + should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is+ a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 + and later). In addition there should be a space before and after each CPP+ clause.++ - In if clauses that use `&&` and depend on more than one statement, the + positive statement should come before the negative statement. In addition the+ clause should come after the single positive clause for that GHC version.++ - There shouldn't be multiple identical CPP statements. The use of odd or even + GHC numbers is identical, with the only preference being to use what is+ already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` + are functionally equivalent)+-}
src/Development/IDE/Core/FileExists.hs view
@@ -95,8 +95,8 @@ instance Pretty Log where pretty = \case- LogFileStore log -> pretty log- LogShake log -> pretty log+ LogFileStore msg -> pretty msg+ LogShake msg -> pretty msg -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap
src/Development/IDE/Core/FileStore.hs view
@@ -1,6 +1,5 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore(@@ -28,16 +27,22 @@ import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class+import qualified Data.Binary as B import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap import Data.IORef+import Data.List (foldl') import qualified Data.Text as T+import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope as Rope import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils+import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log)+import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation@@ -45,24 +50,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import HieDb.Create (deleteMissingRealFiles)-import Ide.Plugin.Config (CheckParents (..),- Config)-import System.IO.Error--#ifdef mingw32_HOST_OS-import qualified System.Directory as Dir-#else-#endif--import qualified Ide.Logger as L--import Data.Aeson (ToJSON (toJSON))-import qualified Data.Binary as B-import qualified Data.ByteString.Lazy as LBS-import Data.List (foldl')-import qualified Data.Text as Text-import Development.IDE.Core.IdeConfiguration (isWorkspaceFile)-import qualified Development.IDE.Core.Shake as Shake import Ide.Logger (Pretty (pretty), Priority (Info), Recorder,@@ -70,6 +57,9 @@ cmapWithPrio, logWith, viaShow, (<+>))+import qualified Ide.Logger as L+import Ide.Plugin.Config (CheckParents (..),+ Config) import Language.LSP.Protocol.Message (toUntypedRegistration) import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),@@ -79,8 +69,10 @@ import qualified Language.LSP.Server as LSP import Language.LSP.VFS import System.FilePath+import System.IO.Error import System.IO.Unsafe + data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])@@ -96,7 +88,7 @@ <+> viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths)- LogShake log -> pretty log+ LogShake msg -> pretty msg addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do@@ -243,11 +235,10 @@ typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph- let log = logWith recorder case revs of- Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp+ Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do- log Info $ LogTypeCheckingReverseDeps nfp revs+ logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session
src/Development/IDE/Core/FileUtils.hs view
@@ -6,6 +6,7 @@ import Data.Time.Clock.POSIX+ #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else
src/Development/IDE/Core/IdeConfiguration.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DuplicateRecordFields #-} module Development.IDE.Core.IdeConfiguration ( IdeConfiguration(..) , registerIdeConfiguration@@ -13,13 +12,13 @@ where import Control.Concurrent.Strict-import Control.Lens ((^.))+ import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) import Data.Hashable (Hashed, hashed, unhashed) import Data.HashSet (HashSet, singleton)-import Data.Text (Text, isPrefixOf)+import Data.Text (isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location
src/Development/IDE/Core/OfInterest.hs view
@@ -55,7 +55,7 @@ instance Pretty Log where pretty = \case- LogShake log -> pretty log+ LogShake msg -> pretty msg newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
src/Development/IDE/Core/PluginUtils.hs view
@@ -1,5 +1,29 @@ {-# LANGUAGE GADTs #-}-module Development.IDE.Core.PluginUtils where+module Development.IDE.Core.PluginUtils+(-- Wrapped Action functions+ runActionE+, runActionMT+, useE+, useMT+, usesE+, usesMT+, useWithStaleE+, useWithStaleMT+-- Wrapped IdeAction functions+, runIdeActionE+, runIdeActionMT+, useWithStaleFastE+, useWithStaleFastMT+, uriToFilePathE+-- Wrapped PositionMapping functions+, toCurrentPositionE+, toCurrentPositionMT+, fromCurrentPositionE+, fromCurrentPositionMT+, toCurrentRangeE+, toCurrentRangeMT+, fromCurrentRangeE+, fromCurrentRangeMT) where import Control.Monad.Extra import Control.Monad.IO.Class
src/Development/IDE/Core/PositionMapping.hs view
@@ -104,7 +104,7 @@ zeroMapping = PositionMapping idDelta -- | Compose two position mappings. Composes in the same way as function--- composition (ie the second argument is applyed to the position first).+-- composition (ie the second argument is applied to the position first). composeDelta :: PositionDelta -> PositionDelta -> PositionDelta@@ -219,9 +219,9 @@ line' -> PositionExact (Position (fromIntegral line') col) -- Construct a mapping between lines in the diff- -- -1 for unsucessful mapping+ -- -1 for unsuccessful mapping go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) go [] _ _ = ([],[])- go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1)- go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew- go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1)+ go (Both _ _ : xs) !glold !glnew = bimap (glnew :) (glold :) $ go xs (glold+1) (glnew+1)+ go (First _ : xs) !glold !glnew = first (-1 :) $ go xs (glold+1) glnew+ go (Second _ : xs) !glold !glnew = second (-1 :) $ go xs glold (glnew+1)
src/Development/IDE/Core/Preprocessor.hs view
@@ -30,9 +30,11 @@ import qualified GHC.LanguageExtensions as LangExt import System.FilePath import System.IO.Extra++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+ #if MIN_VERSION_ghc(9,3,0) import GHC.Utils.Logger (LogFlags (..))-import GHC.Utils.Outputable (renderWithContext) #endif -- | Given a file and some contents, apply any necessary preprocessors,@@ -54,17 +56,17 @@ !src_hash <- liftIO $ Util.fingerprintFromStringBuffer contents -- Perform cpp- (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents- let dflags = hsc_dflags env- let logger = hsc_logger env- (isOnDisk, contents, opts, env) <-+ (opts, pEnv) <- ExceptT $ parsePragmasIntoHscEnv env filename contents+ let dflags = hsc_dflags pEnv+ let logger = hsc_logger pEnv+ (newIsOnDisk, newContents, newOpts, newEnv) <- if not $ xopt LangExt.Cpp dflags then- return (isOnDisk, contents, opts, env)+ return (isOnDisk, contents, opts, pEnv) else do cppLogs <- liftIO $ newIORef [] let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger- contents <- ExceptT- $ (Right <$> (runCpp (putLogHook newLogger env) filename+ con <- ExceptT+ $ (Right <$> (runCpp (putLogHook newLogger pEnv) filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: Util.GhcException) -> do@@ -73,25 +75,25 @@ [] -> throw e diags -> return $ Left diags )- (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents- return (False, contents, opts, env)+ (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv pEnv filename con+ return (False, con, options, hscEnv) -- Perform preprocessor if not $ gopt Opt_Pp dflags then- return (contents, opts, env, src_hash)+ return (newContents, newOpts, newEnv, src_hash) else do- contents <- liftIO $ runPreprocessor env filename $ if isOnDisk then Nothing else Just contents- (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents- return (contents, opts, env, src_hash)+ con <- liftIO $ runPreprocessor newEnv filename $ if newIsOnDisk then Nothing else Just newContents+ (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv newEnv filename con+ return (con, options, hscEnv, src_hash) where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do #if MIN_VERSION_ghc(9,3,0)- let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg+ let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg #else- let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg+ let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg #endif- modifyIORef cppLogs (log :)+ modifyIORef cppLogs (cppLog :) @@ -118,12 +120,12 @@ -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc- go acc (CPPLog sev (RealSrcSpan span _) msg : logs) =- let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]- in go (diag : acc) logs- go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =- go (diag {cdMessage = msg : cdMessage diag} : diags) logs- go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs+ go acc (CPPLog sev (RealSrcSpan rSpan _) msg : gLogs) =+ let diag = CPPDiag (realSrcSpanToRange rSpan) (toDSeverity sev) [msg]+ in go (diag : acc) gLogs+ go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : gLogs) =+ go (diag {cdMessage = msg : cdMessage diag} : diags) gLogs+ go [] (CPPLog _sev (UnhelpfulSpan _) _msg : gLogs) = go [] gLogs cppDiagToDiagnostic :: CPPDiag -> Diagnostic cppDiagToDiagnostic d = Diagnostic@@ -196,12 +198,12 @@ -- | Run CPP on a file runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer-runCpp env0 filename contents = withTempDir $ \dir -> do+runCpp env0 filename mbContents = withTempDir $ \dir -> do let out = dir </> takeFileName filename <.> "out" let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) let env1 = hscSetFlags dflags1 env0 - case contents of+ case mbContents of Nothing -> do -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work@@ -225,21 +227,21 @@ -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" let tweak x- | Just x <- stripPrefix "# " x- , "___GHCIDE_MAGIC___" `isInfixOf` x- , let num = takeWhile (not . isSpace) x+ | Just y <- stripPrefix "# " x+ , "___GHCIDE_MAGIC___" `isInfixOf` y+ , let num = takeWhile (not . isSpace) y -- important to use /, and never \ for paths, even on Windows, since then C escapes them -- and GHC gets all confused- = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""+ = "# " <> num <> " \"" <> map (\z -> if isPathSeparator z then '/' else z) filename <> "\"" | otherwise = x Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer-runPreprocessor env filename contents = withTempDir $ \dir -> do+runPreprocessor env filename mbContents = withTempDir $ \dir -> do let out = dir </> takeFileName filename <.> "out"- inp <- case contents of+ inp <- case mbContents of Nothing -> return filename Just contents -> do let inp = dir </> takeFileName filename <.> "hs"
src/Development/IDE/Core/ProgressReporting.hs view
@@ -18,7 +18,7 @@ modifyTVar', newTVarIO, readTVarIO) import Control.Concurrent.Strict-import Control.Monad.Extra+import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON (toJSON))@@ -112,7 +112,7 @@ -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting-delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting+delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting delayedProgressReporting before after (Just lspEnv) optProgressStyle = do inProgressState <- newInProgress progressState <- newVar NotStarted@@ -136,9 +136,9 @@ ready <- waitBarrier b LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where- start id = LSP.sendNotification SMethod_Progress $+ start token = LSP.sendNotification SMethod_Progress $ LSP.ProgressParams- { _token = id+ { _token = token , _value = toJSON $ WorkDoneProgressBegin { _kind = AString @"begin" , _title = "Processing"@@ -147,9 +147,9 @@ , _percentage = Nothing } }- stop id = LSP.sendNotification SMethod_Progress+ stop token = LSP.sendNotification SMethod_Progress LSP.ProgressParams- { _token = id+ { _token = token , _value = toJSON $ WorkDoneProgressEnd { _kind = AString @"end" , _message = Nothing@@ -157,11 +157,11 @@ } loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound- loop id prevPct = do+ loop token prevPct = do done <- liftIO $ readTVarIO doneVar todo <- liftIO $ readTVarIO todoVar liftIO $ sleep after- if todo == 0 then loop id 0 else do+ if todo == 0 then loop token 0 else do let nextFrac :: Double nextFrac = fromIntegral done / fromIntegral todo@@ -170,7 +170,7 @@ when (nextPct /= prevPct) $ LSP.sendNotification SMethod_Progress $ LSP.ProgressParams- { _token = id+ { _token = token , _value = case optProgressStyle of Explicit -> toJSON $ WorkDoneProgressReport { _kind = AString @"report"@@ -186,7 +186,7 @@ } NoProgress -> error "unreachable" }- loop id nextPct+ loop token nextPct updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks.
src/Development/IDE/Core/RuleTypes.hs view
@@ -475,7 +475,8 @@ instance Hashable GetModSummary instance NFData GetModSummary --- | Get the vscode client settings stored in the ide state+-- See Note [Client configuration in Rules]+-- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings deriving (Eq, Show, Typeable, Generic) instance Hashable GetClientSettings@@ -510,3 +511,33 @@ makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) ''Splices++{- Note [Client configuration in Rules]+The LSP client configuration is stored by `lsp` for us, and is accesible in+handlers through the LspT monad.++This is all well and good, but what if we want to write a Rule that depends+on the configuration? For example, we might have a plugin that provides+diagnostics - if the configuration changes to turn off that plugin, then+we need to invalidate the Rule producing the diagnostics so that they go+away. More broadly, any time we define a Rule that really depends on the+configuration, such that the dependency needs to be tracked and the Rule+invalidated when the configuration changes, we have a problem.++The solution is that we have to mirror the configuration into the state+that our build system knows about. That means that:+- We have a parallel record of the state in 'IdeConfiguration'+- We install a callback so that when the config changes we can update the+'IdeConfiguration' and mark the rule as dirty.++Then we can define a Rule that gets the configuration, and build Actions+on top of that that behave properly. However, these should really only+be used if you need the dependency tracking - for normal usage in handlers+the config can simply be accessed directly from LspT.++TODO(michaelpj): this is me writing down what I think the logic is, but+it doesn't make much sense to me. In particular, we *can* get the LspT+in an Action. So I don't know why we need to store it twice. We would+still need to invalidate the Rule otherwise we won't know it's changed,+though. See https://github.com/haskell/ghcide/pull/731 for some context.+-}
src/Development/IDE/Core/Rules.hs view
@@ -61,26 +61,25 @@ DisplayTHWarning(..), ) where +import Prelude hiding (mod) import Control.Applicative import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Safe import Control.Exception (evaluate)-import Control.Monad.Extra-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.Extra hiding (msum)+import Control.Monad.Reader hiding (msum)+import Control.Monad.State hiding (msum) import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Maybe-import Data.Aeson (Result (Success),- toJSON)-import qualified Data.Aeson.Types as A+import Data.Aeson (toJSON) import qualified Data.Binary as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce-import Data.Foldable+import Data.Foldable hiding (msum) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.Hashable@@ -116,7 +115,7 @@ TargetId(..), loadInterface, Var,- (<+>))+ (<+>), settings) import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error@@ -146,9 +145,8 @@ Properties, ToHsType, useProperty)-import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),- PluginId, PluginDescriptor (pluginId), IdePlugins (IdePlugins))+ PluginId) import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows)@@ -157,20 +155,24 @@ import qualified Development.IDE.Core.Shake as Shake import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake-import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Control.Monad.IO.Unlift-import qualified Data.IntMap as IM-#if MIN_VERSION_ghc(9,3,0)-import GHC.Unit.Module.Graph-import GHC.Unit.Env+++import GHC.Fingerprint++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,3,0)+import GHC (mgModSummaries) #endif-#if MIN_VERSION_ghc(9,5,0)-import GHC.Unit.Home.ModInfo++#if MIN_VERSION_ghc(9,3,0)+import qualified Data.IntMap as IM #endif-import GHC (mgModSummaries)-import GHC.Fingerprint ++ data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath@@ -182,7 +184,7 @@ instance Pretty Log where pretty = \case- LogShake log -> pretty log+ LogShake msg -> pretty msg LogReindexingHieFile path -> "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path ->@@ -334,10 +336,10 @@ let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags dynFlagsModifyParser- let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }+ 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 file ms'' getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do@@ -370,7 +372,7 @@ let import_dirs = deps env_eq let dflags = hsc_dflags env isImplicitCradle = isNothing $ envImportPaths env_eq- dflags <- return $ if isImplicitCradle+ dflags' <- return $ if isImplicitCradle then addRelativeImport file (moduleName $ ms_mod ms) dflags else dflags opt <- getIdeOptions@@ -391,7 +393,7 @@ | otherwise = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do- diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource+ diagOrImp <- locateModule (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path))@@ -405,7 +407,7 @@ bootArtifact <- if boot == Just True then do let modName = ms_mod_name ms- loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath)+ loc <- liftIO $ mkHomeModLocation dflags' modName (fromNormalizedFilePath bootPath) return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True)) else pure Nothing -}@@ -536,9 +538,8 @@ let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) -- Convert cycles of files into cycles of module names forM cycles $ \(imp, files) -> do- modNames <- forM files $ \fileId -> do- let file = idToPath depPathIdMap fileId- getModuleName file+ modNames <- forM files $ + getModuleName . idToPath depPathIdMap pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs)@@ -649,10 +650,9 @@ readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc- let log = (liftIO .) . logWith recorder case res of- Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e- Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc+ Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e+ Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module.@@ -852,7 +852,6 @@ Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f- ShakeExtras{ideNc} <- getShakeExtras 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)@@ -889,12 +888,12 @@ -- 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- hash <- liftIO $ Util.getFileHash hie_loc+ fileHash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow case mrow of Just row- | hash == HieDb.modInfoHash (HieDb.hieModInfo row)+ | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) && Just hie_loc == hie_loc' -> do -- All good, the db has indexed the file@@ -911,7 +910,7 @@ -- can just re-index the file we read from disk Right hf -> liftIO $ do logWith recorder Logger.Debug $ LogReindexingHieFile f- indexHieFile se ms f hash hf+ indexHieFile se ms f fileHash hf return (Just x) @@ -955,8 +954,8 @@ Left diags -> return (Nothing, (diags, Nothing)) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do- ms <- use GetModSummary f- case ms of+ mbMs <- use GetModSummary f+ case mbMs of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { #if !MIN_VERSION_ghc(9,3,0)@@ -982,7 +981,7 @@ getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f- res@(_,(_,mhmi)) <- case fileOfInterest of+ res <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest tmr <- use_ TypeCheck f@@ -990,14 +989,14 @@ hsc <- hscEnv <$> use_ GhcSessionDeps f let compile = fmap ([],) $ use GenerateCore f se <- getShakeExtras- (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr- let fp = hiFileFingerPrint <$> hiFile- hiDiags <- case hiFile of+ (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr+ let fp = hiFileFingerPrint <$> mbHiFile+ hiDiags <- case mbHiFile of Just hiFile | OnDisk <- status , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile _ -> pure []- return (fp, (diags++hiDiags, hiFile))+ return (fp, (diags++hiDiags, mbHiFile)) NotFOI -> do hiFile <- use GetModIfaceFromDiskAndIndex f let fp = hiFileFingerPrint <$> hiFile@@ -1029,22 +1028,22 @@ -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)- (diags, mb_pm) <-+ (diags', mb_pm') <- -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do return (diags, mb_pm) else do -- if parsing fails, try parsing again with Haddock turned off- (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms- return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)- case mb_pm of- Nothing -> return (diags, Nothing)+ (diagsNoHaddock, mb_pm') <- liftIO $ getParsedModuleDefinition hsc opt f ms+ return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm')+ 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+ (diags'', mtmr) <- typeCheckRuleDefinition hsc pm case mtmr of- Nothing -> pure (diags', Nothing)+ Nothing -> pure (diags'', Nothing) Just tmr -> do let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr@@ -1052,7 +1051,7 @@ se <- getShakeExtras -- Bang pattern is important to avoid leaking 'tmr'- (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr+ (diags''', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of@@ -1061,22 +1060,22 @@ -- 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+ se' <- getShakeExtras (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr source <- getSourceFileSource f wDiags <- forM masts $ \asts ->- liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source+ liftIO $ writeAndIndexHieFile hsc se' (tmrModSummary tmr) f (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 hiDiags <- if not $ tmrDeferredError tmr- then liftIO $ writeHiFile se hsc hiFile+ then liftIO $ writeHiFile se' hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) Nothing -> pure [] - return (diags <> diags' <> diags'' <> hiDiags, res)+ return (diags' <> diags'' <> diags''' <> hiDiags, res) -- | HscEnv should have deps included already@@ -1096,6 +1095,7 @@ (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts pure (diags++diags', res) +-- See Note [Client configuration in Rules] getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun@@ -1126,10 +1126,8 @@ core_t <- liftIO $ getModTime core_file case hirCoreFp of Nothing -> error "called GetLinkable for a file without a linkable"- Just (bin_core, hash) -> do+ Just (bin_core, fileHash) -> do session <- use_ GhcSessionDeps f- ShakeExtras{ideNc} <- getShakeExtras- let namecache_updater = mkUpdater ideNc linkableType <- getLinkableType f >>= \case Nothing -> error "called GetLinkable for a file which doesn't need compilation" Just t -> pure t@@ -1165,9 +1163,9 @@ --just before returning it to be loaded. This has a substantial effect on recompile --times as the number of loaded modules and splices increases. --- unload (hscEnv session) (map (\(mod, time) -> LM time mod []) $ moduleEnvToList to_keep)+ unload (hscEnv session) (map (\(mod', time') -> LM time' mod' []) $ moduleEnvToList to_keep) return (to_keep, ())- return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash))+ return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)@@ -1224,11 +1222,11 @@ #if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0) = BCOLinkable #else- | unboxed_tuples_or_sums = ObjectLinkable+ | _unboxed_tuples_or_sums = ObjectLinkable | otherwise = BCOLinkable #endif- where- unboxed_tuples_or_sums =+ where -- unboxed_tuples_or_sums is only used in GHC < 9.2+ _unboxed_tuples_or_sums = xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them
src/Development/IDE/Core/Service.hs view
@@ -52,9 +52,9 @@ instance Pretty Log where pretty = \case- LogShake log -> pretty log- LogOfInterest log -> pretty log- LogFileExists log -> pretty log+ LogShake msg -> pretty msg+ LogOfInterest msg -> pretty msg+ LogFileExists msg -> pretty msg ------------------------------------------------------------ -- Exposed API
src/Development/IDE/Core/Shake.hs view
@@ -86,12 +86,14 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_)+import Control.Lens ((&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Aeson (Result (Success), toJSON)+import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce)@@ -99,14 +101,13 @@ import Data.Dynamic import Data.EnumMap.Strict (EnumMap) import qualified Data.EnumMap.Strict as EM-import Data.Foldable (find, for_, toList)+import Data.Foldable (find, for_) import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet-import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Map.Strict as Map@@ -130,14 +131,10 @@ import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater (..), initNameCache,- knownKeyNames,- mkSplitUniqSupply)-#if !MIN_VERSION_ghc(9,3,0)-import Development.IDE.GHC.Compat (upNameCache)-#endif-import qualified Data.Aeson.Types as A+ knownKeyNames) import Development.IDE.GHC.Orphans ()-import Development.IDE.Graph hiding (ShakeValue)+import Development.IDE.Graph hiding (ShakeValue,+ action) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep,@@ -148,7 +145,7 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics-import Development.IDE.Types.Exports+import Development.IDE.Types.Exports hiding (exportsMapSize) import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location@@ -167,18 +164,27 @@ PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics+import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) import qualified "list-t" ListT-import OpenTelemetry.Eventlog+import OpenTelemetry.Eventlog hiding (addEvent) import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,3,0)+import Data.IORef+import Development.IDE.GHC.Compat (mkSplitUniqSupply,+ upNameCache)+#endif+ data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int@@ -205,10 +211,10 @@ , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)"- LogDelayedAction delayedAction duration ->+ LogDelayedAction delayedAct seconds -> hsep- [ "Finished:" <+> pretty (actionName delayedAction)- , "Took:" <+> pretty (showDuration duration) ]+ [ "Finished:" <+> pretty (actionName delayedAct)+ , "Took:" <+> pretty (showDuration seconds) ] LogBuildSessionFinish e -> vcat [ "Finished build session"@@ -319,6 +325,7 @@ -- This will actually crash HLS Nothing -> liftIO $ fail "missing ShakeExtras" +-- See Note [Client configuration in Rules] -- | Returns the client configuration, creating a build dependency. -- You should always use this function when accessing client configuration -- from build rules.@@ -379,9 +386,9 @@ let typ = typeRep (Proxy :: Proxy a) x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals case x of- Just x- | Just x <- fromDynamic x -> pure x- | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"+ Just y+ | Just z <- fromDynamic y -> pure z+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep y) ++ ")" Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a@@ -396,8 +403,8 @@ getIdeOptions :: Action IdeOptions getIdeOptions = do GlobalIdeOptions x <- getIdeGlobalAction- env <- lspEnv <$> getShakeExtras- case env of+ mbEnv <- lspEnv <$> getShakeExtras+ case mbEnv of Nothing -> return x Just env -> do config <- liftIO $ LSP.runLspT env HLS.getClientConfig@@ -429,8 +436,8 @@ Nothing -> atomicallyNamed "lastValueIO 1" $ do STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing- Just (v,del,ver) -> do- actual_version <- case ver of+ Just (v,del,mbVer) -> do+ actual_version <- case mbVer of Just ver -> pure (Just $ VFSVersion ver) Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) `catch` (\(_ :: IOException) -> pure Nothing)@@ -448,7 +455,7 @@ atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case Nothing -> readPersistent- Just (ValueWithDiagnostics v _) -> case v of+ Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping file ver Stale del ver (fromDynamic -> Just v) ->@@ -599,8 +606,6 @@ shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts monitoring rules = mdo- let log :: Logger.Priority -> Log -> IO ()- log = logWith recorder #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames@@ -626,10 +631,10 @@ -- lazily initialize the exports map with the contents of the hiedb -- TODO: exceptions can be swallowed here? _ <- async $ do- log Debug LogCreateHieDbExportsMapStart+ logWith recorder Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em)- log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)+ logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1)@@ -732,14 +737,13 @@ withMVar' shakeSession (\runner -> do- let log = logWith recorder- (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner+ (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras -- this log is required by tests- log Debug $ LogBuildSessionRestart reason queue backlog stopTime res+ logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession.@@ -747,8 +751,8 @@ (\() -> do (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where- logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO ()- logErrorAfter seconds recorder action = flip withAsync (const action) $ do+ logErrorAfter :: Seconds -> IO () -> IO ()+ logErrorAfter seconds action = flip withAsync (const action) $ do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) @@ -761,8 +765,8 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do (b, dai) <- instantiateDelayedAction act atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue- let wait' b =- waitBarrier b `catches`+ let wait' barrier =+ waitBarrier barrier `catches` [ Handler(\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act)@@ -993,9 +997,6 @@ newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup) --- https://hub.darcs.net/ross/transformers/issue/86-deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)- runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s @@ -1029,7 +1030,7 @@ -- Async trigger the key to be built anyway because we want to -- keep updating the value in the key.- wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file+ waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file@@ -1040,13 +1041,13 @@ res <- lastValueIO s key file case res of Nothing -> do- a <- wait+ a <- waitValue pure $ FastResult ((,zeroMapping) <$> a) (pure a)- Just _ -> pure $ FastResult res wait+ Just _ -> pure $ FastResult res waitValue -- Otherwise, use the computed value even if it's out of date. Just _ -> do res <- lastValueIO s key file- pure $ FastResult res wait+ pure $ FastResult res waitValue useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath@@ -1144,7 +1145,7 @@ 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 (hash, res) <- f k; return (Just hash, Just res) else+ 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" defineEarlyCutoff'@@ -1158,14 +1159,14 @@ -> RunMode -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k)))-defineEarlyCutoff' doDiagnostics cmp key file old mode action = do+defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do- val <- case old of+ val <- case mbOld of Just old | mode == RunDependenciesSame -> do- v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file- case v of+ mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file+ case mbValue of -- No changes in the dependencies and we have -- an existing successful result. Just (v@(Succeeded _ x), diags) -> do@@ -1185,19 +1186,19 @@ Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v Just (Failed b, _) -> Failed b- (bs, (diags, res)) <- actionCatch+ (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - ver <- estimateFileVersionUnsafely key res file- (bs, res) <- case res of+ ver <- estimateFileVersionUnsafely key mbRes file+ (bs, res) <- case mbRes of Nothing -> do- pure (toShakeValue ShakeStale bs, staleV)- Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v)+ pure (toShakeValue ShakeStale mbBs, staleV)+ Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics (vfsVersion =<< ver) diags- let eq = case (bs, fmap decodeShakeValue old) of+ let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result@@ -1214,9 +1215,7 @@ -- without creating a dependency on the GetModificationTime rule -- (and without creating cycles in the build graph). estimateFileVersionUnsafely- :: forall k v- . IdeRule k v- => k+ :: k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion)@@ -1254,7 +1253,7 @@ addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]- update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store+ update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store current = second diagsFromRule <$> current0 addTag "version" (show ver) mask_ $ do@@ -1264,11 +1263,11 @@ -- publishDiagnosticsNotification. newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics- let uri = filePathToUri' fp+ let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0- registerEvent debouncer delay uri $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do+ registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do join $ mask_ $ do- lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics+ lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)@@ -1276,14 +1275,13 @@ liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $- LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) ( newDiags)+ LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) ( newDiags) return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range}- | coerce ideTesting = c- {_relatedInformation =- Just $ [+ | coerce ideTesting = c & L.relatedInformation ?~+ [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp)@@ -1291,7 +1289,6 @@ ) (T.pack $ show k) ]- } | otherwise = c
src/Development/IDE/Core/Tracing.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE PatternSynonyms #-}-{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler
src/Development/IDE/GHC/CPP.hs view
@@ -15,27 +15,33 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import Control.Monad import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Util import GHC -#if MIN_VERSION_ghc(9,0,0)-import qualified GHC.Driver.Pipeline as Pipeline-import GHC.Settings-#elif MIN_VERSION_ghc (8,10,0)+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc (8,10,0) && !MIN_VERSION_ghc(9,0,0) import qualified DriverPipeline as Pipeline import ToolSettings #endif -#if MIN_VERSION_ghc(9,5,0)-import qualified GHC.SysTools.Cpp as Pipeline+#if MIN_VERSION_ghc(9,0,0)+import GHC.Settings #endif -#if MIN_VERSION_ghc(9,3,0)+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Pipeline as Pipeline+#endif++#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,5,0) import qualified GHC.Driver.Pipeline.Execute as Pipeline #endif +#if MIN_VERSION_ghc(9,5,0)+import qualified GHC.SysTools.Cpp as Pipeline+#endif+ addOptP :: String -> DynFlags -> DynFlags addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s@@ -43,7 +49,7 @@ } where fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss- alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }+ alterToolSettings g dynFlags = dynFlags { toolSettings = g (toolSettings dynFlags) } doCpp :: HscEnv -> FilePath -> FilePath -> IO () doCpp env input_fn output_fn =
src/Development/IDE/GHC/Compat.hs view
@@ -142,7 +142,7 @@ #endif ) where -import Data.Bifunctor+import Prelude hiding (mod) import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Iface@@ -156,53 +156,21 @@ ModLocation, RealSrcSpan, exprType, getLoc, lookupName)- import Data.Coerce (coerce) import Data.String (IsString (fromString))+import Compat.HieAst (enrichHie)+import Compat.HieBin+import Compat.HieTypes hiding (nodeAnnotations)+import qualified Compat.HieTypes as GHC (nodeAnnotations)+import Compat.HieUtils+import qualified Data.ByteString as BS+import Data.List (foldl')+import qualified Data.Map as Map+import qualified Data.Set as S +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,5,0)-import GHC.Core.Lint.Interactive (interactiveInScope)-import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr)-import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts)-import GHC.Driver.Config.CoreToStg (initCoreToStgOpts)-import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig)-#else-import GHC.Core.Lint (lintInteractiveExpr)-#endif-import qualified GHC.Core.Opt.Pipeline as GHC-import GHC.Core.Tidy (tidyExpr)-import GHC.CoreToStg.Prep (corePrepPgm)-import qualified GHC.CoreToStg.Prep as GHC-import GHC.Driver.Hooks (hscCompileCoreExprHook)-#if MIN_VERSION_ghc(9,2,0)-import GHC.Linker.Loader (loadExpr)-import GHC.Linker.Types (isObjectLinkable)-import GHC.Runtime.Context (icInteractiveModule)-import GHC.Unit.Home.ModInfo (HomePackageTable,- lookupHpt)-#if MIN_VERSION_ghc(9,3,0)-import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..))-#else-import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..))-#endif-#else-import GHC.CoreToByteCode (coreExprToBCOs)-import GHC.Driver.Types (Dependencies (dep_mods),- HomePackageTable,- icInteractiveModule,- lookupHpt)-import GHC.Runtime.Linker (linkExpr)-#endif-import GHC.ByteCode.Asm (bcoFreeNames)-import GHC.Types.Annotations (AnnTarget (ModuleTarget),- Annotation (..),- extendAnnEnvList)-import GHC.Types.Unique.DFM as UniqDFM-import GHC.Types.Unique.DSet as UniqDSet-import GHC.Types.Unique.Set as UniqSet-#else+#if !MIN_VERSION_ghc(9,0,0) import Annotations (AnnTarget (ModuleTarget), Annotation (..), extendAnnEnvList)@@ -224,70 +192,101 @@ import UniqSet import VarEnv (emptyInScopeSet, emptyTidyEnv, mkRnEnv2)+import FastString+import qualified Avail+import DynFlags hiding (ExposePackage)+import HscTypes+import MkIface hiding (writeIfaceFile)++import StringBuffer (hPutStringBuffer)+import qualified SysTools #endif #if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Core.Opt.Pipeline as GHC+import GHC.Core.Tidy (tidyExpr)+import GHC.CoreToStg.Prep (corePrepPgm)+import qualified GHC.CoreToStg.Prep as GHC+import GHC.Driver.Hooks (hscCompileCoreExprHook)++import GHC.ByteCode.Asm (bcoFreeNames)+import GHC.Types.Annotations (AnnTarget (ModuleTarget),+ Annotation (..),+ extendAnnEnvList)+import GHC.Types.Unique.DFM as UniqDFM+import GHC.Types.Unique.DSet as UniqDSet+import GHC.Types.Unique.Set as UniqSet import GHC.Data.FastString import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage)-import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env-import GHC.Utils.Error-#if MIN_VERSION_ghc(9,2,0)-import GHC.Driver.Env as Env-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary-#else-import GHC.Driver.Types-#endif-import GHC.Iface.Env import GHC.Iface.Make (mkIfaceExports) import qualified GHC.SysTools.Tasks as SysTools import qualified GHC.Types.Avail as Avail-#else-import FastString-import qualified Avail-import DynFlags hiding (ExposePackage)-import HscTypes-import MkIface hiding (writeIfaceFile)+#endif -import StringBuffer (hPutStringBuffer)-import qualified SysTools+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import GHC.Utils.Error+import GHC.CoreToByteCode (coreExprToBCOs)+import GHC.Runtime.Linker (linkExpr)+import GHC.Driver.Types #endif -import Compat.HieAst (enrichHie)-import Compat.HieBin-import Compat.HieTypes hiding (nodeAnnotations)-import qualified Compat.HieTypes as GHC (nodeAnnotations)-import Compat.HieUtils-import qualified Data.ByteString as BS-import Data.IORef+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0)+import GHC.Core.Lint (lintInteractiveExpr)+#endif -import Data.List (foldl')-import qualified Data.Map as Map-import qualified Data.Set as S+#if !MIN_VERSION_ghc(9,2,0)+import Data.Bifunctor+#endif #if MIN_VERSION_ghc(9,2,0)+import GHC.Iface.Env+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Linker.Loader (loadExpr)+import GHC.Runtime.Context (icInteractiveModule)+import GHC.Unit.Home.ModInfo (HomePackageTable,+ lookupHpt)+import GHC.Driver.Env as Env+import GHC.Unit.Module.ModIface import GHC.Builtin.Uniques import GHC.ByteCode.Types import GHC.CoreToStg import GHC.Data.Maybe import GHC.Linker.Loader (loadDecls)-import GHC.Runtime.Interpreter import GHC.Stg.Pipeline import GHC.Stg.Syntax import GHC.StgToByteCode import GHC.Types.CostCentre import GHC.Types.IPE+#endif ++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..))+import GHC.Linker.Types (isObjectLinkable)+import GHC.Unit.Module.ModSummary+import GHC.Runtime.Interpreter #endif +#if !MIN_VERSION_ghc(9,3,0)+import Data.IORef+#endif+ #if MIN_VERSION_ghc(9,3,0)-import GHC.Types.Error+import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) import GHC.Driver.Config.Stg.Pipeline-import GHC.Driver.Plugins (PsMessages (..)) #endif +#if MIN_VERSION_ghc(9,5,0)+import GHC.Core.Lint.Interactive (interactiveInScope)+import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr)+import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts)+import GHC.Driver.Config.CoreToStg (initCoreToStgOpts)+import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig)+#endif++ #if !MIN_VERSION_ghc(9,3,0) nonDetOccEnvElts :: OccEnv a -> [a] nonDetOccEnvElts = occEnvElts@@ -417,9 +416,9 @@ corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr #if MIN_VERSION_ghc(9,5,0)-corePrepExpr _ env exp = do+corePrepExpr _ env expr = do cfg <- initCorePrepConfig env- GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg exp+ GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr #else corePrepExpr _ = GHC.corePrepExpr #endif@@ -573,12 +572,12 @@ NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a]- mergeSorted la@(a:as) lb@(b:bs) = case compare a b of- LT -> a : mergeSorted as lb- EQ -> a : mergeSorted as bs- GT -> b : mergeSorted la bs- mergeSorted as [] = as- mergeSorted [] bs = bs+ mergeSorted la@(a:axs) lb@(b:bxs) = case compare a b of+ LT -> a : mergeSorted axs lb+ EQ -> a : mergeSorted axs bxs+ GT -> b : mergeSorted la bxs+ mergeSorted axs [] = axs+ mergeSorted [] bxs = bxs #else
src/Development/IDE/GHC/Compat/Core.hs view
@@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-}--- TODO: remove-{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} --- | Compat Core module that handles the GHC module hierarchy re-organisation+-- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about. -- -- This module provides no other compat mechanisms, except for simple@@ -502,186 +500,16 @@ import qualified GHC -#if MIN_VERSION_ghc(9,3,0)-import GHC.Iface.Recomp (CompileReason(..))-import GHC.Driver.Env.Types (hsc_type_env_vars)-import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG)-import GHC.Driver.Env.KnotVars-import GHC.Iface.Recomp-import GHC.Linker.Types-import GHC.Unit.Module.Graph-import GHC.Driver.Errors.Types-import GHC.Types.Unique.Map-import GHC.Types.Unique-import GHC.Utils.TmpFs-import GHC.Utils.Panic-import GHC.Unit.Finder.Types-import GHC.Unit.Env-import GHC.Driver.Phases-#endif+-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it.+-- Not the greatest solution, but gets the job done+-- (until the CPP extension is actually needed).+import GHC.LanguageExtensions.Type hiding (Cpp) -#if MIN_VERSION_ghc(9,0,0)-import GHC.Builtin.Names hiding (Unique, printName)-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim-import GHC.Builtin.Utils-import GHC.Core.Class-import GHC.Core.Coercion-import GHC.Core.ConLike-import GHC.Core.DataCon hiding (dataConExTyCoVars)-import qualified GHC.Core.DataCon as DataCon-import GHC.Core.FamInstEnv hiding (pprFamInst)-import GHC.Core.InstEnv-import GHC.Types.Unique.FM hiding (UniqFM)-import qualified GHC.Types.Unique.FM as UniqFM-#if MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Config.Tidy as GHC-import qualified GHC.Data.Strict as Strict-#endif-#if MIN_VERSION_ghc(9,2,0)-import GHC.Data.Bag-import GHC.Core.Multiplicity (scaledThing)-#else-import GHC.Core.Ppr.TyThing hiding (pprFamInst)-import GHC.Core.TyCo.Rep (scaledThing)-#endif-import GHC.Core.PatSyn-import GHC.Core.Predicate-import GHC.Core.TyCo.Ppr-import qualified GHC.Core.TyCo.Rep as TyCoRep-import GHC.Core.TyCon-import GHC.Core.Type hiding (mkInfForAllTys)-import GHC.Core.Unify-import GHC.Core.Utils+import GHC.Hs.Binds +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,2,0)-import GHC.Driver.Env-#else-import GHC.Driver.Finder hiding (mkHomeModLocation)-import GHC.Driver.Types-import GHC.Driver.Ways-#endif-import GHC.Driver.CmdLine (Warn (..))-import GHC.Driver.Hooks-import GHC.Driver.Main as GHC-import GHC.Driver.Monad-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Plugins-import GHC.Driver.Session hiding (ExposePackage)-import qualified GHC.Driver.Session as DynFlags-#if MIN_VERSION_ghc(9,2,0)-import GHC.Hs (HsModule (..), SrcSpanAnn')-import GHC.Hs.Decls hiding (FunDep)-import GHC.Hs.Doc-import GHC.Hs.Expr-import GHC.Hs.Extension-import GHC.Hs.ImpExp-import GHC.Hs.Pat-import GHC.Hs.Type-import GHC.Hs.Utils hiding (collectHsBindsBinders)-import qualified GHC.Hs.Utils as GHC-#endif-#if !MIN_VERSION_ghc(9,2,0)-import GHC.Hs hiding (HsLet, LetStmt)-#endif-import GHC.HsToCore.Docs-import GHC.HsToCore.Expr-import GHC.HsToCore.Monad-import GHC.Iface.Load-import GHC.Iface.Make (mkFullIface, mkPartialIface)-import GHC.Iface.Make as GHC-import GHC.Iface.Recomp-import GHC.Iface.Syntax-import GHC.Iface.Tidy as GHC-import GHC.IfaceToCore-import GHC.Parser-import GHC.Parser.Header hiding (getImports)-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types-import GHC.Parser.Lexer hiding (initParserState, getPsMessages)-import GHC.Parser.Annotation (EpAnn (..))-import GHC.Platform.Ways-import GHC.Runtime.Context (InteractiveImport (..))-#else-import GHC.Parser.Lexer-import qualified GHC.Runtime.Linker as Linker-#endif-import GHC.Rename.Fixity (lookupFixityRn)-import GHC.Rename.Names-import GHC.Rename.Splice-import qualified GHC.Runtime.Interpreter as GHCi-import GHC.Tc.Instance.Family-import GHC.Tc.Module-import GHC.Tc.Types-import GHC.Tc.Types.Evidence hiding ((<.>))-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef,- MonadFix (..), MonadIO (..),- allM, anyM, concatMapM,- mapMaybeM, (<$>))-import GHC.Tc.Utils.TcType as TcType-import qualified GHC.Types.Avail as Avail-#if MIN_VERSION_ghc(9,2,0)-import GHC.Types.Avail (greNamePrintableName)-import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity)-#endif-#if MIN_VERSION_ghc(9,2,0)-import GHC.Types.Meta-#endif-import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Name hiding (varName)-import GHC.Types.Name.Cache-import GHC.Types.Name.Env-import GHC.Types.Name.Reader hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par)-import qualified GHC.Types.Name.Reader as RdrName-#if MIN_VERSION_ghc(9,2,0)-import GHC.Types.Name.Set-import GHC.Types.SourceFile (HscSource (..),-#if !MIN_VERSION_ghc(9,3,0)- SourceModified(..)-#endif- )-import GHC.Types.SourceText-import GHC.Types.Target (Target (..), TargetId (..))-import GHC.Types.TyThing-import GHC.Types.TyThing.Ppr-#else-import GHC.Types.Name.Set-#endif-import GHC.Types.SrcLoc (BufPos, BufSpan,- SrcLoc (UnhelpfulLoc),- SrcSpan (UnhelpfulSpan))-import qualified GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Unique.Supply-import GHC.Types.Var (Var (varName), setTyVarUnique,- setVarUnique)-#if MIN_VERSION_ghc(9,2,0)-import GHC.Unit.Finder hiding (mkHomeModLocation)-import GHC.Unit.Home.ModInfo-#endif-import GHC.Unit.Info (PackageName (..))-import GHC.Unit.Module hiding (ModLocation (..), UnitId,- addBootSuffixLocnOut, moduleUnit,- toUnitId)-import qualified GHC.Unit.Module as Module-#if MIN_VERSION_ghc(9,2,0)-import GHC.Unit.Module.Graph (mkModuleGraph)-import GHC.Unit.Module.Imported-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..),- ModIface_ (..), mi_fix)-import GHC.Unit.Module.ModSummary (ModSummary (..))-#endif-import GHC.Unit.State (ModuleOrigin (..))-import GHC.Utils.Error (Severity (..), emptyMessages)-import GHC.Utils.Panic hiding (try)-import qualified GHC.Utils.Panic.Plain as Plain-#else+#if !MIN_VERSION_ghc(9,0,0) import qualified Avail import BasicTypes hiding (Version) import Class@@ -711,7 +539,7 @@ import Id import IfaceSyn import InstEnv-import Lexer hiding (getSrcLoc)+import Lexer import qualified Linker import LoadIface import MkIface as GHC@@ -748,7 +576,6 @@ mapMaybeM, (<$>)) import TcRnTypes import TcType-import qualified TcType import TidyPgm as GHC import qualified TyCoRep import TyCon@@ -766,40 +593,167 @@ import Predicate import SrcLoc (Located, SrcLoc (UnhelpfulLoc), SrcSpan (UnhelpfulSpan))+import qualified Finder as GHC #endif --import Data.List (isSuffixOf)-import System.FilePath+#if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Names hiding (Unique, printName)+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Utils+import GHC.Core.Class+import GHC.Core.Coercion+import GHC.Core.ConLike+import GHC.Core.DataCon hiding (dataConExTyCoVars)+import qualified GHC.Core.DataCon as DataCon+import GHC.Core.FamInstEnv hiding (pprFamInst)+import GHC.Core.InstEnv+import GHC.Types.Unique.FM hiding (UniqFM)+import qualified GHC.Types.Unique.FM as UniqFM+import GHC.Core.PatSyn+import GHC.Core.Predicate+import GHC.Core.TyCo.Ppr+import qualified GHC.Core.TyCo.Rep as TyCoRep+import GHC.Core.TyCon+import GHC.Core.Type hiding (mkInfForAllTys)+import GHC.Core.Unify+import GHC.Core.Utils+import GHC.Driver.CmdLine (Warn (..))+import GHC.Driver.Hooks+import GHC.Driver.Main as GHC+import GHC.Driver.Monad+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Plugins+import GHC.Driver.Session hiding (ExposePackage)+import qualified GHC.Driver.Session as DynFlags+import GHC.HsToCore.Docs+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.Iface.Load+import GHC.Iface.Make as GHC+import GHC.Iface.Recomp+import GHC.Iface.Syntax+import GHC.Iface.Tidy as GHC+import GHC.IfaceToCore+import GHC.Parser+import GHC.Parser.Header hiding (getImports)+import GHC.Rename.Fixity (lookupFixityRn)+import GHC.Rename.Names+import GHC.Rename.Splice+import qualified GHC.Runtime.Interpreter as GHCi+import GHC.Tc.Instance.Family+import GHC.Tc.Module+import GHC.Tc.Types+import GHC.Tc.Types.Evidence hiding ((<.>))+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef,+ MonadFix (..), MonadIO (..),+ allM, anyM, concatMapM,+ mapMaybeM, (<$>))+import GHC.Tc.Utils.TcType as TcType+import qualified GHC.Types.Avail as Avail+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Name hiding (varName)+import GHC.Types.Name.Cache+import GHC.Types.Name.Env+import GHC.Types.Name.Reader hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par)+import qualified GHC.Types.Name.Reader as RdrName+import GHC.Types.SrcLoc (BufPos, BufSpan,+ SrcLoc (UnhelpfulLoc),+ SrcSpan (UnhelpfulSpan))+import qualified GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique.Supply+import GHC.Types.Var (Var (varName), setTyVarUnique,+ setVarUnique)+import GHC.Unit.Info (PackageName (..))+import GHC.Unit.Module hiding (ModLocation (..), UnitId,+ addBootSuffixLocnOut, moduleUnit,+ toUnitId)+import qualified GHC.Unit.Module as Module+import GHC.Unit.State (ModuleOrigin (..))+import GHC.Utils.Error (Severity (..), emptyMessages)+import GHC.Utils.Panic hiding (try)+import qualified GHC.Utils.Panic.Plain as Plain+#endif +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import GHC.Core.Ppr.TyThing hiding (pprFamInst)+import GHC.Core.TyCo.Rep (scaledThing)+import GHC.Driver.Finder hiding (mkHomeModLocation)+import GHC.Driver.Types+import GHC.Driver.Ways+import GHC.Hs hiding (HsLet, LetStmt)+import GHC.Parser.Lexer+import qualified GHC.Runtime.Linker as Linker+import GHC.Types.Name.Set+import qualified GHC.Driver.Finder as GHC+#endif #if MIN_VERSION_ghc(9,2,0)+import Data.Foldable (toList)+import GHC.Data.Bag+import GHC.Core.Multiplicity (scaledThing)+import GHC.Driver.Env+import GHC.Hs (HsModule (..), SrcSpanAnn')+import GHC.Hs.Decls hiding (FunDep)+import GHC.Hs.Doc+import GHC.Hs.Expr+import GHC.Hs.Extension+import GHC.Hs.ImpExp+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Hs.Utils hiding (collectHsBindsBinders)+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types+import GHC.Parser.Lexer hiding (initParserState, getPsMessages)+import GHC.Parser.Annotation (EpAnn (..))+import GHC.Platform.Ways+import GHC.Runtime.Context (InteractiveImport (..))+import GHC.Types.Avail (greNamePrintableName)+import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity)+import GHC.Types.Meta+import GHC.Types.Name.Set+import GHC.Types.SourceFile (HscSource (..))+import GHC.Types.SourceText+import GHC.Types.Target (Target (..), TargetId (..))+import GHC.Types.TyThing+import GHC.Types.TyThing.Ppr+import GHC.Unit.Finder hiding (mkHomeModLocation)+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..),+ ModIface_ (..), mi_fix)+import GHC.Unit.Module.ModSummary (ModSummary (..)) import Language.Haskell.Syntax hiding (FunDep) #endif-#if MIN_VERSION_ghc(9,3,0)-import GHC.Driver.Env as GHCi-#endif -import Data.Foldable (toList)+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Types.SourceFile (SourceModified(..))+import GHC.Unit.Module.Graph (mkModuleGraph)+import qualified GHC.Unit.Finder as GHC+#endif #if MIN_VERSION_ghc(9,3,0)+import GHC.Driver.Env.KnotVars+import GHC.Unit.Module.Graph+import GHC.Driver.Errors.Types+import GHC.Types.Unique.Map+import GHC.Types.Unique+import GHC.Utils.TmpFs+import GHC.Utils.Panic+import GHC.Unit.Finder.Types+import GHC.Unit.Env+import qualified GHC.Driver.Config.Tidy as GHC+import qualified GHC.Data.Strict as Strict+import GHC.Driver.Env as GHCi import qualified GHC.Unit.Finder as GHC import qualified GHC.Driver.Config.Finder as GHC-#elif MIN_VERSION_ghc(9,2,0)-import qualified GHC.Unit.Finder as GHC-#elif MIN_VERSION_ghc(9,0,0)-import qualified GHC.Driver.Finder as GHC-#else-import qualified Finder as GHC #endif --- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it.--- Not the greatest solution, but gets the job done--- (until the CPP extension is actually needed).-import GHC.LanguageExtensions.Type hiding (Cpp)--import GHC.Hs.Binds- mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f@@ -1132,10 +1086,10 @@ hsc_env #endif -mkIfaceTc hsc_env sf details ms tcGblEnv =+mkIfaceTc hsc_env sf details _ms tcGblEnv = -- ms is only used in GHC >= 9.4 GHC.mkIfaceTc hsc_env sf details #if MIN_VERSION_ghc(9,3,0)- ms+ _ms #endif tcGblEnv @@ -1203,6 +1157,7 @@ #else mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = SrcLoc.mapLoc+groupOrigin :: MatchGroup p body -> Origin groupOrigin = mg_origin #endif
src/Development/IDE/GHC/Compat/Env.hs view
@@ -53,58 +53,70 @@ Development.IDE.GHC.Compat.Env.platformDefaultBackend, ) where -import GHC (setInteractiveDynFlags)+import GHC (setInteractiveDynFlags) -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)-import GHC.Driver.Backend as Backend-#if MIN_VERSION_ghc(9,3,0)-import GHC.Driver.Env (HscEnv)-#else-import GHC.Driver.Env (HscEnv, hsc_EPS)-#endif-import qualified GHC.Driver.Env as Env-import qualified GHC.Driver.Session as Session-import GHC.Platform.Ways hiding (hostFullWays)-import qualified GHC.Platform.Ways as Ways-import GHC.Runtime.Context-import GHC.Unit.Env (UnitEnv)-import GHC.Unit.Home as Home-import GHC.Utils.Logger-import GHC.Utils.TmpFs-#else-import qualified GHC.Driver.Session as DynFlags-import GHC.Driver.Types (HscEnv, InteractiveContext (..), hsc_EPS,- setInteractivePrintName)-import qualified GHC.Driver.Types as Env-import GHC.Driver.Ways hiding (hostFullWays)-import qualified GHC.Driver.Ways as Ways-#endif-import GHC.Driver.Hooks (Hooks)-import GHC.Driver.Session hiding (mkHomeModule)-#if __GLASGOW_HASKELL__ >= 905-import Language.Haskell.Syntax.Module.Name-#else-import GHC.Unit.Module.Name-#endif-import GHC.Unit.Types (Module, Unit, UnitId, mkModule)-#else+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0) import DynFlags import Hooks-import HscTypes as Env+import HscTypes as Env import Module #endif #if MIN_VERSION_ghc(9,0,0)-#if !MIN_VERSION_ghc(9,2,0)-import qualified Data.Set as Set+import GHC.Driver.Hooks (Hooks)+import GHC.Driver.Session hiding (mkHomeModule)+import GHC.Unit.Types (Module, UnitId) #endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import qualified Data.Set as Set+import qualified GHC.Driver.Session as DynFlags+import GHC.Driver.Types (HscEnv,+ InteractiveContext (..),+ hsc_EPS,+ setInteractivePrintName)+import qualified GHC.Driver.Types as Env+import GHC.Driver.Ways hiding (hostFullWays)+import qualified GHC.Driver.Ways as Ways+import GHC.Unit.Types (Unit, mkModule) #endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0)+import GHC.Unit.Module.Name+#endif+ #if !MIN_VERSION_ghc(9,2,0) import Data.IORef #endif +#if MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Backend as Backend+import qualified GHC.Driver.Env as Env+import qualified GHC.Driver.Session as Session+import GHC.Platform.Ways hiding (hostFullWays)+import qualified GHC.Platform.Ways as Ways+import GHC.Runtime.Context+import GHC.Unit.Env (UnitEnv)+import GHC.Unit.Home as Home+import GHC.Utils.Logger+import GHC.Utils.TmpFs+#endif++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Driver.Env (HscEnv, hsc_EPS)+#endif+ #if MIN_VERSION_ghc(9,3,0)+import GHC.Driver.Env (HscEnv)+#endif++#if MIN_VERSION_ghc(9,5,0)+import Language.Haskell.Syntax.Module.Name+#endif++#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = hsc_unit_env #endif@@ -276,13 +288,13 @@ #endif setWays :: Ways -> DynFlags -> DynFlags-setWays ways flags =+setWays newWays flags = #if MIN_VERSION_ghc(9,2,0)- flags { Session.targetWays_ = ways}+ flags { Session.targetWays_ = newWays} #elif MIN_VERSION_ghc(9,0,0)- flags {ways = ways}+ flags {ways = newWays} #else- updateWays $ flags {ways = ways}+ updateWays $ flags {ways = newWays} #endif -- -------------------------------------------------------
src/Development/IDE/GHC/Compat/Iface.hs view
@@ -6,25 +6,32 @@ cannotFindModule, ) where +import Development.IDE.GHC.Compat.Env+import Development.IDE.GHC.Compat.Outputable import GHC-#if MIN_VERSION_ghc(9,3,0)-import GHC.Driver.Session (targetProfile)++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import Finder (FindResult)+import qualified Finder+import qualified MkIface #endif-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Iface.Load as Iface-import GHC.Unit.Finder.Types (FindResult)-#elif MIN_VERSION_ghc(9,0,0)++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import qualified GHC.Driver.Finder as Finder import GHC.Driver.Types (FindResult) import qualified GHC.Iface.Load as Iface-#else-import Finder (FindResult)-import qualified Finder-import qualified MkIface #endif -import Development.IDE.GHC.Compat.Env-import Development.IDE.GHC.Compat.Outputable+#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Iface.Load as Iface+import GHC.Unit.Finder.Types (FindResult)+#endif++#if MIN_VERSION_ghc(9,3,0)+import GHC.Driver.Session (targetProfile)+#endif writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () #if MIN_VERSION_ghc(9,3,0)
src/Development/IDE/GHC/Compat/Logger.hs view
@@ -13,17 +13,26 @@ import Development.IDE.GHC.Compat.Env as Env import Development.IDE.GHC.Compat.Outputable +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import DynFlags+import Outputable (queryQual)+#endif+ #if MIN_VERSION_ghc(9,0,0)-import GHC.Driver.Session as DynFlags import GHC.Utils.Outputable+#endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Session as DynFlags+#endif+ #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env (hsc_logger) import GHC.Utils.Logger as Logger #endif-#else-import DynFlags-import Outputable (queryQual)-#endif+ #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Error #endif
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -49,17 +49,36 @@ textDoc, ) where +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,0,0)+import Development.IDE.GHC.Compat.Core (GlobalRdrEnv)+import DynFlags+import ErrUtils hiding (mkWarnMsg)+import qualified ErrUtils as Err+import HscTypes+import Outputable as Out hiding+ (defaultUserStyle)+import qualified Outputable as Out+import SrcLoc+#endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import GHC.Driver.Session+import GHC.Driver.Types as HscTypes+import GHC.Types.Name.Reader (GlobalRdrEnv)+import GHC.Types.SrcLoc+import GHC.Utils.Error as Err hiding (mkWarnMsg)+import qualified GHC.Utils.Error as Err+import GHC.Utils.Outputable as Out hiding+ (defaultUserStyle)+import qualified GHC.Utils.Outputable as Out+#endif+ #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session-#if !MIN_VERSION_ghc(9,3,0)-import GHC.Parser.Errors-#else-import GHC.Parser.Errors.Types-#endif-import qualified GHC.Parser.Errors.Ppr as Ppr import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr import GHC.Types.Name.Reader@@ -71,37 +90,24 @@ (defaultUserStyle) import qualified GHC.Utils.Outputable as Out import GHC.Utils.Panic-#elif MIN_VERSION_ghc(9,0,0)-import GHC.Driver.Session-import GHC.Driver.Types as HscTypes-import GHC.Types.Name.Reader (GlobalRdrEnv)-import GHC.Types.SrcLoc-import GHC.Utils.Error as Err hiding (mkWarnMsg)-import qualified GHC.Utils.Error as Err-import GHC.Utils.Outputable as Out hiding- (defaultUserStyle)-import qualified GHC.Utils.Outputable as Out-#else-import Development.IDE.GHC.Compat.Core (GlobalRdrEnv)-import DynFlags-import ErrUtils hiding (mkWarnMsg)-import qualified ErrUtils as Err-import HscTypes-import Outputable as Out hiding- (defaultUserStyle)-import qualified Outputable as Out-import SrcLoc #endif-#if MIN_VERSION_ghc(9,5,0)-import GHC.Driver.Errors.Types (GhcMessage)++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Parser.Errors+import qualified GHC.Parser.Errors.Ppr as Ppr #endif+ #if MIN_VERSION_ghc(9,3,0) import Data.Maybe import GHC.Driver.Config.Diagnostic-import GHC.Utils.Logger+import GHC.Parser.Errors.Types #endif #if MIN_VERSION_ghc(9,5,0)+import GHC.Driver.Errors.Types (GhcMessage)+#endif++#if MIN_VERSION_ghc(9,5,0) type PrintUnqualified = NamePprCtx #endif @@ -221,16 +227,18 @@ #endif mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified-mkPrintUnqualifiedDefault env = #if MIN_VERSION_ghc(9,5,0)+mkPrintUnqualifiedDefault env = mkNamePprCtx ptc (hsc_unit_env env) where ptc = initPromotionTickContext (hsc_dflags env) #elif MIN_VERSION_ghc(9,2,0)+mkPrintUnqualifiedDefault env = -- GHC 9.2 version -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified (hsc_unit_env env) #else+mkPrintUnqualifiedDefault env = HscTypes.mkPrintUnqualified (hsc_dflags env) #endif
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -45,46 +45,51 @@ pattern EpaBlockComment ) where -#if MIN_VERSION_ghc(9,0,0)-#if !MIN_VERSION_ghc(9,2,0)-import qualified GHC.Driver.Types as GHC+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Util++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import qualified ApiAnnotation as Anno+import qualified HscTypes as GHC+import Lexer+import qualified SrcLoc #endif++#if MIN_VERSION_ghc(9,0,0) import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..))+#endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)+import qualified GHC.Driver.Types as GHC+#endif++#if !MIN_VERSION_ghc(9,2,0)+import qualified Data.Map as Map+import qualified GHC+#endif+ #if MIN_VERSION_ghc(9,2,0)-import GHC (Anchor (anchor),- EpAnnComments (priorComments),- EpaComment (EpaComment),- EpaCommentTok (..),- epAnnComments,+import GHC (EpaCommentTok (..), pm_extra_src_files, pm_mod_summary, pm_parsed_source) import qualified GHC-#if MIN_VERSION_ghc(9,3,0)-import qualified GHC.Driver.Config.Parser as Config-#else-import qualified GHC.Driver.Config as Config-#endif-import GHC.Hs (LEpaComment, hpm_module,- hpm_src_files)-import GHC.Parser.Lexer hiding (initParserState)+import GHC.Hs (hpm_module, hpm_src_files) #endif-#else-import qualified ApiAnnotation as Anno-import qualified HscTypes as GHC-import Lexer-import qualified SrcLoc++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Config as Config #endif-import Development.IDE.GHC.Compat.Core-import Development.IDE.GHC.Compat.Util -#if !MIN_VERSION_ghc(9,2,0)-import qualified Data.Map as Map-import qualified GHC+#if MIN_VERSION_ghc(9,3,0)+import qualified GHC.Driver.Config.Parser as Config #endif + #if !MIN_VERSION_ghc(9,0,0) type ParserOpts = DynFlags #elif !MIN_VERSION_ghc(9,2,0)@@ -131,7 +136,7 @@ , hpm_annotations } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations)) where- HsParsedModule hpm_module hpm_src_files hpm_annotations =+ HsParsedModule hpm_module hpm_src_files _hpm_annotations = GHC.HsParsedModule hpm_module hpm_src_files #endif
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -19,33 +19,48 @@ getPsMessages ) where -#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Driver.Env as Env+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags)+import Development.IDE.GHC.Compat.Parser as Parser++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import qualified DynamicLoading as Loader+import Plugins #endif++#if MIN_VERSION_ghc(9,0,0) import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, withPlugins)+import qualified GHC.Runtime.Loader as Loader+#endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0)+import Development.IDE.GHC.Compat.Outputable as Out+#endif++#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Driver.Env as Env+#endif++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import Data.Bifunctor (bimap)+#endif++#if !MIN_VERSION_ghc(9,3,0)+import Development.IDE.GHC.Compat.Util (Bag)+#endif+ #if MIN_VERSION_ghc(9,3,0) import GHC.Driver.Plugins (ParsedResult (..), PsMessages (..), staticPlugins) import qualified GHC.Parser.Lexer as Lexer-#else-import Data.Bifunctor (bimap) #endif-import qualified GHC.Runtime.Loader as Loader-#else-import qualified DynamicLoading as Loader-import Plugins-#endif-import Development.IDE.GHC.Compat.Core-import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags)-import Development.IDE.GHC.Compat.Outputable as Out-import Development.IDE.GHC.Compat.Parser as Parser-import Development.IDE.GHC.Compat.Util (Bag) #if !MIN_VERSION_ghc(9,3,0)@@ -53,7 +68,7 @@ #endif getPsMessages :: PState -> DynFlags -> PsMessages-getPsMessages pst dflags =+getPsMessages pst _dflags = --dfags is only used if GHC < 9.2 #if MIN_VERSION_ghc(9,3,0) uncurry PsMessages $ Lexer.getPsMessages pst #else@@ -62,12 +77,13 @@ #endif getMessages pst #if !MIN_VERSION_ghc(9,2,0)- dflags+ _dflags #endif #endif applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)-applyPluginsParsedResultAction env dflags ms hpm_annotations parsed msgs = do+applyPluginsParsedResultAction env _dflags ms hpm_annotations parsed msgs = do+ -- dflags is only used in GHC < 9.2 -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms #if MIN_VERSION_ghc(9,3,0)@@ -80,7 +96,7 @@ #elif MIN_VERSION_ghc(9,2,0) env #else- dflags+ _dflags #endif applyPluginAction #if MIN_VERSION_ghc(9,3,0)
src/Development/IDE/GHC/Compat/Units.hs view
@@ -53,41 +53,19 @@ findImportedModule, ) where -import Control.Monad-import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Strict as Map-#if MIN_VERSION_ghc(9,3,0)-import GHC.Unit.Home.ModInfo-#endif-#if MIN_VERSION_ghc(9,0,0)-#if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Data.ShortText as ST-#if !MIN_VERSION_ghc(9,3,0)-import GHC.Driver.Env (hsc_unit_dbs)-#endif-import GHC.Driver.Ppr-import GHC.Unit.Env-import GHC.Unit.External-import GHC.Unit.Finder hiding- (findImportedModule)-#else-import GHC.Driver.Types-#endif-import GHC.Data.FastString-import qualified GHC.Driver.Session as DynFlags-import GHC.Types.Unique.Set-import qualified GHC.Unit.Info as UnitInfo-import GHC.Unit.State (LookupResult, UnitInfo,- UnitState (unitInfoMap))-import qualified GHC.Unit.State as State-import GHC.Unit.Types hiding (moduleUnit,- toUnitId)-import qualified GHC.Unit.Types as Unit-import GHC.Utils.Outputable-#else+import Data.Either+import Data.Version+import Development.IDE.GHC.Compat.Core+import Development.IDE.GHC.Compat.Env+import Development.IDE.GHC.Compat.Outputable+import Prelude hiding (mod)++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0) import qualified DynFlags import FastString-import GhcPlugins (SDoc, showSDocForUser)+import qualified Finder as GHC import HscTypes import Module hiding (moduleUnitId) import qualified Module@@ -101,26 +79,51 @@ import qualified Packages #endif -import Development.IDE.GHC.Compat.Core-import Development.IDE.GHC.Compat.Env-import Development.IDE.GHC.Compat.Outputable+#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Unique.Set+import qualified GHC.Unit.Info as UnitInfo+import GHC.Unit.State (LookupResult, UnitInfo,+ UnitState (unitInfoMap))+import qualified GHC.Unit.State as State+import GHC.Unit.Types hiding (moduleUnit,+ toUnitId)+import qualified GHC.Unit.Types as Unit+#endif+ #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import Data.Map (Map)+import qualified GHC.Driver.Finder as GHC+import qualified GHC.Driver.Session as DynFlags+import GHC.Driver.Types #endif-import Data.Either-import Data.Version-import qualified GHC -#if MIN_VERSION_ghc(9,3,0)-import GHC.Types.PkgQual (PkgQual (NoPkgQual))+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Data.FastString+ #endif-#if MIN_VERSION_ghc(9,1,0)++#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.Data.ShortText as ST+import GHC.Unit.External import qualified GHC.Unit.Finder as GHC-#elif MIN_VERSION_ghc(9,0,0)-import qualified GHC.Driver.Finder as GHC-#else-import qualified Finder as GHC #endif++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Unit.Env+import GHC.Unit.Finder hiding+ (findImportedModule)+#endif++#if MIN_VERSION_ghc(9,3,0)+import Control.Monad+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified GHC+import qualified GHC.Driver.Session as DynFlags+import GHC.Types.PkgQual (PkgQual (NoPkgQual))+import GHC.Unit.Home.ModInfo+#endif+ #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId
src/Development/IDE/GHC/Compat/Util.hs view
@@ -69,23 +69,9 @@ atEnd, ) where -#if MIN_VERSION_ghc(9,0,0)-import Control.Exception.Safe (MonadCatch, catch, try)-import GHC.Data.Bag-import GHC.Data.BooleanFormula-import GHC.Data.EnumSet+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Data.Pair-import GHC.Data.StringBuffer-import GHC.Types.Unique-import GHC.Types.Unique.DFM-import GHC.Utils.Fingerprint-import GHC.Utils.Misc-import GHC.Utils.Outputable (pprHsString)-import GHC.Utils.Panic hiding (try)-#else+#if !MIN_VERSION_ghc(9,0,0) import Bag import BooleanFormula import EnumSet@@ -100,6 +86,27 @@ import UniqDFM import Unique import Util+#endif++#if MIN_VERSION_ghc(9,0,0)+import Control.Exception.Safe (MonadCatch, catch, try)+import GHC.Data.Bag+import GHC.Data.BooleanFormula+import GHC.Data.EnumSet++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.Pair+import GHC.Data.StringBuffer+import GHC.Types.Unique+import GHC.Types.Unique.DFM+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable (pprHsString)+import GHC.Utils.Panic hiding (try)+#endif++#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Utils.Misc #endif #if MIN_VERSION_ghc(9,3,0)
src/Development/IDE/GHC/CoreFile.hs view
@@ -19,11 +19,26 @@ import Data.IORef import Data.List (isPrefixOf) import Data.Maybe-import qualified Data.Text as T+import qualified Data.Text as T+import Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat.Util as Util import GHC.Fingerprint+import Prelude hiding (mod) -import Development.IDE.GHC.Compat+-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,0,0)+import Binary+import BinFingerprint (fingerprintBinMem)+import BinIface+import CoreSyn+import HscTypes+import IfaceEnv+import MkId+import TcIface+import ToIface+#endif+ #if MIN_VERSION_ghc(9,0,0) import GHC.Core import GHC.CoreToIface@@ -33,29 +48,16 @@ import GHC.IfaceToCore import GHC.Types.Id.Make import GHC.Utils.Binary+#endif -#if MIN_VERSION_ghc(9,2,0)-import GHC.Types.TypeEnv-#else+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import GHC.Driver.Types #endif -#else-import Binary-import BinFingerprint (fingerprintBinMem)-import BinIface-import CoreSyn-import HscTypes-import IdInfo-import IfaceEnv-import MkId-import TcIface-import ToIface-import Unique-import Var+#if MIN_VERSION_ghc(9,2,0)+import GHC.Types.TypeEnv #endif -import qualified Development.IDE.GHC.Compat.Util as Util -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int@@ -118,7 +120,7 @@ #if MIN_VERSION_ghc(9,2,0) QuietBinIFace #else- (const $ pure ())+ const $ pure () #endif putWithUserData quietTrace bh fat_iface@@ -141,7 +143,7 @@ codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash #else codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash-#endif+ -- | Implicit binds can be generated from the interface and are not tidied, -- so we must filter them out isNotImplictBind :: CoreBind -> Bool@@ -150,6 +152,7 @@ bindBindings :: CoreBind -> [Var] bindBindings (NonRec b _) = [b] bindBindings (Rec bnds) = map fst bnds+#endif getImplicitBinds :: TyCon -> [CoreBind] getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc@@ -167,14 +170,14 @@ | (op, val_index) <- classAllSelIds cls `zip` [0..] ] get_defn :: Id -> CoreBind-get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))+get_defn identifier = NonRec identifier (unfoldingTemplate (realIdUnfolding identifier)) toIfaceTopBndr1 :: Module -> Id -> IfaceId-toIfaceTopBndr1 mod id- = IfaceId (mangleDeclName mod $ getName id)- (toIfaceType (idType id))- (toIfaceIdDetails (idDetails id))- (toIfaceIdInfo (idInfo id))+toIfaceTopBndr1 mod identifier+ = IfaceId (mangleDeclName mod $ getName identifier)+ (toIfaceType (idType identifier))+ (toIfaceIdDetails (idDetails identifier))+ (toIfaceIdInfo (idInfo identifier)) toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r)@@ -224,8 +227,8 @@ pure $ ifid{ ifName = name' } | otherwise = pure ifid -- invariant: 'IfaceId' is always a 'IfaceId' constructor- getIfaceId (AnId id) = id- getIfaceId _ = error "tcIfaceId: got non Id"+ getIfaceId (AnId identifier) = identifier+ getIfaceId _ = error "tcIfaceId: got non Id" tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind tc_iface_bindings (TopIfaceNonRec v e) = do
src/Development/IDE/GHC/Error.hs view
@@ -175,12 +175,12 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do- Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $- handleSourceError (sourceErrorToDiagnostics dflags) $+ Compat.handleGhcException ghcExceptionToDiagnostics $+ handleSourceError sourceErrorToDiagnostics $ Right <$> ghcM where- ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags- sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags+ ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags+ sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags #if MIN_VERSION_ghc(9,3,0) . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages #endif
src/Development/IDE/GHC/Orphans.hs view
@@ -8,49 +8,57 @@ -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where+import Development.IDE.GHC.Compat+import Development.IDE.GHC.Util -#if MIN_VERSION_ghc(9,2,0)-import GHC.Parser.Annotation+import Control.DeepSeq+import Control.Monad.Trans.Reader (ReaderT (..))+import Data.Aeson+import Data.Hashable+import Data.String (IsString (fromString))+import Data.Text (unpack)++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import Bag+import ByteCodeTypes+import GhcPlugins hiding (UniqFM)+import qualified StringBuffer as SB+import Unique (getKey) #endif+ #if MIN_VERSION_ghc(9,0,0)+import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString import qualified GHC.Data.StringBuffer as SB-import GHC.Types.Name.Occurrence import GHC.Types.SrcLoc-import GHC.Types.Unique (getKey)-import GHC.Unit.Info-import GHC.Utils.Outputable-#else-import Bag-import GhcPlugins-import qualified StringBuffer as SB-import Unique (getKey)-#endif +#endif -import Development.IDE.GHC.Compat-import Development.IDE.GHC.Util+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0)+import GHC (ModuleGraph)+import GHC.Types.Unique (getKey)+#endif -import Control.DeepSeq-import Data.Aeson+#if MIN_VERSION_ghc(9,2,0) import Data.Bifunctor (Bifunctor (..))-import Data.Hashable-import Data.String (IsString (fromString))-import Data.Text (unpack)-#if MIN_VERSION_ghc(9,0,0)-import GHC.ByteCode.Types-import GHC (ModuleGraph)-#else-import ByteCodeTypes+import GHC.Parser.Annotation #endif+ #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual #endif+ #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo #endif +-- Orphan instance for Shake.hs+-- https://hub.darcs.net/ross/transformers/issue/86+deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)+ -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable instance NFData CoreModule where rnf = rwhnf@@ -241,8 +249,14 @@ rnf = rwhnf #endif -instance NFData (HsExpr (GhcPass 'Renamed)) where+instance NFData (HsExpr (GhcPass Renamed)) where rnf = rwhnf +instance NFData (Pat (GhcPass Renamed)) where+ rnf = rwhnf+ instance NFData Extension where rnf = rwhnf++instance NFData (UniqFM Name [Name]) where+ rnf (ufmToIntMap -> m) = rnf m
src/Development/IDE/GHC/Util.hs view
@@ -30,25 +30,6 @@ getExtensions ) where -#if MIN_VERSION_ghc(9,2,0)-import GHC.Data.EnumSet-import GHC.Data.FastString-import GHC.Data.StringBuffer-import GHC.Driver.Env hiding (hscSetFlags)-import GHC.Driver.Monad-import GHC.Driver.Session hiding (ExposePackage)-import GHC.Parser.Lexer-import GHC.Runtime.Context-import GHC.Types.Name.Occurrence-import GHC.Types.Name.Reader-import GHC.Types.SrcLoc-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.ModGuts-import GHC.Utils.Fingerprint-import GHC.Utils.Outputable-#else-import Development.IDE.GHC.Compat.Util-#endif import Control.Concurrent import Control.Exception as E import Data.Binary.Put (Put, runPut)@@ -56,40 +37,43 @@ import Data.ByteString.Internal (ByteString (..)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS-import Data.Data (Data) import Data.IORef import Data.List.Extra import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T-import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime,- utcTimeToPOSIXSeconds) import Data.Typeable-import qualified Data.Unique as U-import Debug.Trace-import Development.IDE.GHC.Compat as GHC+import Development.IDE.GHC.Compat as GHC hiding (unitState) import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable-import GHC hiding (ParsedModule (..))+import GHC hiding (ParsedModule (..),+ parser) import GHC.IO.BufferedIO (BufferedIO) import GHC.IO.Device as IODevice import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types-import GHC.Stack import Ide.PluginUtils (unescape)-import System.Environment.Blank (getEnvDefault) import System.FilePath-import System.IO.Unsafe-import Text.Printf +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,2,0)+import Development.IDE.GHC.Compat.Util+#endif++#if MIN_VERSION_ghc(9,2,0)+import GHC.Data.EnumSet+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Utils.Fingerprint+#endif ---------------------------------------------------------------------- -- GHC setup @@ -189,9 +173,9 @@ -- Will produce an 8 byte unreadable ByteString. fingerprintToBS :: Fingerprint -> BS.ByteString fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do- ptr <- pure $ castPtr ptr- pokeElemOff ptr 0 a- pokeElemOff ptr 1 b+ ptr' <- pure $ castPtr ptr+ pokeElemOff ptr' 0 a+ pokeElemOff ptr' 1 b -- | Take the 'Fingerprint' of a 'StringBuffer'. fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
src/Development/IDE/Import/DependencyInformation.hs view
@@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE CPP #-} module Development.IDE.Import.DependencyInformation ( DependencyInformation(..)@@ -33,7 +34,7 @@ import Data.Bifunctor import Data.Coerce import Data.Either-import Data.Graph+import Data.Graph hiding (edges, path) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMS import Data.IntMap (IntMap)@@ -48,13 +49,19 @@ import Data.Tuple.Extra hiding (first, second) import Development.IDE.GHC.Orphans () import GHC.Generics (Generic)+import Prelude hiding (mod) import Development.IDE.Import.FindImports (ArtifactsLocation (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.GHC.Compat++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,3,0) import GHC-import Development.IDE.GHC.Compat+#endif -- | The imports for a given module. newtype ModuleImports = ModuleImports@@ -92,14 +99,14 @@ case HMS.lookup (artifactFilePath path) pathToIdMap of Nothing -> let !newId = FilePathId nextFreshId- in (newId, insertPathId path newId m)- Just id -> (id, m)+ in (newId, insertPathId newId )+ Just fileId -> (fileId, m) where- insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap- insertPathId path id PathIdMap{..} =+ insertPathId :: FilePathId -> PathIdMap+ insertPathId fileId = PathIdMap- (IntMap.insert (getFilePathId id) path idToPathMap)- (HMS.insert (artifactFilePath path) id pathToIdMap)+ (IntMap.insert (getFilePathId fileId) path idToPathMap)+ (HMS.insert (artifactFilePath path) fileId pathToIdMap) (succ nextFreshId) insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation@@ -115,7 +122,7 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation-idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id+idToModLocation PathIdMap{idToPathMap} (FilePathId i) = idToPathMap IntMap.! i type BootIdMap = FilePathIdMap FilePathId @@ -137,7 +144,7 @@ DependencyInformation { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly.- , depModules :: !(FilePathIdMap ShowableModule)+ , depModules :: !(FilePathIdMap ShowableModule) , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package.@@ -273,9 +280,9 @@ errorsForCycle files = IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]- cycleErrorsForFile cycle f =- let entryPoints = mapMaybe (findImport f) cycle- in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints+ cycleErrorsForFile cycles' f =+ let entryPoints = mapMaybe (findImport f) cycles'+ in map (\imp -> (f, ErrorNode (PartOfCycle imp cycles' :| []))) entryPoints otherErrors = IntMap.map otherErrorsForFile g otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
src/Development/IDE/Import/FindImports.hs view
@@ -15,7 +15,6 @@ import Control.DeepSeq import Development.IDE.GHC.Compat as Compat-import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics@@ -27,6 +26,13 @@ import Data.List (isSuffixOf) import Data.Maybe import System.FilePath++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,3,0)+import Development.IDE.GHC.Compat.Util+#endif+ #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual import GHC.Unit.State@@ -55,14 +61,14 @@ rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation-modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mbMod where isSource HsSrcFile = True isSource _ = False source = case ms of- Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp- Just ms -> isSource (ms_hsc_src ms)- mod = ms_mod <$> ms+ Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp+ Just modSum -> isSource (ms_hsc_src modSum)+ mbMod = ms_mod <$> ms -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m@@ -89,7 +95,7 @@ -- as they can never be imported into another package. #if MIN_VERSION_ghc(9,3,0) mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath])-mkImportDirs env (i, flags) = Just (i, importPaths flags)+mkImportDirs _env (i, flags) = Just (i, importPaths flags) #else mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath])) mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i@@ -130,7 +136,7 @@ | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths -> lookupLocal uid dirs #endif- | otherwise -> lookupInPackageDB env+ | otherwise -> lookupInPackageDB #if MIN_VERSION_ghc(9,3,0) NoPkgQual -> do #else@@ -139,7 +145,7 @@ mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName case mbFile of- Nothing -> lookupInPackageDB env+ Nothing -> lookupInPackageDB Just (uid, file) -> toModLocation uid file where dflags = hsc_dflags env@@ -160,7 +166,7 @@ hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units #else- import_paths'+ _import_paths' #endif -- first try to find the module as a file. If we can't find it try to find it in the package@@ -168,7 +174,7 @@ -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure.- import_paths' =+ _import_paths' = -- import_paths' is only used in GHC < 9.4 #if MIN_VERSION_ghc(9,3,0) import_paths #else@@ -178,19 +184,19 @@ toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) #if MIN_VERSION_ghc(9,0,0)- let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes+ let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes #else- let mod = mkModule uid (unLoc modName)+ let genMod = mkModule uid (unLoc modName) #endif- return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod)+ return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) lookupLocal uid dirs = do mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound []- Just (uid, file) -> toModLocation uid file+ Just (uid', file) -> toModLocation uid' file - lookupInPackageDB env = do+ lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr env modName reason
src/Development/IDE/LSP/HoverDefinition.hs view
@@ -40,7 +40,7 @@ hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences+references :: PluginMethodHandler IdeState Method_TextDocumentReferences references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do nfp <- getNormalizedFilePathE uri liftIO $ logDebug (ideLogger ide) $@@ -48,7 +48,7 @@ " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol+wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query
src/Development/IDE/LSP/LanguageServer.hs view
@@ -43,7 +43,6 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) import Ide.Logger-import qualified Ide.Logger as Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>))@@ -77,8 +76,8 @@ "Reactor thread stopped" LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId- LogSession log -> pretty log- LogLspServer log -> pretty log+ LogSession msg -> pretty msg+ LogLspServer msg -> pretty msg -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb@@ -91,12 +90,13 @@ -> Handle -- output -> config -> (config -> Value -> Either T.Text config)+ -> (config -> m config ()) -> (MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO ()-runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do+runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar@@ -104,8 +104,11 @@ (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition- { LSP.onConfigurationChange = onConfigurationChange+ { LSP.parseConfig = parseConfig+ , LSP.onConfigChange = onConfigChange , LSP.defaultConfig = defaultConfig+ -- TODO: magic string+ , LSP.configSection = "haskell" , LSP.doInitialize = doInitialize , LSP.staticHandlers = (const staticHandlers) , LSP.interpretHandler = interpretHandler@@ -113,10 +116,7 @@ } let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog)- lspCologAction = toCologActionWithPrio $ cfilter- -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447- (\msg -> priority msg >= Info)- (cmapWithPrio LogLspServer recorder)+ lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) void $ untilMVar clientMsgVar $ void $ LSP.runServerWithHandles@@ -211,16 +211,16 @@ let initConfig = parseConfiguration params - log Info $ LogRegisteringIdeConfig initConfig+ logWith recorder Info $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do- log Error $ LogReactorThreadException e+ logWith recorder Error $ LogReactorThreadException e exitClientMsg handleServerException (Right _) = pure () exceptionInHandler e = do- log Error $ LogReactorMessageActionException e+ logWith recorder Error $ LogReactorMessageActionException e checkCancelled _id act k = flip finally (clearReqId _id) $@@ -232,15 +232,15 @@ cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do- log Debug $ LogCancelledRequest _id+ logWith recorder Debug $ LogCancelledRequest _id k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do- untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do- putMVar dbMVar (WithHieDbShield withHieDb,hieChan)+ untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do+ putMVar dbMVar (WithHieDbShield withHieDb',hieChan') forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously@@ -248,12 +248,8 @@ case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k- log Info LogReactorThreadStopped+ logWith recorder Info LogReactorThreadStopped pure $ Right (env,ide)-- where- log :: Logger.Priority -> Log -> IO ()- log = logWith recorder -- | Runs the action until it ends or until the given MVar is put.
src/Development/IDE/LSP/Notifications.hs view
@@ -32,12 +32,10 @@ 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.RuleTypes (GetClientSettings (..)) import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location-import Development.IDE.Types.Shake (toKey) import Ide.Logger import Ide.Types import Numeric.Natural@@ -49,8 +47,8 @@ instance Pretty Log where pretty = \case- LogShake log -> pretty log- LogFileStore log -> pretty log+ LogShake msg -> pretty msg+ LogFileStore msg -> pretty msg whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'@@ -119,12 +117,9 @@ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $- \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do- let msg = Text.pack $ show cfg- logDebug (ideLogger ide) $ "Configuration changed: " <> msg- modifyClientSettings ide (const $ Just cfg)- setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change"+ -- Nothing additional to do here beyond what `lsp` does for us, but this prevents+ -- complaints about there being no handler defined+ , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do --------- Initialize Shake session --------------------------------------------------------------------
src/Development/IDE/LSP/Outline.hs view
@@ -11,10 +11,8 @@ import Control.Monad.IO.Class import Data.Functor-import Data.Foldable (toList) import Data.Generics hiding (Prefix) import Data.Maybe-import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat@@ -29,12 +27,20 @@ TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL, InR), uriToFilePath) import Language.LSP.Protocol.Message++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]+ #if MIN_VERSION_ghc(9,2,0)-import Data.List.NonEmpty (nonEmpty)+import Data.List.NonEmpty (nonEmpty)+import Data.Foldable (toList) #endif +#if !MIN_VERSION_ghc(9,3,0)+import qualified Data.Text as T+#endif+ moduleOutline- :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol+ :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do@@ -89,13 +95,13 @@ , _detail = Just "class" , _children = Just $- [ (defDocumentSymbol l :: DocumentSymbol)+ [ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Method- , _selectionRange = realSrcSpanToRange l'+ , _selectionRange = realSrcSpanToRange l'' }- | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs- , L (locA -> (RealSrcSpan l' _)) n <- names+ | L (locA -> (RealSrcSpan l' _)) (ClassOpSig _ False names _) <- tcdSigs+ , L (locA -> (RealSrcSpan l'' _)) n <- names ] } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))@@ -104,28 +110,28 @@ , _kind = SymbolKind_Struct , _children = Just $- [ (defDocumentSymbol l :: DocumentSymbol)+#if MIN_VERSION_ghc(9,2,0)+ [ (defDocumentSymbol l'' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l'-#if MIN_VERSION_ghc(9,2,0) , _children = toList <$> nonEmpty childs } | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con , let childs = mapMaybe cvtFld flds , L (locA -> RealSrcSpan l' _) n <- cs- , let l = case con of- L (locA -> RealSrcSpan l _) _ -> l+ , let l'' = case con of+ L (locA -> RealSrcSpan l''' _) _ -> l''' _ -> l' ] } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol #if MIN_VERSION_ghc(9,3,0)- cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)+ cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) #else- cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol)+ cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) #endif #if MIN_VERSION_ghc(9,3,0) { _name = printOutputable (unLoc (foLabel n))@@ -136,21 +142,25 @@ } cvtFld _ = Nothing #else+ [ (defDocumentSymbol l'' :: DocumentSymbol)+ { _name = printOutputable n+ , _kind = SymbolKind_Constructor+ , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) }- | L (locA -> (RealSrcSpan l _ )) x <- dd_cons+ | L (locA -> (RealSrcSpan l'' _ )) x <- dd_cons , L (locA -> (RealSrcSpan l' _)) n <- getConNames' x ] } where -- | Extract the record fields of a constructor conArgRecordFields (RecCon (L _ lcdfs)) = Just- [ (defDocumentSymbol l :: DocumentSymbol)+ [ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Field } | L _ cdf <- lcdfs- , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf+ , L (locA -> (RealSrcSpan l' _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing #endif
src/Development/IDE/LSP/Server.hs view
@@ -14,7 +14,7 @@ import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing-import Ide.Types (HasTracing, traceWithSpan)+import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Server (Handlers, LspM) import qualified Language.LSP.Server as LSP@@ -30,7 +30,7 @@ deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler- :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) =>+ :: forall m c. PluginMethod Request m => SMethod m -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c)@@ -45,7 +45,7 @@ writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler- :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) =>+ :: forall m c. PluginMethod Notification m => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c)
src/Development/IDE/Main.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-} module Development.IDE.Main (Arguments(..) ,defaultArguments@@ -12,13 +11,18 @@ ,testing ,Log(..) ) where+ import Control.Concurrent.Extra (withNumCapabilities)+import Control.Concurrent.MVar (newEmptyMVar,+ putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) import Control.Monad.Extra (concatMapM, unless, when)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Aeson as J import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Foldable (traverse_)@@ -30,14 +34,15 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import Development.IDE (Action,- GhcVersion (..), Priority (Debug, Error),- Rules, ghcVersion,+ Rules, emptyFilePath, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer)-import Development.IDE.Core.FileStore (isWatchSupported)+import Development.IDE.Core.FileStore (isWatchSupported,+ setSomethingModified) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..),+ modifyClientSettings, registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick,@@ -77,14 +82,6 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath')-import Ide.Logger (Logger,- Pretty (pretty),- Priority (Info, Warning),- Recorder,- WithPriority,- cmapWithPrio,- logWith, nest, vsep,- (<+>)) import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),@@ -93,12 +90,20 @@ defaultIdeOptions, optModifyDynFlags, optTesting)-import Development.IDE.Types.Shake (WithHieDb)+import Development.IDE.Types.Shake (WithHieDb, toKey) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) import qualified HieDb.Run as HieDb+import Ide.Logger (Logger,+ Pretty (pretty),+ Priority (Info),+ Recorder,+ WithPriority,+ cmapWithPrio,+ logDebug, logWith,+ nest, vsep, (<+>)) import Ide.Plugin.Config (CheckParents (NeverCheck), Config, checkParents, checkProject,@@ -147,7 +152,7 @@ instance Pretty Log where pretty = \case- LogHeapStats log -> pretty log+ LogHeapStats msg -> pretty msg LogLspStart pluginIds -> nest 2 $ vsep [ "Starting LSP server..."@@ -160,13 +165,13 @@ "shouldRunSubset:" <+> pretty shouldRunSubset LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e)- LogService log -> pretty log- LogShake log -> pretty log- LogGhcIde log -> pretty log- LogLanguageServer log -> pretty log- LogSession log -> pretty log- LogPluginHLS log -> pretty log- LogRules log -> pretty log+ LogService msg -> pretty msg+ LogShake msg -> pretty msg+ LogGhcIde msg -> pretty msg+ LogLanguageServer msg -> pretty msg+ LogSession msg -> pretty msg+ LogPluginHLS msg -> pretty msg+ LogRules msg -> pretty msg data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures@@ -281,9 +286,6 @@ defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where- log :: Priority -> Log -> IO ()- log = logWith recorder- fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID@@ -294,7 +296,7 @@ hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }- argsOnConfigChange = getConfigFromNotification argsHlsPlugins+ argsParseConfig = getConfigFromNotification argsHlsPlugins rules = argsRules >> pluginRules plugins debouncer <- argsDebouncer@@ -306,14 +308,15 @@ case argCommand of LSP -> withNumCapabilities numCapabilities $ do- t <- offsetTime- log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)+ ioT <- offsetTime+ logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) + ideStateVar <- newEmptyMVar let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do traverse_ IO.setCurrentDirectory rootPath- t <- t- log Info $ LogLspStartDuration t+ t <- ioT+ logWith recorder Info $ LogLspStartDuration t dir <- maybe IO.getCurrentDirectory return rootPath @@ -322,7 +325,7 @@ _mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead- `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing)+ `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig@@ -330,16 +333,16 @@ -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported- log Debug $ LogShouldRunSubset runSubset+ logWith recorder Debug $ LogShouldRunSubset runSubset - let options = def_options+ let ideOptions = def_options { optReportProgress = clientSupportsProgress caps , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins , optRunSubset = runSubset } caps = LSP.resClientCapabilities env monitoring <- argsMonitoring- initialise+ ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins@@ -347,14 +350,28 @@ (Just env) logger debouncer- options+ ideOptions withHieDb hieChan monitoring+ putMVar ideStateVar ide+ pure ide let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState+ -- See Note [Client configuration in Rules]+ onConfigChange cfg = do+ -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint+ let cfgObj = J.toJSON cfg+ mide <- liftIO $ tryReadMVar ideStateVar+ case mide of+ Nothing -> pure ()+ Just ide -> liftIO $ do+ let msg = T.pack $ show cfg+ logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg+ modifyClientSettings ide (const $ Just cfgObj)+ setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup+ runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot@@ -370,11 +387,11 @@ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir files <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly- files <- nubOrd <$> mapM IO.canonicalizePath files- putStrLn $ "Found " ++ show (length files) ++ " files"+ absoluteFiles <- nubOrd <$> mapM IO.canonicalizePath files+ putStrLn $ "Found " ++ show (length absoluteFiles) ++ " files" putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"- cradles <- mapM findCradle files+ cradles <- mapM findCradle absoluteFiles let ucradles = nubOrd cradles let n = length ucradles putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]@@ -382,25 +399,25 @@ putStrLn "\nStep 3/4: Initializing the IDE" sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader- options = def_options+ ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins }- ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty+ ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files"- setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files- results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)- _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)- _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)- let (worked, failed) = partition fst $ zip (map isJust results) 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 when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+ let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files" putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" unless (null failed) (exitWith $ ExitFailure (length failed))@@ -420,12 +437,12 @@ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader- options = def_options+ ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins }- ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty+ ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide@@ -437,9 +454,9 @@ then return [x] else do let recurse "." = True- recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc- recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories- files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x+ recurse y | "." `isPrefixOf` takeFileName y = False -- skip .git etc+ recurse y = takeFileName y `notElem` ["dist", "dist-newstyle"] -- cabal directories+ files <- filter (\y -> takeExtension y `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files
src/Development/IDE/Main/HeapStats.hs view
@@ -19,7 +19,7 @@ deriving Show instance Pretty Log where- pretty log = case log of+ pretty = \case LogHeapStatsPeriod period -> "Logging heap statistics every" <+> pretty (toFormattedSeconds period) LogHeapStatsDisabled ->
src/Development/IDE/Monitoring/EKG.hs view
@@ -3,6 +3,7 @@ import Development.IDE.Types.Monitoring (Monitoring (..)) import Ide.Logger (Logger)+ #ifdef MONITORING_EKG import Control.Concurrent (killThread) import Control.Concurrent.Async (async, waitCatch)
src/Development/IDE/Monitoring/OpenTelemetry.hs view
@@ -15,9 +15,9 @@ monitoring | userTracingEnabled = do actions <- newIORef []- let registerCounter name read = do+ let registerCounter name readA = do observer <- mkValueObserver (encodeUtf8 name)- let update = observe observer . fromIntegral =<< read+ let update = observe observer . fromIntegral =<< readA atomicModifyIORef'_ actions (update :) registerGauge = registerCounter let start = do
src/Development/IDE/Plugin/Completions.hs view
@@ -11,11 +11,10 @@ import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO)-import Control.Lens ((&), (.~))+import Control.Lens ((&), (.~), (?~)) import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT (ExceptT), withExceptT)-import Data.Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import Data.Maybe@@ -25,7 +24,8 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake)-import Development.IDE.Core.Shake hiding (Log)+import Development.IDE.Core.Shake hiding (Log,+ knownTargets) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util@@ -50,17 +50,24 @@ import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import Numeric.Natural+import Prelude hiding (mod) import Text.Fuzzy.Parallel (Scored (..)) import Development.IDE.Core.Rules (usePropertyAction)-import qualified GHC.LanguageExtensions as LangExt+ import qualified Ide.Plugin.Config as Config +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc(9,2,0)+import qualified GHC.LanguageExtensions as LangExt+#endif+ data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case- LogShake log -> pretty log+ LogShake msg -> pretty msg ghcideCompletionsPluginPriority :: Natural ghcideCompletionsPluginPriority = defaultPluginPriority@@ -79,8 +86,8 @@ produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file- pm <- useWithStale GetParsedModule file- case pm of+ mbPm <- useWithStale GetParsedModule file+ case mbPm of Just (pm, _) -> do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata)@@ -90,9 +97,9 @@ -- synthesizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file- sess <- fmap fst <$> useWithStale GhcSessionDeps file+ mbSess <- fmap fst <$> useWithStale GhcSessionDeps file - case (ms, sess) of+ case (ms, mbSess) of (Just ModSummaryResult{..}, Just sess) -> do let env = hscEnv sess -- We do this to be able to provide completions of items that are not restricted to the explicit list@@ -122,7 +129,7 @@ f x = x in f <$> iDecl -resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve+resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_CompletionItemResolve resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = do file <- getNormalizedFilePathE uri@@ -137,8 +144,8 @@ #endif mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file let (dm,km) = case mdkm of- Just (DKMap dm km, _) -> (dm,km)- Nothing -> (mempty, mempty)+ Just (DKMap docMap kindMap, _) -> (docMap,kindMap)+ Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name@@ -155,13 +162,13 @@ InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc pure (comp & L.detail .~ (det1 <> _detail)- & L.documentation .~ Just doc1)+ & L.documentation ?~ doc1) where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -- | Generate code actions.-getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion+getCompletionsLSP :: PluginMethodHandler IdeState Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position@@ -207,7 +214,7 @@ Just (cci', parsedMod, bindMap) -> do let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of- ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})+ (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) -> return (InL []) (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic (@@ -15,7 +15,8 @@ ) where import Control.Applicative-import Control.Lens hiding (Context)+import Control.Lens hiding (Context,+ parts) import Data.Char (isAlphaNum, isUpper) import Data.Default (def) import Data.Generics@@ -23,9 +24,10 @@ (stripPrefix) import qualified Data.Map as Map import Data.Row+import Prelude hiding (mod) -import Data.Maybe (catMaybes, fromMaybe,- isJust, isNothing,+import Data.Maybe (fromMaybe, isJust,+ isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T@@ -34,37 +36,22 @@ import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Function (on)-import Data.Functor-import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.Monoid (First (..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set-import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping-import Development.IDE.GHC.Compat hiding (ppr)+import Development.IDE.GHC.Compat hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types-import Development.IDE.Spans.Common-import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports-import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options--#if MIN_VERSION_ghc(9,2,0)-import GHC.Plugins (Depth (AllTheWay),- defaultSDocContext,- mkUserStyle,- neverQualify,- renderWithContext,- sdocStyle)-#endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..),@@ -76,10 +63,24 @@ original) import qualified Data.Text.Utf16.Rope as Rope-import Development.IDE+import Development.IDE hiding (line) import Development.IDE.Spans.AtPoint (pointCommand) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if MIN_VERSION_ghc(9,2,0)+import GHC.Plugins (Depth (AllTheWay),+ mkUserStyle,+ neverQualify,+ sdocStyle)+#endif++#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)+import GHC.Plugins (defaultSDocContext,+ renderWithContext)+#endif+ #if MIN_VERSION_ghc(9,5,0) import Language.Haskell.Syntax.Basic #endif@@ -144,12 +145,15 @@ | pos `isInsideSrcSpan` r = Just TypeContext goInline _ = Nothing +#if MIN_VERSION_ghc(9,5,0) importGo :: GHC.LImportDecl GhcPs -> Maybe Context importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r-#if MIN_VERSION_ghc(9,5,0) = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) #else+ importGo :: GHC.LImportDecl GhcPs -> Maybe Context+ importGo (L (locA -> r) impDecl)+ | pos `isInsideSrcSpan` r = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) #endif <|> Just (ImportContext importModuleName)@@ -160,18 +164,24 @@ -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (EverythingBut, L r _))+ | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName+ | otherwise = Nothing #else importInline modName (Just (True, L r _))-#endif | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing+#endif+ #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (Exactly, L r _))+ | pos `isInsideSrcSpan` r = Just $ ImportListContext modName+ | otherwise = Nothing #else importInline modName (Just (False, L r _))-#endif | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing+#endif+ importInline _ _ = Nothing occNameToComKind :: OccName -> CompletionItemKind@@ -191,7 +201,7 @@ -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl pId- IdeOptions {..}+ _ideOptions uri CI { compKind,@@ -285,27 +295,27 @@ mkModCompl :: T.Text -> CompletionItem mkModCompl label =- (defaultCompletionItemWithLabel label)- { _kind = Just CompletionItemKind_Module }+ defaultCompletionItemWithLabel label+ & L.kind ?~ CompletionItemKind_Module mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label =- (defaultCompletionItemWithLabel label)- { _kind = Just CompletionItemKind_Function- , _detail = Just moduleName }+ defaultCompletionItemWithLabel label+ & L.kind ?~ CompletionItemKind_Function+ & L.detail ?~ moduleName mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label =- (defaultCompletionItemWithLabel m)- { _kind = Just CompletionItemKind_Module- , _detail = Just label }+ defaultCompletionItemWithLabel m+ & L.kind ?~ CompletionItemKind_Module+ & L.detail ?~ label where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label =- (defaultCompletionItemWithLabel label)- { _kind = Just CompletionItemKind_Keyword }+ defaultCompletionItemWithLabel label+ & L.kind ?~ CompletionItemKind_Keyword defaultCompletionItemWithLabel :: T.Text -> CompletionItem defaultCompletionItemWithLabel label =@@ -313,14 +323,14 @@ def def def def def def def def def fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem-fromIdentInfo doc id@IdentInfo{..} q = CI+fromIdentInfo doc identInfo@IdentInfo{..} q = CI { compKind= occNameToComKind name , insertText=rend , provenance = DefinedIn mod , label=rend , typeText = Nothing , isInfix=Nothing- , isTypeCompl= not (isDatacon id) && isUpper (T.head rend)+ , isTypeCompl= not (isDatacon identInfo) && isUpper (T.head rend) , additionalTextEdits= Just $ ExtendImport { doc,@@ -332,8 +342,8 @@ , nameDetails = Nothing , isLocalCompletion = False }- where rend = rendered id- mod = moduleNameText id+ where rend = rendered identInfo+ mod = moduleNameText identInfo cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports =@@ -396,7 +406,7 @@ in (unqual,QualCompls qual) toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem]- toCompItem par m mn n imp' =+ toCompItem par _ mn n imp' = -- docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n)@@ -439,34 +449,34 @@ } where typeSigIds = Set.fromList- [ id+ [ identifier | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls- , L _ id <- ids+ , L _ identifier <- ids ] hasTypeSig = (`Set.member` typeSigIds) . unLoc compls = concat [ case decl of SigD _ (TypeSig _ ids typ) ->- [mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | id <- ids]+ [mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | identifier <- ids] ValD _ FunBind{fun_id} -> [ mkComp fun_id CompletionItemKind_Function Nothing | not (hasTypeSig fun_id) ] ValD _ PatBind{pat_lhs} ->- [mkComp id CompletionItemKind_Variable Nothing- | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]+ [mkComp identifier CompletionItemKind_Variable Nothing+ | VarPat _ identifier <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) :- [ mkComp id CompletionItemKind_Function (Just $ showForSnippet typ)+ [ mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs- , id <- ids] +++ , identifier <- ids] ++ [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName) | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x ->- let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x)- | id <- listify (\(_ :: LIdP GhcPs) -> True) x- , let cl = occNameToComKind (rdrNameOcc $ unLoc id)]+ let generalCompls = [mkComp identifier cl (Just $ showForSnippet $ tyClDeclLName x)+ | identifier <- listify (\(_ :: LIdP GhcPs) -> True) x+ , let cl = occNameToComKind (rdrNameOcc $ unLoc identifier)] -- here we only have to look at the outermost type recordCompls = findRecordCompl uri (Local pos) x in@@ -670,9 +680,9 @@ | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls)) ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls - filtListWith f list =+ filtListWith f xs = [ fmap f label- | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list+ | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix xs , enteredQual `T.isPrefixOf` original label ]
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -19,17 +19,24 @@ import Data.Typeable (Typeable) import Development.IDE.GHC.Compat import Development.IDE.Graph (RuleResult)-import Development.IDE.Spans.Common+import Development.IDE.Spans.Common () import GHC.Generics (Generic) import Ide.Plugin.Properties import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) import qualified Language.LSP.Protocol.Types as J++-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import qualified OccName as Occ+#endif+ #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Types.Name.Occurrence as Occ-#else-import qualified OccName as Occ #endif ++ -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions@@ -53,8 +60,8 @@ extendImportCommandId = "extendImport" properties :: Properties- '[ 'PropertyKey "autoExtendOn" 'TBoolean,- 'PropertyKey "snippetsOn" 'TBoolean]+ '[ 'PropertyKey "autoExtendOn" TBoolean,+ 'PropertyKey "snippetsOn" TBoolean] properties = emptyProperties & defineBooleanProperty #snippetsOn "Inserts snippets when using code completions"@@ -200,7 +207,7 @@ instance Show NameDetails where show = show . toJSON --- | The data that is acutally sent for resolve support+-- | The data that is actually sent for resolve support -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData
src/Development/IDE/Plugin/HLS.hs view
@@ -11,7 +11,6 @@ ) where import Control.Exception (SomeException)-import Control.Lens ((^.)) import Control.Monad import Control.Monad.Trans.Except (runExceptT) import qualified Data.Aeson as A@@ -39,7 +38,6 @@ import Ide.Plugin.Error import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS-import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP@@ -65,22 +63,15 @@ LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> pretty err LogResponseError (PluginId pId) err ->- pretty pId <> ":" <+> prettyResponseError err+ pretty pId <> ":" <+> pretty err LogNoPluginForMethod (Some method) ->- "No plugin enabled for " <> pretty (show method)+ "No plugin enabled for " <> pretty method LogInvalidCommandIdentifier-> "Invalid command identifier" ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing "- <> viaShow method <> ": " <> viaShow exception+ <> pretty method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty --- various error message specific builders-prettyResponseError :: ResponseError -> Doc a-prettyResponseError err = errorCode <> ":" <+> errorBody- where- errorCode = pretty $ show $ err ^. L.code- errorBody = pretty $ err ^. L.message- noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) noPluginEnabled recorder m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m)@@ -91,7 +82,7 @@ pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)- + pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -232,9 +223,9 @@ -- --------------------------------------------------------------------- extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config-extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }+extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers } where- IdeHandlers handlers' = foldMap bakePluginId xs+ IdeHandlers handlers' = foldMap bakePluginId plugins bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)])@@ -250,11 +241,11 @@ -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')- Just fs -> do- let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs- es <- runConcurrently exceptionInPlugin m handlers ide params+ Just neFs -> do+ let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs+ es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params caps <- LSP.getClientCapabilities- let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es+ let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of Nothing -> do@@ -288,12 +279,12 @@ case nonEmpty fs of Nothing -> do logWith recorder Warning (LogNoPluginForMethod $ Some m)- Just fs -> do+ Just neFs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params `catchAny` -- See Note [Exception handling in plugins]- (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs+ (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) neFs -- ---------------------------------------------------------------------@@ -344,14 +335,14 @@ instance Semigroup IdeHandlers where (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b where- go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a <> b)+ go _ (IdeHandler c) (IdeHandler d) = IdeHandler (c <> d) instance Monoid IdeHandlers where mempty = IdeHandlers mempty instance Semigroup IdeNotificationHandlers where (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b where- go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b)+ go _ (IdeNotificationHandler c) (IdeNotificationHandler d) = IdeNotificationHandler (c <> d) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -27,9 +27,9 @@ instance Pretty Log where pretty = \case- LogNotifications log -> pretty log- LogCompletions log -> pretty log- LogTypeLenses log -> pretty log+ LogNotifications msg -> pretty msg+ LogCompletions msg -> pretty msg+ LogTypeLenses msg -> pretty msg descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder =@@ -59,7 +59,7 @@ -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover+hover' :: PluginMethodHandler IdeState Method_TextDocumentHover hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..}
src/Development/IDE/Plugin/Test.hs view
@@ -46,7 +46,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic)-import Ide.Plugin.Config (CheckParents) import Ide.Plugin.Error import Ide.Types import Language.LSP.Protocol.Message
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -15,28 +15,29 @@ import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf)+import Control.Lens ((?~)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift))-import Data.Aeson.Types (Value, toJSON)+import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A import Data.List (find) import qualified Data.Map as Map-import Data.Maybe (catMaybes, mapMaybe)+import Data.Maybe (catMaybes, maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv),- RuleResult, Rules,+ RuleResult, Rules, Uri, define, srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping,+ fromCurrentRange, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction)-import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),- TypeCheck (TypeCheck))+import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use)@@ -44,8 +45,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes-import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)-import Development.IDE.Types.Location (Position (Position, _character, _line),+import Development.IDE.Types.Location (Position (Position, _line), Range (Range, _end, _start)) import GHC.Generics (Generic) import Ide.Logger (Pretty (pretty),@@ -60,31 +60,35 @@ PluginDescriptor (..), PluginId, PluginMethodHandler,+ ResolveFunction, configCustomConfig, defaultConfigDescriptor, defaultPluginDescriptor, mkCustomConfig,- mkPluginHandler)-import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens),+ mkPluginHandler,+ mkResolveHandler)+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),- CodeLens (CodeLens),+ CodeLens (..), CodeLensParams (CodeLensParams, _textDocument),- Diagnostic (..),+ Command, Diagnostic (..), Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), type (|?) (..)) import qualified Language.LSP.Server as LSP-import Text.Regex.TDFA ((=~), (=~~))+import Text.Regex.TDFA ((=~)) data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case- LogShake log -> pretty log+ LogShake msg -> pretty msg + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -92,12 +96,13 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider+ <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]+properties :: Properties '[ 'PropertyKey "mode" (TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" [ (Always, "Always displays type lenses of global bindings")@@ -109,97 +114,115 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePathE uri- env <- hscEnv . fst <$>- runActionE "codeLens.GhcSession" ideState- (useWithStaleE GhcSession nfp)-- (tmr, _) <- runActionE "codeLens.TypeCheck" ideState- (useWithStaleE TypeCheck nfp)-- (bindings, _) <- runActionE "codeLens.GetBindings" ideState- (useWithStaleE GetBindings nfp)-- (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <-- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState- (useWithStaleE GetGlobalBindingTypeSigs nfp)-- diag <- liftIO $ atomically $ getDiagnostics ideState- hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState+ -- We have two ways we can possibly generate code lenses for type lenses.+ -- Different options are with different "modes" of the type-lenses plugin.+ -- (Remember here, as the code lens is not resolved yet, we only really need+ -- the range and any data that will help us resolve it later)+ let -- The first option is to generate lens from diagnostics about+ -- top level bindings.+ generateLensFromGlobalDiags diags =+ -- We don't actually pass any data to resolve, however we need this+ -- dummy type to make sure HLS resolves our lens+ [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)+ | (dFile, _, diag@Diagnostic{_range}) <- diags+ , dFile == nfp+ , isGlobalDiagnostic diag]+ -- The second option is to generate lenses from the GlobalBindingTypeSig+ -- rule. This is the only type that needs to have the range adjusted+ -- with PositionMapping.+ -- PositionMapping for diagnostics doesn't make sense, because we always+ -- have fresh diagnostics even if current module parsed failed (the+ -- diagnostic would then be parse failed). See+ -- https://github.com/haskell/haskell-language-server/pull/3558 for this+ -- discussion.+ generateLensFromGlobal sigs mp = do+ [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve)+ | sig <- sigs+ , Just range <- [srcSpanToRange (gbSrcSpan sig)]+ , Just newRange <- [toCurrentRange mp range]]+ if mode == Always || mode == Exported+ then do+ -- In this mode we get the global bindings from the+ -- GlobalBindingTypeSigs rule.+ (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <-+ runActionE "codeLens.GetGlobalBindingTypeSigs" ideState+ $ useWithStaleE GetGlobalBindingTypeSigs nfp+ -- Depending on whether we only want exported or not we filter our list+ -- of signatures to get what we want+ let relevantGlobalSigs =+ if mode == Exported+ then filter gbExported gblSigs+ else gblSigs+ pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp+ else do+ -- For this mode we exclusively use diagnostics to create the lenses.+ -- However we will still use the GlobalBindingTypeSigs to resolve them.+ diags <- liftIO $ atomically $ getDiagnostics ideState+ hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState+ let allDiags = diags <> hDiags+ pure $ InL $ generateLensFromGlobalDiags allDiags - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ tedit) Nothing Nothing- generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do- range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig)- tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp)- let wedit = toWorkSpaceEdit [tedit]- pure $ generateLens pId range (T.pack gbRendered) wedit- generateLensFromDiags f =- [ generateLens pId _range title edit- | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag- , dFile == nfp- , (title, tedit) <- f dDiag- , let edit = toWorkSpaceEdit tedit- ]- -- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning,- -- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh.- pure $ InL $ case mode of- Always ->- mapMaybe (generateLensForGlobal gblSigsMp) gblSigs'- <> generateLensFromDiags- (suggestLocalSignature False (Just env) (Just tmr) (Just bindings)) -- we still need diagnostics for local bindings- Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs')- Diagnostics -> generateLensFromDiags- $ suggestSignature False (Just env) (Just gblSigs) (Just tmr) (Just bindings)+codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve+codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do+ nfp <- getNormalizedFilePathE uri+ (gblSigs@(GlobalBindingTypeSigsResult _), pm) <-+ runActionE "codeLens.GetGlobalBindingTypeSigs" ideState+ $ useWithStaleE GetGlobalBindingTypeSigs nfp+ -- 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+ -- beginning or freshly taken from diagnostics.+ newRange <- handleMaybe PluginStaleResolve (fromCurrentRange pm _range)+ -- We also pass on the PositionMapping so that the generated text edit can+ -- have the range adjusted.+ (title, edit) <-+ handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange+ pure $ lens & L.command ?~ generateLensCommand pId uri title edit -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens-generateLens pId _range title edit =- let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])- in CodeLens _range (Just cId) Nothing+generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command+generateLensCommand pId uri title edit =+ let wEdit = WorkspaceEdit (Just $ Map.singleton uri $ [edit]) Nothing Nothing+ in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit]) +-- Since the lenses are created with diagnostics, and since the globalTypeSig+-- rule can't be changed as it is also used by the hls-refactor plugin, we can't+-- rely on actions. Because we can't rely on actions it doesn't make sense to+-- recompute the edit upon command. Hence the command here just takes a edit+-- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) pure $ InR Null --------------------------------------------------------------------------------+suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)]+suggestSignature isQuickFix mGblSigs diag =+ maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]-suggestSignature isQuickFix env mGblSigs mTmr mBindings diag =- suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag+-- The suggestGlobalSignature is separated into two functions. The main function+-- works with a diagnostic, which then calls the secondary function with+-- whatever pieces of the diagnostic it needs. This allows the resolve function,+-- which no longer has the Diagnostic, to still call the secondary functions.+suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit)+suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range}+ | isGlobalDiagnostic diag =+ suggestGlobalSignature' isQuickFix mGblSigs Nothing _range+ | otherwise = Nothing -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]-suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}- | _message- =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)- , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs- , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs- , signature <- T.pack $ gbRendered sig- , title <- if isQuickFix then "add signature: " <> signature else signature- , Just action <- gblBindingTypeSigToEdit sig Nothing =- [(title, [action])]- | otherwise = []+isGlobalDiagnostic :: Diagnostic -> Bool+isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) -suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]-suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}}- | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <-- (T.unwords . T.words $ _message)- =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)- , Just bindings <- mBindings- , Just env <- mEnv- , localScope <- getFuzzyScope bindings _start _end- , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name- Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy- , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr- , -- not a top-level thing, to avoid duplication- not $ name `elemNameSet` tcg_sigs- , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault env tcg_rdr_env) $ pprSigmaType ty- , signature <- T.pack $ printName name <> " :: " <> tyMsg- , startCharacter <- _character _start- , startOfLine <- Position (_line _start) startCharacter- , beforeLine <- Range startOfLine startOfLine+-- If a PositionMapping is supplied, this function will call+-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location.+suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit)+suggestGlobalSignature' isQuickFix mGblSigs pm range+ | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs+ , Just sig <- find (\x -> sameThing (gbSrcSpan x) range) sigs+ , signature <- T.pack $ gbRendered sig , title <- if isQuickFix then "add signature: " <> signature else signature- , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =- [(title, [action])]- | otherwise = []+ , Just action <- gblBindingTypeSigToEdit sig pm =+ Just (title, action)+ | otherwise = Nothing sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2)@@ -209,12 +232,20 @@ | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 , beforeLine <- Range startOfLine startOfLine- -- If `mmp` is `Nothing`, return the original range, it used by lenses from diagnostic,+ -- If `mmp` is `Nothing`, return the original range, -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed. , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp- = Just $ TextEdit range $ T.pack gbRendered <> "\n"+ -- We need to flatten the signature, as otherwise long signatures are+ -- rendered on multiple lines with invalid formatting.+ , renderedFlat <- unwords $ lines gbRendered+ = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing +-- |We don't need anything to resolve our lens, but a data field is mandatory+-- to get types resolved in HLS+data TypeLensesResolve = TypeLensesResolve+ deriving (Generic, A.FromJSON, A.ToJSON)+ data Mode = -- | always displays type lenses of global bindings, no matter what GHC flags are set Always@@ -282,11 +313,11 @@ showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f- bindToSig id = do- let name = idName id+ bindToSig identifier = do+ let name = idName identifier hasSig name $ do env <- tcInitTidyEnv- let (_, ty) = tidyOpenType env (idType id)+ let (_, ty) = tidyOpenType env (idType identifier) pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) patToSig p = do let name = patSynName p
src/Development/IDE/Spans/AtPoint.hs view
@@ -30,6 +30,7 @@ import Development.IDE.Types.Location import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..))+import Prelude hiding (mod) -- compiler and infrastructure import Development.IDE.Core.PositionMapping@@ -58,7 +59,8 @@ import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb)-import HieDb hiding (pointCommand)+import HieDb hiding (pointCommand,+ withHieDb) import System.Directory (doesFileExist) -- | Gives a Uri for the module, given the .hie file location and the the module info@@ -93,11 +95,11 @@ Just (HAR _ hf _ _ _,mapping) -> let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts- go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs+ go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs where- refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst)+ refs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst) $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names- typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation)+ typerefs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation) $ concat $ mapMaybe (`M.lookup` tr) names in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) @@ -133,8 +135,8 @@ typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do- refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude)- pure $ mapMaybe typeRowToLoc refs+ refs' <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude)+ pure $ mapMaybe typeRowToLoc refs' _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -243,9 +245,9 @@ -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool- isInternal (Right _, dets) =+ isInternal (Right _, _dets) = -- dets is only used in GHC >= 9.0.1 #if MIN_VERSION_ghc(9,0,1)- any isEvidenceContext $ identInfo dets+ any isEvidenceContext $ identInfo _dets #else False #endif@@ -270,7 +272,7 @@ prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do m <- nameModule_maybe n- pkgTxt <- packageNameWithVersion m env+ pkgTxt <- packageNameWithVersion m pure $ "*(" <> pkgTxt <> ")*" -- Return the module text itself and@@ -279,14 +281,14 @@ packageNameForImportStatement mod = do mpkg <- findImportedModule env mod :: IO (Maybe Module) let moduleName = printOutputable mod- case mpkg >>= flip packageNameWithVersion env of+ case mpkg >>= packageNameWithVersion of Nothing -> pure moduleName Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion -- 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 -> HscEnv -> Maybe T.Text- packageNameWithVersion m env = do+ packageNameWithVersion :: Module -> Maybe T.Text+ packageNameWithVersion m = do let pid = moduleUnit m conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf@@ -331,20 +333,20 @@ unfold = map (arr A.!) getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) where ni = nodeInfo' x- getTypes ts = flip concatMap (unfold ts) $ \case+ getTypes' ts' = flip concatMap (unfold ts') $ \case HTyVarTy n -> [n]- HAppTy a (HieArgs xs) -> getTypes (a : map snd xs)- HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs)- HForAllTy _ a -> getTypes [a]+ HAppTy a (HieArgs xs) -> getTypes' (a : map snd xs)+ HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes' (map snd xs)+ HForAllTy _ a -> getTypes' [a] #if MIN_VERSION_ghc(9,0,1)- HFunTy a b c -> getTypes [a,b,c]+ HFunTy a b c -> getTypes' [a,b,c] #else- HFunTy a b -> getTypes [a,b]+ HFunTy a b -> getTypes' [a,b] #endif- HQualTy a b -> getTypes [a,b]- HCastTy a -> getTypes [a]+ HQualTy a b -> getTypes' [a,b]+ HCastTy a -> getTypes' [a] _ -> []- in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)+ in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts) HieFresh -> let ts = concat $ pointCommand ast pos getts getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)@@ -412,8 +414,8 @@ -- This is a hack to make find definition work better with ghcide's nascent multi-component support, -- where names from a component that has been indexed in a previous session but not loaded in this -- session may end up with different unit ids- erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing)- case erow of+ erow' <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing)+ case erow' of [] -> MaybeT $ pure Nothing xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs
src/Development/IDE/Spans/Documentation.hs view
@@ -29,13 +29,11 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common+import Language.LSP.Protocol.Types (filePathToUri, getUri)+import Prelude hiding (mod) import System.Directory import System.FilePath -import Language.LSP.Protocol.Types (filePathToUri, getUri)-#if MIN_VERSION_ghc(9,3,0)-import GHC.Types.Unique.Map-#endif mkDocMap :: HscEnv@@ -59,17 +57,17 @@ k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where- getDocs n map- | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist+ getDocs n nameMap+ | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist | otherwise = do doc <- getDocumentationTryGhc env n- pure $ extendNameEnv map n doc- getType n map+ pure $ extendNameEnv nameMap n doc+ getType n nameMap | isTcOcc $ occName n- , Nothing <- lookupNameEnv map n+ , Nothing <- lookupNameEnv nameMap n = do kind <- lookupKind env n- pure $ maybe map (extendNameEnv map n) kind- | otherwise = pure map+ pure $ maybe nameMap (extendNameEnv nameMap n) kind+ | otherwise = pure nameMap names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod@@ -85,8 +83,8 @@ getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env names = do- res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names- case res of+ resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names+ case resOr of Left _ -> return [] Right res -> zipWithM unwrap res names where@@ -123,6 +121,9 @@ => [ParsedModule] -- ^ All of the possible modules it could be defined in. -> name -- ^ The name you want documentation for. -> [T.Text]+#if MIN_VERSION_ghc(9,2,0)+getDocumentation _sources _targetName = []+#else -- This finds any documentation between the name you want -- documentation for and the one before it. This is only an -- approximately correct algorithm and there are easily constructed@@ -133,10 +134,7 @@ -- TODO : Implement this for GHC 9.2 with in-tree annotations -- (alternatively, just remove it and rely solely on GHC's parsing) getDocumentation sources targetName = fromMaybe [] $ do-#if MIN_VERSION_ghc(9,2,0)- Nothing-#else- -- Find the module the target is defined in.+ -- Find the module the target is defined in. targetNameSpan <- realSpan $ getLoc targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
src/Development/IDE/Spans/Pragmas.hs view
@@ -9,8 +9,8 @@ , insertNewPragma , getFirstPragma ) where +import Control.Lens ((&), (.~)) import Data.Bits (Bits (setBit))-import Data.Function ((&)) import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Text (Text, pack)@@ -18,17 +18,18 @@ import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) 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.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 getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo-getNextPragmaInfo dynFlags sourceText =- if | Just sourceText <- sourceText+getNextPragmaInfo dynFlags mbSourceText =+ if | Just sourceText <- mbSourceText , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText) , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer -> case parserState of@@ -46,7 +47,7 @@ showExtension ext = pack (show ext) insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit-insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" } :: LSP.TextEdit+insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins & L.newText .~ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" :: LSP.TextEdit insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" where pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0@@ -98,8 +99,8 @@ -- need to merge tokens that are deleted/inserted into one TextEdit each -- to work around some weird TextEdits applied in reversed order issue updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits-updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits- | Just prevLineSplitTextEdits <- prevLineSplitTextEdits+updateLineSplitTextEdits tokenRange tokenString mbPrevLineSplitTextEdits+ | Just prevLineSplitTextEdits <- mbPrevLineSplitTextEdits , let LineSplitTextEdits { lineSplitInsertTextEdit = prevInsertTextEdit , lineSplitDeleteTextEdit = prevDeleteTextEdit } = prevLineSplitTextEdits@@ -290,8 +291,8 @@ | otherwise = prevParserState where hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool- hasDeleteStartedOnSameLine line lineSplitTextEdits- | Just lineSplitTextEdits <- lineSplitTextEdits+ hasDeleteStartedOnSameLine line mbLineSplitTextEdits+ | Just lineSplitTextEdits <- mbLineSplitTextEdits , let LineSplitTextEdits{ lineSplitDeleteTextEdit } = lineSplitTextEdits , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit , let LSP.Range _ deleteEndPosition = deleteRange
src/Development/IDE/Types/Exports.hs view
@@ -23,21 +23,18 @@ import Control.DeepSeq (NFData (..), force, ($!!)) import Control.Monad-import Data.Bifunctor (Bifunctor (second)) import Data.Char (isUpper) import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap, elems)-import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set-import Data.List (foldl', isSuffixOf)+import Data.List (isSuffixOf) import Data.Text (Text, uncons) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans ()-import Development.IDE.GHC.Util import GHC.Generics (Generic)-import HieDb+import HieDb hiding (withHieDb)+import Prelude hiding (mod) data ExportsMap = ExportsMap@@ -46,7 +43,7 @@ } instance NFData ExportsMap where- rnf (ExportsMap a b) = foldOccEnv (\a b -> rnf a `seq` b) (seqEltsUFM rnf b) a+ rnf (ExportsMap a b) = foldOccEnv (\c d -> rnf c `seq` d) (seqEltsUFM rnf b) a instance Show ExportsMap where show (ExportsMap occs mods) =@@ -63,13 +60,13 @@ updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap updateExportsMap old new = ExportsMap { getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased- , getModuleExportsMap = (getModuleExportsMap old) `plusUFM` (getModuleExportsMap new) -- plusUFM is right biased+ , getModuleExportsMap = getModuleExportsMap old `plusUFM` getModuleExportsMap new -- plusUFM is right biased } where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq) | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)] size :: ExportsMap -> Int-size = sum . map (Set.size) . nonDetOccEnvElts . getExportsMap+size = sum . map Set.size . nonDetOccEnvElts . getExportsMap mkVarOrDataOcc :: Text -> OccName mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t@@ -144,8 +141,8 @@ mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent- = [ IdentInfo (nameOccName n) (Just $! nameOccName parent) mod- | n <- nn ++ map flSelector flds+ = [ IdentInfo (nameOccName name) (Just $! nameOccName parent) mod+ | name <- nn ++ map flSelector flds ] ++ [ IdentInfo (nameOccName n) Nothing mod] @@ -162,7 +159,7 @@ where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace- concatMap (getModDetails) (mi_exports modIFace)+ concatMap getModDetails (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do@@ -202,7 +199,7 @@ | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where- f id@IdentInfo {..} = (name, mn, Set.singleton id)+ f identInfo@IdentInfo {..} = (name, mn, Set.singleton identInfo) identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo)
src/Development/IDE/Types/HscEnvEq.hs view
@@ -22,7 +22,7 @@ import qualified Data.Set as Set import Data.Unique (Unique) import qualified Data.Unique as Unique-import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat hiding (newUnique) import qualified Development.IDE.GHC.Compat.Util as Maybes import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig)
src/Development/IDE/Types/Location.hs view
@@ -31,18 +31,22 @@ import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String+import Language.LSP.Protocol.Types (Location (..), Position (..),+ Range (..))+import qualified Language.LSP.Protocol.Types as LSP+import Text.ParserCombinators.ReadP as ReadP +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]++#if !MIN_VERSION_ghc(9,0,0)+import FastString+import SrcLoc as GHC+#endif+ #if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString import GHC.Types.SrcLoc as GHC-#else-import FastString-import SrcLoc as GHC #endif-import Language.LSP.Protocol.Types (Location (..), Position (..),- Range (..))-import qualified Language.LSP.Protocol.Types as LSP-import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "."
src/Development/IDE/Types/Options.hs view
@@ -2,8 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..)@@ -19,6 +18,7 @@ , OptHaddockParse(..) , ProgressReportingStyle(..) ) where+ import Control.Lens import qualified Data.Text as T import Data.Typeable@@ -30,6 +30,7 @@ import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Types as LSP+ data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
src/Generics/SYB/GHC.hs view
@@ -31,7 +31,7 @@ SrcSpan -> GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case- (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast)+ (L srcSpan ast :: Located ast) -> Just (dst `isSubspanOf` srcSpan, ast) -- | Lift a function that replaces a value with several values into a generic
test/exe/AsyncTests.hs view
@@ -35,7 +35,7 @@ , "foo = id" ] void waitForDiagnostics- codeLenses <- getCodeLenses doc+ codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] , testSession "request" $ do@@ -47,7 +47,7 @@ , "foo = id" ] void waitForDiagnostics- codeLenses <- getCodeLenses doc+ codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] ]
test/exe/ClientSettingsTests.hs view
@@ -4,8 +4,9 @@ import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON)-import qualified Data.Aeson as A+import Data.Default import qualified Data.Text as T+import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),@@ -19,11 +20,11 @@ tests :: TestTree tests = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do+ setIgnoringLogNotifications False void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone- sendNotification SMethod_WorkspaceDidChangeConfiguration- (DidChangeConfigurationParams (toJSON (mempty :: A.Object)))+ setConfigSection "haskell" $ toJSON (def :: Config) skipManyTill anyMessage restartingBuildSession ]
test/exe/CodeLensTests.hs view
@@ -3,10 +3,13 @@ module CodeLensTests (tests) where import Control.Applicative.Combinators+import Control.Lens ((^.))+import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T+import Data.Tuple.Extra import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message@@ -16,9 +19,6 @@ SemanticTokensEdit (..), mkRange) import Language.LSP.Test--- import Test.QuickCheck.Instances ()-import Control.Lens ((^.))-import Data.Tuple.Extra import Test.Tasty import Test.Tasty.HUnit import TestUtils@@ -45,14 +45,19 @@ T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others- createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]]- sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do+ createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]+ sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others- sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode+ setConfigSection "haskell" (createConfig mode) doc <- createDoc "Sigs.hs" "haskell" originalCode- waitForProgressDone- codeLenses <- getCodeLenses doc+ -- Because the diagnostics mode is really relying only on diagnostics now+ -- to generate the code lens we need to make sure we wait till the file+ -- is parsed before asking for codelenses, otherwise we will get nothing.+ if waitForDiags+ then void waitForDiagnostics+ else waitForProgressDone+ codeLenses <- getAndResolveCodeLenses doc if not $ null $ snd def then do liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses@@ -84,15 +89,16 @@ , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")+ , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool") ] in testGroup "add signature"- [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]- , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)+ [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases]+ , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) , testGroup "diagnostics mode works"- [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []- , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []+ [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []+ , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] , testSession "keep stale lens" $ do let content = T.unlines@@ -112,3 +118,5 @@ listOfChar :: T.Text listOfChar | ghcVersion >= GHC90 = "String" | otherwise = "[Char]"++
test/exe/InitializeResponseTests.hs view
@@ -49,7 +49,7 @@ , chk " doc symbol" _documentSymbolProvider (Just $ InL True) , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) , chk " code action" _codeActionProvider (Just $ InL False)- , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False))+ , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" _documentRangeFormattingProvider (Just $ InL False)
test/exe/TestUtils.hs view
@@ -7,8 +7,8 @@ import Control.Applicative.Combinators import Control.Concurrent.Async-import Control.Exception (bracket_, finally)-import Control.Lens ((.~))+import Control.Exception (bracket_, finally, throw)+import Control.Lens ((.~), (^.)) import qualified Control.Lens as Lens import qualified Control.Lens.Extras as Lens import Control.Monad@@ -47,6 +47,8 @@ import Test.Tasty.HUnit import LogType++import Data.Traversable (for) -- | Wait for the next progress begin step waitForProgressBegin :: Session ()
test/src/Development/IDE/Test.hs view
@@ -50,7 +50,7 @@ WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic-import GHC.TypeLits ( symbolVal )+import GHC.TypeLits (symbolVal) import Ide.Plugin.Config (CheckParents, checkProject) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message@@ -241,10 +241,7 @@ _ -> Nothing configureCheckProject :: Bool -> Session ()-configureCheckProject overrideCheckProject =- sendNotification SMethod_WorkspaceDidChangeConfiguration- (DidChangeConfigurationParams $ toJSON- def{checkProject = overrideCheckProject})+configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject}) -- | Pattern match a message from ghcide indicating that a file has been indexed isReferenceReady :: FilePath -> Session ()