diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,8 +3,8 @@ * Progress reporting improvements (#1784) - Pepe Iborra * Unify session loading using implicit-hie (#1783) - fendor * Fix remove constraint (#1578) - Kostas Dermentzis -* Fix wrong extend import while type constuctor and data constructor have the same name (#1775) - Lei Zhu -* Imporve vscode extension schema generation (#1742) - Potato Hatsue +* Fix wrong extend import while type constructor and data constructor have the same name (#1775) - Lei Zhu +* Improve vscode extension schema generation (#1742) - Potato Hatsue * Add hls-graph abstracting over shake (#1748) - Neil Mitchell * Tease apart the custom SYB from ExactPrint (#1746) - Sandy Maguire * fix class method completion (#1741) - Lei Zhu diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -98,25 +98,7 @@ ### Optimal project setup -`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. - -### Configuration - -`ghcide` accepts the following lsp configuration options: - -```typescript -{ - // When to check the dependents of a module - // AlwaysCheck means retypechecking them on every change - // CheckOnSave means dependent/parent modules will only be checked when you save - // "CheckOnSaveAndClose" by default - checkParents : "NeverCheck" | "CheckOnClose" | "CheckOnSaveAndClose" | "AlwaysCheck" | , - // Whether to check the entire project on initial load - // true by default - checkProject : boolean - -} -``` +`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.8, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. ### Using with VS Code diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -121,8 +121,8 @@ let arguments = if argsTesting - then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger - else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDEMain.argsProjectRoot = Just argsCwd @@ -144,7 +144,6 @@ let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader in defOptions { optShakeProfiling = argsShakeProfiling - , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling , optCheckParents = pure $ checkParents config , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.8.0.0 +version: 1.9.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 +tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.5 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -62,16 +62,15 @@ focus, ghc-trace-events, Glob, - haddock-library >= 1.8 && < 1.11, + haddock-library >= 1.8 && < 1.12, hashable, hie-compat ^>= 0.3.0.0, - hls-plugin-api ^>= 1.5, + hls-plugin-api ^>= 1.6, lens, list-t, hiedb == 0.4.2.*, lsp-types ^>= 1.6.0.0, lsp ^>= 1.6.0.0 , - monoid-subclasses, mtl, optparse-applicative, parallel, @@ -81,7 +80,7 @@ regex-tdfa >= 1.3.1.0, text-rope, safe-exceptions, - hls-graph ^>= 1.8, + hls-graph ^>= 1.9, sorted-list, sqlite-simple, stm, @@ -96,16 +95,20 @@ Diff ^>=0.4.0, vector, opentelemetry >=0.6.1, - heapsize ==0.3.*, unliftio >= 0.2.6, unliftio-core, ghc-boot-th, ghc-boot, - ghc >= 8.6, + ghc >= 8.10, ghc-check >=0.5.0.8, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios ^>= 0.11.0, + -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change. + -- https://github.com/Avi-D-coder/implicit-hie/issues/50 + -- to make sure ghcide behaves in a desirable way, we put implicit-hie + -- fake dependency here. + implicit-hie < 0.1.3, implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, base16-bytestring >=0.1.1 && <1.1 if os(windows) @@ -226,9 +229,8 @@ if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE - if impl(ghc < 8.10) - exposed-modules: - Development.IDE.GHC.Compat.CPP + if impl(ghc >= 9) + ghc-options: -Wunused-packages if flag(ekg) build-depends: @@ -271,28 +273,15 @@ "-with-rtsopts=-I0 -A128M -T" main-is: Main.hs build-depends: - hiedb, - aeson, base == 4.*, data-default, - directory, extra, - filepath, gitrev, - safe-exceptions, - ghc, - hashable, lsp, lsp-types, - heapsize, - hie-bios, hls-plugin-api, ghcide, - lens, optparse-applicative, - hls-graph, - text, - unordered-containers, other-modules: Arguments Paths_ghcide @@ -322,7 +311,10 @@ ekg-wai, ekg-core, cpp-options: -DMONITORING_EKG + if impl(ghc >= 9) + ghc-options: -Wunused-packages + test-suite ghcide-tests type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -372,12 +364,14 @@ text, text-rope, unordered-containers, - if (impl(ghc >= 8.6) && impl(ghc < 9.2)) + if impl(ghc < 9.2) build-depends: record-dot-preprocessor, record-hasfield if impl(ghc < 9.3) build-depends: ghc-typelits-knownnat + if impl(ghc >= 9) + ghc-options: -Wunused-packages hs-source-dirs: test/cabal test/exe test/src ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -67,15 +67,16 @@ import Development.IDE.Types.Logger (Pretty (pretty), Priority (Debug, Error, Info, Warning), Recorder, WithPriority, - logWith, nest, vcat, - viaShow, (<+>), - toCologActionWithPrio, cmapWithPrio) + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios -import qualified HIE.Bios.Types as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) +import qualified HIE.Bios.Types as HieBios import Hie.Implicit.Cradle (loadImplicitHieCradle) import Language.LSP.Server import Language.LSP.Types @@ -90,6 +91,8 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) import Control.Concurrent.STM.TQueue +import Control.DeepSeq +import Control.Exception (evaluate) import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) @@ -103,9 +106,6 @@ import HieDb.Utils import qualified System.Random as Random import System.Random (RandomGen) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Exception (evaluate) -import Control.DeepSeq data Log = LogSettingInitialDynFlags @@ -362,7 +362,7 @@ withHieDb fp $ \writedb -> do -- the type signature is necessary to avoid concretizing the tyvar - -- e.g. `withWriteDbRetrable initConn` without type signature will + -- e.g. `withWriteDbRetryable initConn` without type signature will -- instantiate tyvar `a` to `()` let withWriteDbRetryable :: WithHieDb withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -17,7 +17,8 @@ isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) import Development.IDE.Core.Rules as X (getClientConfigAction, - getParsedModule) + getParsedModule, + usePropertyAction) import Development.IDE.Core.RuleTypes as X import Development.IDE.Core.Service as X (runAction) import Development.IDE.Core.Shake as X (FastResult (..), @@ -31,7 +32,7 @@ defineEarlyCutoff, defineNoDiagnostics, getClientConfig, - getPluginConfig, + getPluginConfigAction, ideLogger, runIdeAction, shakeExtras, use, diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -104,10 +104,6 @@ import System.IO.Extra (fixIO, newTempFileWithin) import Unsafe.Coerce -#if !MIN_VERSION_ghc(8,10,0) -import ErrUtils -#endif - #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice @@ -162,10 +158,9 @@ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo -data TypecheckHelpers +newtype TypecheckHelpers = TypecheckHelpers - { getLinkablesToKeep :: !(IO (ModuleEnv UTCTime)) - , getLinkables :: !([NormalizedFilePath] -> IO [LinkableResult]) + { getLinkables :: ([NormalizedFilePath] -> IO [LinkableResult]) -- ^ hls-graph action to get linkables for files } typecheckModule :: IdeDefer @@ -176,11 +171,11 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do let modSummary = pm_mod_summary pm dflags = ms_hspp_opts modSummary - mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" + initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" (initPlugins hsc modSummary) - case mmodSummary' of + case initialized of Left errs -> return (errs, Nothing) - Right modSummary' -> do + Right (modSummary', hsc) -> do (warnings, etcm) <- withWarnings "typecheck" $ \tweak -> let session = tweak (hscSetFlags dflags hsc) @@ -191,10 +186,10 @@ tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings - deferedError = any fst diags + deferredError = any fst diags case etcm of Left errs -> return (map snd diags ++ errs, Nothing) - Right tcm -> return (map snd diags, Just $ tcm{tmrDeferedError = deferedError}) + Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id @@ -308,7 +303,7 @@ mods_transitive = getTransitiveMods hsc_env needed_mods -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same - mods_transitive_list = + mods_transitive_list = #if MIN_VERSION_ghc(9,3,0) mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive #else @@ -331,11 +326,6 @@ ] ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env - -- Essential to do this here after we load the linkables - ; keep_lbls <- getLinkablesToKeep - - ; unload hsc_env' $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls - #if MIN_VERSION_ghc(9,3,0) {- load it -} ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos @@ -362,7 +352,7 @@ #endif -- Compute the transitive set of linkables required - getTransitiveMods hsc_env needed_mods + getTransitiveMods hsc_env needed_mods #if MIN_VERSION_ghc(9,3,0) = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] @@ -437,6 +427,15 @@ tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) + +-- Note [Clearing mi_globals after generating an iface] +-- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode +-- interpreter. +-- However, this field is expensive in terms of heap usage, and we don't use it in HLS +-- anywhere. So we zero it out. +-- The field is not serialized or deserialised from disk, so we don't need to remove it +-- while reading an iface from disk, only if we just generated an iface in memory + mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session @@ -444,7 +443,8 @@ tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv - iface <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv + iface' <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv + let iface = iface' { mi_globals = Nothing } -- See Note [Clearing mi_globals after generating an iface] pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing mkHiFileResultCompile @@ -477,17 +477,16 @@ #endif simplified_guts - final_iface <- mkFullIface session partial_iface Nothing + final_iface' <- mkFullIface session partial_iface Nothing #if MIN_VERSION_ghc(9,4,2) Nothing #endif -#elif MIN_VERSION_ghc(8,10,0) - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface <- mkFullIface session partial_iface #else - (final_iface,_) <- mkIface session Nothing details simplified_guts + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface' <- mkFullIface session partial_iface #endif + let final_iface = final_iface' {mi_globals = Nothing} -- See Note [Clearing mi_globals after generating an iface] -- Write the core file now core_file <- case mguts of @@ -500,7 +499,7 @@ writeBinCoreFile fp core_file -- We want to drop references to guts and read in a serialized, compact version -- of the core file from disk (as it is deserialised lazily) - -- This is because we don't want to keep the guts in memeory for every file in + -- This is because we don't want to keep the guts in memory for every file in -- the project as it becomes prohibitively expensive -- 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 @@ -509,7 +508,7 @@ pure $ assert (core_hash1 == core_hash2) $ Just (core_file, fingerprintToBS core_hash2) - -- Verify core file by rountrip testing and comparison + -- Verify core file by roundtrip testing and comparison IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se case core_file of Just (core, _) | optVerifyCoreFile -> do @@ -561,7 +560,7 @@ when (not $ null diffs) $ - panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds'])) + panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds'])) _ -> pure () pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) @@ -575,11 +574,6 @@ . (("Error during " ++ T.unpack source) ++) . show @SomeException ] -initPlugins :: HscEnv -> ModSummary -> IO ModSummary -initPlugins session modSummary = do - session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) - return modSummary{ms_hspp_opts = hsc_dflags session1} - -- | Whether we should run the -O0 simplifier when generating core. -- -- This is required for template Haskell to work but we disable this in DAML. @@ -637,11 +631,7 @@ #else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts #endif -#if MIN_VERSION_ghc(8,10,0) (ms_location summary) -#else - summary -#endif fp obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) #if MIN_VERSION_ghc(9,3,0) @@ -670,11 +660,7 @@ -- TODO: maybe settings ms_hspp_opts is unnecessary? summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session guts -#if MIN_VERSION_ghc(8,10,0) (ms_location summary') -#else - summary' -#endif let unlinked = BCOs bytecode sptEntries let linkable = LM time (ms_mod summary) [unlinked] pure (map snd warnings, linkable) @@ -739,9 +725,7 @@ , Opt_WarnUnusedMatches , Opt_WarnUnusedTypePatterns , Opt_WarnUnusedForalls -#if MIN_VERSION_ghc(8,10,0) , Opt_WarnUnusedRecordWildcards -#endif , Opt_WarnInaccessibleCode , Opt_WarnWarningsDeprecations ] @@ -789,7 +773,7 @@ -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) + let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm #if MIN_VERSION_ghc(9,0,1) ts = tmrTypechecked tcm :: TcGblEnv @@ -817,8 +801,8 @@ #endif #endif -spliceExpresions :: Splices -> [LHsExpr GhcTc] -spliceExpresions Splices{..} = +spliceExpressions :: Splices -> [LHsExpr GhcTc] +spliceExpressions Splices{..} = DL.toList $ mconcat [ DL.fromList $ map fst exprSplices , DL.fromList $ map fst patSplices @@ -828,7 +812,7 @@ ] -- | In addition to indexing the `.hie` file, this function is responsible for --- maintaining the 'IndexQueue' state and notfiying the user about indexing +-- maintaining the 'IndexQueue' state and notifying the user about indexing -- progress. -- -- We maintain a record of all pending index operations in the 'indexPending' @@ -1013,7 +997,7 @@ -> HscEnv loadModulesHome mod_infos e = #if MIN_VERSION_ghc(9,3,0) - hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) + hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) #else let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] in e { hsc_HPT = new_modules @@ -1117,8 +1101,11 @@ -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do - (contents, opts, dflags) <- preprocessor env fp contents + (contents, opts, env, src_hash) <- preprocessor env fp contents + + let dflags = hsc_dflags env + -- The warns will hopefully be reported when we actually parse the module (_warns, L main_loc hsmod) <- parseHeader dflags fp contents @@ -1166,9 +1153,6 @@ liftIO $ evaluate $ rnf srcImports liftIO $ evaluate $ rnf textualImports -#if MIN_VERSION_ghc (9,3,0) - !src_hash <- liftIO $ fingerprintFromStringBuffer contents -#endif modLoc <- liftIO $ if mod == mAIN_NAME -- specially in tests it's common to have lots of nameless modules @@ -1176,14 +1160,12 @@ then mkHomeModLocation dflags (pathToModuleName fp) fp else mkHomeModLocation dflags mod fp - let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod + let modl = mkHomeModule (hscHomeUnit env) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - msrModSummary = + msrModSummary2 = ModSummary { ms_mod = modl -#if MIN_VERSION_ghc(8,8,0) , ms_hie_date = Nothing -#endif #if MIN_VERSION_ghc(9,3,0) , ms_dyn_obj_date = Nothing , ms_ghc_prim_import = ghc_prim_import @@ -1205,7 +1187,8 @@ , ms_textual_imps = textualImports } - msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2 + (msrModSummary, msrHscEnv) <- liftIO $ initPlugins env msrModSummary2 return ModSummaryResult{..} where -- Compute a fingerprint from the contents of `ModSummary`, @@ -1246,7 +1229,7 @@ PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags POk pst rdr_module -> do - let (warns, errs) = getMessages' pst dflags + let (warns, errs) = renderMessages $ getPsMessages pst dflags -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser @@ -1281,9 +1264,18 @@ POk pst rdr_module -> let hpm_annotations = mkApiAnns pst - (warns, errs) = getMessages' pst dflags + psMessages = getPsMessages pst dflags in do + let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module + + unless (null errs) $ + throwE $ diagFromStrings "parser" DsError errs + + let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns + (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages + let (warns, errs) = renderMessages msgs + -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser -- distinguishes between fatal and non-fatal @@ -1296,15 +1288,7 @@ unless (null errs) $ throwE $ diagFromErrMsgs "parser" dflags errs - -- Ok, we got here. It's safe to continue. - let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module - unless (null errs) $ - throwE $ diagFromStrings "parser" DsError errs - - let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed - -- To get the list of extra source files, we take the list -- that the parser gave us, -- - eliminate files beginning with '<'. gcc likes to use @@ -1427,7 +1411,7 @@ ml_core_file :: ModLocation -> FilePath ml_core_file ml = ml_hi_file ml <.> "core" --- | Retuns an up-to-date module interface, regenerating if needed. +-- | Returns an up-to-date module interface, regenerating if needed. -- Assumes file exists. -- Requires the 'HscEnv' to be set up with dependencies -- See Note [Recompilation avoidance in the presence of TH] @@ -1455,7 +1439,7 @@ -- 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 - Nothing -> SourceModified -- desitination file doesn't exist, assume modified source + Nothing -> SourceModified -- destination file doesn't exist, assume modified source Just dest_version | source_version <= dest_version -> SourceUnmodified | otherwise -> SourceModified @@ -1479,24 +1463,12 @@ case (mb_checked_iface, recomp_iface_reqd) of (Just iface, UpToDate) -> do - -- If we have an old value, just return it - case old_value of - Just (old_hir, _) - | isNothing linkableNeeded || isJust (hirCoreFp old_hir) - -> do - -- Peform the fine grained recompilation check for TH - maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) (hirRuntimeModules old_hir) - case maybe_recomp of - Just msg -> do_regenerate msg - Nothing -> return ([], Just old_hir) - -- Otherwise use the value from disk, provided the core file is up to date if required - _ -> do details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface -- parse the runtime dependencies from the annotations let runtime_deps | not (mi_used_th iface) = emptyModuleEnv | otherwise = parseRuntimeDeps (md_anns details) - -- Peform the fine grained recompilation check for TH + -- Perform the fine grained recompilation check for TH maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps case maybe_recomp of Just msg -> do_regenerate msg @@ -1577,7 +1549,7 @@ mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails mkDetailsFromIface session iface = do fixIO $ \details -> do - let hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session + let !hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session initIfaceLoad hsc' (typecheckIface iface) coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts @@ -1616,15 +1588,14 @@ --- and leads to fun errors like "Cannot continue after interface file error". getDocsBatch :: HscEnv - -> Module -- ^ a moudle where the names are in scope -> [Name] #if MIN_VERSION_ghc(9,3,0) -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] #else -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] #endif -getDocsBatch hsc_env _mod _names = do - (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name -> +getDocsBatch hsc_env _names = do + res <- initIfaceLoad hsc_env $ forM _names $ \name -> case nameModule_maybe name of Nothing -> return (Left $ NameHasNoModule name) Just mod -> do @@ -1639,7 +1610,7 @@ , mi_decl_docs = DeclDocMap dmap , mi_arg_docs = ArgDocMap amap #endif - } <- loadModuleInterface "getModuleInterface" mod + } <- loadSysInterface (text "getModuleInterface") mod #if MIN_VERSION_ghc(9,3,0) if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap #else @@ -1660,44 +1631,44 @@ #else Map.findWithDefault mempty name amap)) #endif - case res of - Just x -> return $ map (first $ T.unpack . printOutputable) - $ x - Nothing -> throwErrors -#if MIN_VERSION_ghc(9,3,0) - $ fmap GhcTcRnMessage msgs -#elif MIN_VERSION_ghc(9,2,0) - $ Error.getErrorMessages msgs -#else - $ snd msgs -#endif + return $ map (first $ T.unpack . printOutputable) + $ res where - throwErrors = liftIO . throwIO . mkSrcErr compiled n = -- TODO: Find a more direct indicator. case nameSrcLoc n of RealSrcLoc {} -> False UnhelpfulLoc {} -> True -fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 - -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds --- and leads to fun errors like "Cannot continue after interface file error". lookupName :: HscEnv - -> Module -- ^ A module where the Names are in scope -> Name -> IO (Maybe TyThing) -lookupName hsc_env mod name = do - (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - return res - +lookupName _ name + | Nothing <- nameModule_maybe name = pure Nothing +lookupName hsc_env name = handle $ do +#if MIN_VERSION_ghc(9,2,0) + mb_thing <- liftIO $ lookupType hsc_env name +#else + eps <- liftIO $ readIORef (hsc_EPS hsc_env) + let mb_thing = lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +#endif + case mb_thing of + x@(Just _) -> return x + Nothing + | x@(Just thing) <- wiredInNameTyThing_maybe name + -> do when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + return x + | otherwise -> do + res <- initIfaceLoad hsc_env $ importDecl name + case res of + Util.Succeeded x -> return (Just x) + _ -> return Nothing + where + handle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing pathToModuleName :: FilePath -> ModuleName pathToModuleName = mkModuleName . map rep diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -55,7 +55,6 @@ import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashSet as HSet import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) @@ -256,7 +255,7 @@ atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip HSet.insert) x keys + foldl' (flip insertKeySet) x keys void $ restartShakeSession (shakeExtras state) vfs reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -1,6 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Development.IDE.Core.Preprocessor ( preprocessor @@ -8,6 +8,7 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util +import qualified Development.IDE.GHC.Util as Util import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans () @@ -30,36 +31,40 @@ import System.FilePath import System.IO.Extra #if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Logger (LogFlags(..)) -import GHC.Utils.Outputable (renderWithContext) +import GHC.Utils.Logger (LogFlags (..)) +import GHC.Utils.Outputable (renderWithContext) #endif -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags) -preprocessor env0 filename mbContents = do +preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint) +preprocessor env filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do - newcontent <- liftIO $ runLhs env0 filename mbContents + newcontent <- liftIO $ runLhs env filename mbContents return (False, newcontent) else do contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents let isOnDisk = isNothing mbContents return (isOnDisk, contents) + -- Compute the source hash before the preprocessor because this is + -- how GHC does it. + !src_hash <- liftIO $ Util.fingerprintFromStringBuffer contents + -- Perform cpp - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents - let env1 = hscSetFlags dflags env0 - let logger = hsc_logger env1 - (isOnDisk, contents, opts, dflags) <- + (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents + let dflags = hsc_dflags env + let logger = hsc_logger env + (isOnDisk, contents, opts, env) <- if not $ xopt LangExt.Cpp dflags then - return (isOnDisk, contents, opts, dflags) + return (isOnDisk, contents, opts, env) else do cppLogs <- liftIO $ newIORef [] let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger contents <- ExceptT - $ (Right <$> (runCpp (putLogHook newLogger env1) filename + $ (Right <$> (runCpp (putLogHook newLogger env) filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: Util.GhcException) -> do @@ -68,16 +73,16 @@ [] -> throw e diags -> return $ Left diags ) - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents - return (False, contents, opts, dflags) + (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents + return (False, contents, opts, env) -- Perform preprocessor if not $ gopt Opt_Pp dflags then - return (contents, opts, dflags) + return (contents, opts, env, src_hash) else do - contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents - return (contents, opts, dflags) + 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) where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do @@ -137,12 +142,12 @@ -- | This reads the pragma information directly from the provided buffer. -parsePragmasIntoDynFlags +parsePragmasIntoHscEnv :: HscEnv -> FilePath -> Util.StringBuffer - -> IO (Either [FileDiagnostic] ([String], DynFlags)) -parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do + -> IO (Either [FileDiagnostic] ([String], HscEnv)) +parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do #if MIN_VERSION_ghc(9,3,0) let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp #else @@ -154,7 +159,7 @@ (dflags, _, _) <- parseDynamicFilePragma dflags0 opts hsc_env' <- initializePlugins (hscSetFlags dflags env) - return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env')) + return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env') where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -155,7 +155,7 @@ , tmrTypechecked :: TcGblEnv , tmrTopLevelSplices :: Splices -- ^ Typechecked splice information - , tmrDeferedError :: !Bool + , tmrDeferredError :: !Bool -- ^ Did we defer any type errors for this module? , tmrRuntimeModules :: !(ModuleEnv ByteString) -- ^ Which modules did we need at runtime while compiling this file? @@ -357,6 +357,12 @@ { msrModSummary :: !ModSummary , msrImports :: [LImportDecl GhcPs] , msrFingerprint :: !Fingerprint + , msrHscEnv :: !HscEnv + -- ^ HscEnv for this particular ModSummary. + -- Contains initialised plugins, parsed options, etc... + -- + -- Implicit assumption: DynFlags in 'msrModSummary' are the same as + -- the DynFlags in 'msrHscEnv'. } instance Show ModSummaryResult where diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -62,9 +62,6 @@ DisplayTHWarning(..), ) where -#if !MIN_VERSION_ghc(8,8,0) -import Control.Applicative (liftA2) -#endif import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.DeepSeq @@ -147,7 +144,7 @@ useProperty) import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), - PluginId) + PluginId, PluginDescriptor (pluginId), IdePlugins (IdePlugins)) import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) @@ -157,7 +154,7 @@ import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Control.Monad.IO.Unlift #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Module.Graph @@ -256,9 +253,7 @@ getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do - ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file - sess <- use_ GhcSession file - let hsc = hscEnv sess + ModSummaryResult{msrModSummary = ms', msrHscEnv = hsc} <- use_ GetModSummary file opt <- getIdeOptions modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } @@ -330,8 +325,7 @@ -- The parse diagnostics are owned by the GetParsedModule rule -- For this reason, this rule does not produce any diagnostics defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do - ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file - sess <- use_ GhcSession file + ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file opt <- getIdeOptions let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms @@ -339,12 +333,12 @@ 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 (hscEnv sess) opt file ms + liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do opts <- getIdeOptions - cfg <- getClientConfigAction def + cfg <- getClientConfigAction pure $ f $ optModifyDynFlags opts cfg @@ -697,8 +691,7 @@ unlift <- askUnliftIO let dets = TypecheckHelpers - { getLinkablesToKeep = unliftIO unlift $ currentLinkables - , getLinkables = unliftIO unlift . uses_ GetLinkable + { getLinkables = unliftIO unlift . uses_ GetLinkable } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -785,7 +778,7 @@ let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces #if MIN_VERSION_ghc(9,3,0) -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph - -- also points to all the direct descendents of the current module. To get the keys for the descendents + -- also points to all the direct descendants of the current module. To get the keys for the descendants -- we must get their `ModSummary`s !final_deps <- do dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps @@ -953,7 +946,7 @@ hiDiags <- case hiFile of Just hiFile | OnDisk <- status - , not (tmrDeferedError tmr) -> liftIO $ writeHiFile se hsc hiFile + , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile _ -> pure [] return (fp, (diags++hiDiags, hiFile)) NotFOI -> do @@ -1025,9 +1018,9 @@ wDiags <- forM masts $ \asts -> liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source - -- We don't write the `.hi` file if there are defered errors, since we won't get + -- 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 $ tmrDeferedError tmr + hiDiags <- if not $ tmrDeferredError tmr then liftIO $ writeHiFile se hsc hiFile else pure [] @@ -1060,16 +1053,6 @@ settings <- clientSettings <$> getIdeConfiguration return (LBS.toStrict $ B.encode $ hash settings, settings) --- | Returns the client configurarion stored in the IdeState. --- You can use this function to access it from shake Rules -getClientConfigAction :: Config -- ^ default value - -> Action Config -getClientConfigAction defValue = do - mbVal <- unhashed <$> useNoFile_ GetClientSettings - case A.parse (parseConfig defValue) <$> mbVal of - Just (Success c) -> return c - _ -> return defValue - usePropertyAction :: (HasProperty s k t r) => KeyNameProxy s -> @@ -1077,8 +1060,7 @@ Properties r -> Action (ToHsType t) usePropertyAction kn plId p = do - config <- getClientConfigAction def - let pluginConfig = configForPlugin config plId + pluginConfig <- getPluginConfigAction plId pure $ useProperty kn p $ plcConfig pluginConfig -- --------------------------------------------------------------------- @@ -1119,10 +1101,23 @@ Just obj_t | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time") - -- Record the linkable so we know not to unload it + -- Record the linkable so we know not to unload it, and unload old versions whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction - liftIO $ void $ modifyVar' compiledLinkables $ \old -> extendModuleEnv old mod time + liftIO $ modifyVar compiledLinkables $ \old -> do + let !to_keep = extendModuleEnv old mod time + --We need to unload old linkables before we can load in new linkables. However, + --the unload function in the GHC API takes a list of linkables to keep (i.e. + --not unload). Earlier we unloaded right before loading in new linkables, which + --is effectively once per splice. This can be slow as unload needs to walk over + --the list of all loaded linkables, for each splice. + -- + --Solution: now we unload old linkables right after we generate a new linkable and + --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) + return (to_keep, ()) return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -10,7 +11,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -- | A Shake implementation of the compiler service. -- @@ -53,7 +53,7 @@ getIdeOptionsIO, GlobalIdeOptions(..), HLS.getClientConfig, - getPluginConfig, + getPluginConfigAction, knownTargets, setPriority, ideLogger, @@ -77,7 +77,7 @@ garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log(..), - VFSModified(..) + VFSModified(..), getClientConfigAction ) where import Control.Concurrent.Async @@ -90,7 +90,8 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe -import Data.Aeson (toJSON) +import Data.Aeson (Result (Success), + toJSON) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) @@ -98,7 +99,7 @@ import Data.Dynamic import Data.EnumMap.Strict (EnumMap) import qualified Data.EnumMap.Strict as EM -import Data.Foldable (for_, toList) +import Data.Foldable (find, for_, toList) import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Hashable @@ -130,11 +131,11 @@ NameCacheUpdater (..), initNameCache, knownKeyNames, + mkSplitUniqSupply) #if !MIN_VERSION_ghc(9,3,0) - upNameCache, +import Development.IDE.GHC.Compat (upNameCache) #endif - mkSplitUniqSupply - ) +import qualified Data.Aeson.Types as A import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -162,7 +163,9 @@ import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId, IdePlugins) +import Ide.Types (IdePlugins (IdePlugins), + PluginDescriptor (pluginId), + PluginId) import Language.LSP.Diagnostics import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -179,7 +182,7 @@ data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) @@ -198,7 +201,7 @@ vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) - , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) + , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" @@ -257,7 +260,7 @@ -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an - -- accumlation of all previous mappings. + -- accumulation of all previous mappings. ,progress :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants @@ -280,18 +283,18 @@ ,clientCapabilities :: ClientCapabilities , withHieDb :: WithHieDb -- ^ Use only to read. , hiedbWriter :: HieDbWriter -- ^ use to write - , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent) - -- ^ Registery for functions that compute/get "stale" results for the rule + , persistentKeys :: TVar (KeyMap GetStalePersistent) + -- ^ Registry for functions that compute/get "stale" results for the rule -- (possibly from disk) , vfsVar :: TVar VFS -- ^ A snapshot of the current state of the virtual file system. Updated on shakeRestart -- VFS state is managed by LSP. However, the state according to the lsp library may be newer than the state of the current session, - -- leaving us vulnerable to suble race conditions. To avoid this, we take a snapshot of the state of the VFS on every + -- leaving us vulnerable to subtle race conditions. To avoid this, we take a snapshot of the state of the VFS on every -- restart, so that the whole session sees a single consistent view of the VFS. -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , dirtyKeys :: TVar (HashSet Key) + , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run } @@ -312,10 +315,25 @@ Just x <- getShakeExtraRules @ShakeExtras return x -getPluginConfig - :: LSP.MonadLsp Config m => PluginId -> m PluginConfig -getPluginConfig plugin = do - config <- HLS.getClientConfig +-- | Returns the client configuration, creating a build dependency. +-- You should always use this function when accessing client configuration +-- from build rules. +getClientConfigAction :: Action Config +getClientConfigAction = do + ShakeExtras{lspEnv, idePlugins} <- getShakeExtras + currentConfig <- (`LSP.runLspT` LSP.getConfig) `traverse` lspEnv + mbVal <- unhashed <$> useNoFile_ GetClientSettings + let defValue = fromMaybe def currentConfig + case A.parse (parseConfig idePlugins defValue) <$> mbVal of + Just (Success c) -> return c + _ -> return defValue + +getPluginConfigAction :: PluginId -> Action PluginConfig +getPluginConfigAction plId = do + config <- getClientConfigAction + ShakeExtras{idePlugins = IdePlugins plugins} <- getShakeExtras + let plugin = fromMaybe (error $ "Plugin not found: " <> show plId) $ + find (\p -> pluginId p == plId) plugins return $ HLS.configForPlugin config plugin -- | Register a function that will be called to get the "stale" result of a rule, possibly from disk @@ -325,7 +343,7 @@ addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules - void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) + void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where @@ -400,7 +418,7 @@ pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k - f <- MaybeT $ pure $ HMap.lookup (Key k) pmap + f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of @@ -510,7 +528,7 @@ -> STM () deleteValue ShakeExtras{dirtyKeys, state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ HSet.insert (toKey key file) + modifyTVar' dirtyKeys $ insertKeySet (toKey key file) recordDirtyKeys :: Shake.ShakeValue k @@ -519,7 +537,7 @@ -> [NormalizedFilePath] -> STM (IO ()) recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) + modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) @@ -595,7 +613,7 @@ positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty let restartShakeSession = shakeRestart recorder ideState - persistentKeys <- newTVarIO HMap.empty + persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 indexProgressToken <- newVar Nothing @@ -630,20 +648,17 @@ shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir IdeOptions - { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled - , optProgressStyle + { optProgressStyle , optCheckParents } <- getIdeOptionsIO shakeExtras - startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras - checkParents <- optCheckParents -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) - readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) + readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb @@ -666,7 +681,7 @@ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do - -- Take a snapshot of the VFS - it should be empty as we've recieved no notifications + -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" @@ -801,10 +816,10 @@ workRun restore = withSpan "Shake session" $ \otSpan -> do setTag otSpan "reason" (fromString reason) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) - whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) + whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ - restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs + restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs return $ do let exception = case res of @@ -835,7 +850,7 @@ b <- newBarrier let a' = do -- work gets reenqueued when the Shake session is restarted - -- it can happen that a work item finished just as it was reenqueud + -- it can happen that a work item finished just as it was reenqueued -- in that case, skipping the work is fine alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b unless alreadyDone $ do @@ -894,7 +909,7 @@ = atomicallyNamed "GC" $ do gotIt <- STM.focus (Focus.member <* Focus.delete) k values when gotIt $ - modifyTVar' dk (HSet.insert k) + modifyTVar' dk (insertKeySet k) return $ if gotIt then (counter+1, k:keys) else st | otherwise = pure st @@ -1072,7 +1087,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do @@ -1091,7 +1106,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () @@ -1164,7 +1179,7 @@ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file) + liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file @@ -1203,7 +1218,7 @@ -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv} current = +updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current @@ -1211,7 +1226,8 @@ 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 (T.pack $ show k) new store + update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store + current = second diagsFromRule <$> current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always @@ -1234,6 +1250,22 @@ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) return action + where + diagsFromRule :: Diagnostic -> Diagnostic + diagsFromRule c@Diagnostic{_range} + | coerce ideTesting = c + {_relatedInformation = + Just $ List [ + DiagnosticRelatedInformation + (Location + (filePathToUri $ fromNormalizedFilePath fp) + _range + ) + (T.pack $ show k) + ] + } + | otherwise = c + newtype Priority = Priority Double diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -5,9 +5,6 @@ module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction - , startProfilingTelemetry - , measureMemory - , getInstrumentCached , otTracedProvider , otSetUri , otTracedGarbageCollection @@ -17,69 +14,31 @@ ) where -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.Extra (modifyVar_, newVar, readVar, - threadDelay) -import Control.Exception (evaluate) -import Control.Exception.Safe (SomeException, catch, - generalBracket) -import Control.Monad (forM_, forever, void, when, - (>=>)) +import Control.Exception.Safe (generalBracket) import Control.Monad.Catch (ExitCase (..), MonadMask) -import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift -import Control.Monad.STM (atomically) -import Control.Seq (r0, seqList, seqTuple2, - using) import Data.ByteString (ByteString) import Data.ByteString.Char8 (pack) -import qualified Data.HashMap.Strict as HMap -import Data.IORef (modifyIORef', newIORef, - readIORef, writeIORef) import Data.String (IsString (fromString)) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (TypeRep, typeOf) import Data.Word (Word16) import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), - GhcSessionIO (GhcSessionIO)) import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger), logDebug, - logInfo) -import Development.IDE.Types.Shake (ValueWithDiagnostics (..), - Values, fromKeyType) -import Foreign.Storable (Storable (sizeOf)) -import HeapSize (recursiveSize, runHeapsize) -import Ide.PluginUtils (installSigUsr1Handler) +import Development.IDE.Types.Logger (Logger (Logger)) import Ide.Types (PluginId (..)) import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) -import qualified "list-t" ListT -import Numeric.Natural (Natural) import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, - beginSpan, endSpan, - mkValueObserver, observe, - setTag, withSpan, withSpan_) -import qualified StmContainers.Map as STM + beginSpan, endSpan, setTag, + withSpan) -#if MIN_VERSION_ghc(8,8,0) -otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a -#endif -withTrace :: (MonadMask m, MonadIO m) => - String -> ((String -> String -> m ()) -> m a) -> m a +withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do @@ -87,6 +46,7 @@ act setSpan' | otherwise = act (\_ _ -> pure ()) +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a withEventTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do @@ -156,6 +116,7 @@ (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) | otherwise = act (\_ -> return ()) +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] otTracedGarbageCollection label act | userTracingEnabled = fst <$> generalBracket @@ -169,6 +130,7 @@ (const act) | otherwise = act +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a otTracedProvider (PluginId pluginName) provider act | userTracingEnabled = do runInIO <- askRunInIO @@ -176,128 +138,4 @@ setTag sp "plugin" (encodeUtf8 pluginName) runInIO act | otherwise = act - - -startProfilingTelemetry :: Bool -> Logger -> Values -> IO () -startProfilingTelemetry allTheTime logger state = do - instrumentFor <- getInstrumentCached - - installSigUsr1Handler $ do - logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger state instrumentFor - - when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger state instrumentFor - where - seconds = 1000000 - - regularly :: Int -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> threadDelay delay) - - -performMeasurement :: - Logger -> - Values -> - (Maybe String -> IO OurValueObserver) -> - IO () -performMeasurement logger values instrumentFor = do - contents <- atomically $ ListT.toList $ STM.listT values - let keys = typeOf GhcSession - : typeOf GhcSessionDeps - -- TODO restore - : [ kty - | (k,_) <- contents - , Just (kty,_) <- [fromKeyType k] - -- do GhcSessionIO last since it closes over stateRef itself - , kty /= typeOf GhcSession - , kty /= typeOf GhcSessionDeps - , kty /= typeOf GhcSessionIO - ] - ++ [typeOf GhcSessionIO] - groupedForSharing <- evaluate (keys `using` seqList r0) - measureMemory logger [groupedForSharing] instrumentFor values - `catch` \(e::SomeException) -> - logInfo logger ("MEMORY PROFILING ERROR: " <> fromString (show e)) - - -type OurValueObserver = Int -> IO () - -getInstrumentCached :: IO (Maybe String -> IO OurValueObserver) -getInstrumentCached = do - instrumentMap <- newVar HMap.empty - mapBytesInstrument <- mkValueObserver "value map size_bytes" - - let instrumentFor k = do - mb_inst <- HMap.lookup k <$> readVar instrumentMap - case mb_inst of - Nothing -> do - instrument <- mkValueObserver (fromString (show k ++ " size_bytes")) - modifyVar_ instrumentMap (return . HMap.insert k instrument) - return $ observe instrument - Just v -> return $ observe v - return $ maybe (return $ observe mapBytesInstrument) instrumentFor - -whenNothing :: IO () -> IO (Maybe a) -> IO () -whenNothing act mb = mb >>= f - where f Nothing = act - f Just{} = return () - -measureMemory - :: Logger - -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis - -> (Maybe String -> IO OurValueObserver) - -> Values - -> IO () -measureMemory logger groups instrumentFor values = withSpan_ "Measure Memory" $ do - contents <- atomically $ ListT.toList $ STM.listT values - valuesSizeRef <- newIORef $ Just 0 - let !groupsOfGroupedValues = groupValues contents - logDebug logger "STARTING MEMORY PROFILING" - forM_ groupsOfGroupedValues $ \groupedValues -> do - keepGoing <- readIORef valuesSizeRef - whenJust keepGoing $ \_ -> - whenNothing (writeIORef valuesSizeRef Nothing) $ - repeatUntilJust 3 $ do - -- logDebug logger (fromString $ show $ map fst groupedValues) - runHeapsize 25000000 $ - forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do - acc <- liftIO $ newIORef 0 - observe <- liftIO $ instrumentFor $ Just k - mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v - size <- liftIO $ readIORef acc - let !byteSize = sizeOf (undefined :: Word) * size - setTag sp "size" (fromString (show byteSize ++ " bytes")) - () <- liftIO $ observe byteSize - liftIO $ modifyIORef' valuesSizeRef (fmap (+ byteSize)) - - mbValuesSize <- readIORef valuesSizeRef - case mbValuesSize of - Just valuesSize -> do - observe <- instrumentFor Nothing - observe valuesSize - logDebug logger "MEMORY PROFILING COMPLETED" - Nothing -> - logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" - - where - -- groupValues :: Values -> [ [(String, [Value Dynamic])] ] - groupValues contents = - let !groupedValues = - [ [ (show ty, vv) - | ty <- groupKeys - , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- contents - , kty == ty] - ] - | groupKeys <- groups - ] - -- force the spine of the nested lists - in groupedValues `using` seqList (seqList (seqTuple2 r0 (seqList r0))) - -repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a) -repeatUntilJust 0 _ = return Nothing -repeatUntilJust nattempts action = do - res <- action - case res of - Nothing -> repeatUntilJust (nattempts-1) action - Just{} -> return res diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -16,30 +16,21 @@ where import Development.IDE.GHC.Compat as Compat -import GHC -#if !MIN_VERSION_ghc(8,10,0) -import qualified Development.IDE.GHC.Compat.CPP as CPP -#else import Development.IDE.GHC.Compat.Util -#endif +import GHC #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Driver.Pipeline as Pipeline import GHC.Settings -#else -#if MIN_VERSION_ghc (8,10,0) +#elif MIN_VERSION_ghc (8,10,0) import qualified DriverPipeline as Pipeline import ToolSettings -#else -import DynFlags #endif -#endif #if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Pipeline.Execute as Pipeline +import qualified GHC.Driver.Pipeline.Execute as Pipeline #endif addOptP :: String -> DynFlags -> DynFlags -#if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) @@ -47,20 +38,12 @@ where fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -#else -addOptP opt = onSettings (onOptP (opt:)) - where - onSettings f x = x{settings = f $ settings x} - onOptP f x = x{sOpt_P = f $ sOpt_P x} -#endif doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () doCpp env raw input_fn output_fn = #if MIN_VERSION_ghc (9,2,0) Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn -#elif MIN_VERSION_ghc (8,10,0) - Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn #else - CPP.doCpp (hsc_dflags env) raw input_fn output_fn + Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn #endif diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -22,10 +22,12 @@ #else upNameCache, #endif + lookupNameCache, disableWarningsAsErrors, reLoc, reLocA, - getMessages', + getPsMessages, + renderMessages, pattern PFailedWithErrorMessages, isObjectLinkable, @@ -42,6 +44,8 @@ #endif FastStringCompat, + bytesFS, + mkFastStringByteString, nodeInfo', getNodeIds, sourceNodeInfo, @@ -52,6 +56,8 @@ mkAstNode, combineRealSrcSpans, + nonDetOccEnvElts, + isQualifiedImport, GhcVersion(..), ghcVersion, @@ -205,6 +211,7 @@ #endif #if MIN_VERSION_ghc(9,0,0) +import GHC.Data.FastString import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) @@ -223,24 +230,15 @@ 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) -#if MIN_VERSION_ghc(8,8,0) import StringBuffer (hPutStringBuffer) -#endif import qualified SysTools - -#if !MIN_VERSION_ghc(8,8,0) -import qualified EnumSet -import SrcLoc (RealLocated) - -import Foreign.ForeignPtr -import System.IO #endif -#endif import Compat.HieAst (enrichHie) import Compat.HieBin @@ -254,10 +252,6 @@ import qualified Data.Map as Map import qualified Data.Set as S -#if !MIN_VERSION_ghc(8,10,0) -import Bag (unitBag) -#endif - #if MIN_VERSION_ghc(9,2,0) import GHC.Builtin.Uniques import GHC.ByteCode.Types @@ -275,8 +269,14 @@ #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Error import GHC.Driver.Config.Stg.Pipeline +import GHC.Driver.Plugins (PsMessages (..)) #endif +#if !MIN_VERSION_ghc(9,3,0) +nonDetOccEnvElts :: OccEnv a -> [a] +nonDetOccEnvElts = occEnvElts +#endif + type ModIfaceAnnotation = Annotation #if MIN_VERSION_ghc(9,3,0) @@ -385,32 +385,13 @@ simplifyExpr df _ = GHC.simplifyExpr df #endif -#if !MIN_VERSION_ghc(8,8,0) -hPutStringBuffer :: Handle -> StringBuffer -> IO () -hPutStringBuffer hdl (StringBuffer buf len cur) - = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> - hPutBuf hdl ptr len -#endif - -#if MIN_VERSION_ghc(9,2,0) -type ErrMsg = MsgEnvelope DecoratedSDoc -#endif -#if MIN_VERSION_ghc(9,3,0) -type WarnMsg = MsgEnvelope DecoratedSDoc -#endif - -getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg) -getMessages' pst dflags = +renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) +renderMessages msgs = #if MIN_VERSION_ghc(9,3,0) - bimap (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) $ getPsMessages pst + let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs + in (renderMsgs psWarnings, renderMsgs psErrors) #else -#if MIN_VERSION_ghc(9,2,0) - bimap (fmap pprWarning) (fmap pprError) $ -#endif - getMessages pst -#if !MIN_VERSION_ghc(9,2,0) - dflags -#endif + msgs #endif #if MIN_VERSION_ghc(9,2,0) @@ -421,17 +402,10 @@ #else <- PFailed (const . fmap pprError . getErrorMessages -> msgs) #endif -#elif MIN_VERSION_ghc(8,10,0) -pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a -pattern PFailedWithErrorMessages msgs - <- PFailed (getErrorMessages -> msgs) #else pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a pattern PFailedWithErrorMessages msgs - <- ((fmap.fmap) unitBag . mkPlainErrMsgIfPFailed -> Just msgs) - -mkPlainErrMsgIfPFailed (PFailed _ pst err) = Just (\dflags -> mkPlainErrMsg dflags pst err) -mkPlainErrMsgIfPFailed _ = Nothing + <- PFailed (getErrorMessages -> msgs) #endif {-# COMPLETE POk, PFailedWithErrorMessages #-} @@ -444,14 +418,28 @@ #if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache #else + +lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) +-- Lookup up the (Module,OccName) in the NameCache +-- If you find it, return it; if not, allocate a fresh original name and extend +-- the NameCache. +-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. +-- If we need to explore its value we will load Foo.hi; but meanwhile all we +-- need is a Name for it. +lookupNameCache mod occ name_cache = + case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> (name_cache, name); + Nothing -> + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} + upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if MIN_VERSION_ghc(8,8,0) upNameCache = updNameCache -#else -upNameCache ref upd_fn - = atomicModifyIORef' ref upd_fn #endif -#endif #if !MIN_VERSION_ghc(9,0,1) type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] @@ -480,27 +468,15 @@ where f i = i{includePathsQuote = path : includePathsQuote i} setHieDir :: FilePath -> DynFlags -> DynFlags -setHieDir _f d = -#if MIN_VERSION_ghc(8,8,0) - d { hieDir = Just _f} -#else - d -#endif +setHieDir _f d = d { hieDir = Just _f} dontWriteHieFiles :: DynFlags -> DynFlags -dontWriteHieFiles d = -#if MIN_VERSION_ghc(8,8,0) - gopt_unset d Opt_WriteHie -#else - d -#endif +dontWriteHieFiles d = gopt_unset d Opt_WriteHie setUpTypedHoles ::DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy -#if MIN_VERSION_ghc(8,8,0) $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used -#endif $ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers) $ flip gopt_unset Opt_ShowProvOfHoleFits -- not used $ flip gopt_unset Opt_ShowTypeAppOfHoleFits -- not used @@ -522,30 +498,16 @@ getModuleHash :: ModIface -> Fingerprint -#if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts -#else -getModuleHash = mi_mod_hash -#endif disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = - flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] - -#if !MIN_VERSION_ghc(8,8,0) -wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_unset_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } -#endif + flip gopt_unset Opt_WarnIsError $! foldl' wopt_unset_fatal df [toEnum 0 ..] isQualifiedImport :: ImportDecl a -> Bool -#if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{} = True -#else -isQualifiedImport ImportDecl{ideclQualified} = ideclQualified -#endif isQualifiedImport _ = False @@ -606,9 +568,7 @@ #endif data GhcVersion - = GHC86 - | GHC88 - | GHC810 + = GHC810 | GHC90 | GHC92 | GHC94 @@ -626,10 +586,6 @@ ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810 -#elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0) -ghcVersion = GHC88 -#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) -ghcVersion = GHC86 #endif runUnlit :: Logger -> DynFlags -> [Option] -> IO () diff --git a/src/Development/IDE/GHC/Compat/CPP.hs b/src/Development/IDE/GHC/Compat/CPP.hs deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/CPP.hs +++ /dev/null @@ -1,204 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 --- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. --- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. - -{- HLINT ignore -} -- since copied from upstream - -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Re-export 'doCpp' for GHC < 8.10. --- --- Later versions export what we need. -module Development.IDE.GHC.Compat.CPP ( - doCpp - ) where - -import FileCleanup -import Packages -import Panic -import SysTools -#if MIN_VERSION_ghc(8,8,2) -import LlvmCodeGen (llvmVersionList) -#elif MIN_VERSION_ghc(8,8,0) -import LlvmCodeGen (LlvmVersion (..)) -#endif -import Control.Monad -import Data.List (intercalate) -import Data.Maybe -import Data.Version -import DynFlags -import Module (rtsUnitId, toInstalledUnitId) -import System.Directory -import System.FilePath -import System.Info - -import Development.IDE.GHC.Compat as Compat - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_VERSION_ghc(8,10,0) - | otherwise = SysTools.runCc Nothing -#else - | otherwise = SysTools.runCc -#endif - dflags (SysTools.Option "-E" : args) - - let target_defs = - -- NEIL: Patched to use System.Info instead of constants from CPP - [ "-D" ++ os ++ "_BUILD_OS", - "-D" ++ arch ++ "_BUILD_ARCH", - "-D" ++ os ++ "_HOST_OS", - "-D" ++ arch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of -#if MIN_VERSION_ghc(8,8,2) - Just v - | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] - | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_VERSION_ghc(8,8,0) - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] -#else - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] -#endif - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] - --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [Compat.UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x - -rtsUnit :: UnitId -rtsUnit = Module.rtsUnitId diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -36,12 +36,17 @@ maxRefHoleFits, maxValidHoleFits, setOutputFile, + lookupType, + needWiredInHomeIface, + loadWiredInHomeIface, + loadSysInterface, + importDecl, #if MIN_VERSION_ghc(8,8,0) CommandLineOption, +#endif #if !MIN_VERSION_ghc(9,2,0) staticPlugins, #endif -#endif sPgm_F, settings, gopt, @@ -78,12 +83,8 @@ -- * Interface Files IfaceExport, IfaceTyCon(..), -#if MIN_VERSION_ghc(8,10,0) ModIface, ModIface_(..), -#else - ModIface(..), -#endif HscSource(..), WhereFrom(..), loadInterface, @@ -92,12 +93,8 @@ #endif loadModuleInterface, RecompileRequired(..), -#if MIN_VERSION_ghc(8,10,0) mkPartialIface, mkFullIface, -#else - mkIface, -#endif checkOldIface, #if MIN_VERSION_ghc(9,0,0) IsBootInterface(..), @@ -140,10 +137,12 @@ ), pattern FunTy, pattern ConPatIn, + conPatDetails, + mapConPatDetail, #if !MIN_VERSION_ghc(9,2,0) Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, #endif - Development.IDE.GHC.Compat.Core.mkVisFunTys, + mkVisFunTys, Development.IDE.GHC.Compat.Core.mkInfForAllTys, -- * Specs ImpDeclSpec(..), @@ -217,6 +216,7 @@ noLocA, unLocA, LocatedAn, + LocatedA, #if MIN_VERSION_ghc(9,2,0) GHC.AnnListItem(..), GHC.NameAnn(..), @@ -242,7 +242,7 @@ SrcLoc.mkGeneralSrcSpan, SrcLoc.mkRealSrcSpan, SrcLoc.mkRealSrcLoc, - getRealSrcSpan, + SrcLoc.getRealSrcSpan, SrcLoc.realSrcLocSpan, SrcLoc.realSrcSpanStart, SrcLoc.realSrcSpanEnd, @@ -263,9 +263,7 @@ SrcLoc.noSrcSpan, SrcLoc.noSrcLoc, SrcLoc.noLoc, -#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0) - SrcLoc.dL, -#endif + SrcLoc.mapLoc, -- * Finder FindResult(..), mkHomeModLocation, @@ -311,13 +309,13 @@ Module.ml_hs_file, Module.ml_obj_file, Module.ml_hi_file, - Development.IDE.GHC.Compat.Core.ml_hie_file, + Module.ml_hie_file, -- * DataCon - Development.IDE.GHC.Compat.Core.dataConExTyCoVars, + DataCon.dataConExTyCoVars, -- * Role Role(..), -- * Panic - PlainGhcException, + Plain.PlainGhcException, panic, panicDoc, -- * Other @@ -405,10 +403,8 @@ #else module BasicTypes, module Class, -#if MIN_VERSION_ghc(8,10,0) module Coercion, module Predicate, -#endif module ConLike, module CoreUtils, module DataCon, @@ -455,22 +451,7 @@ module GHC.Parser.Header, module GHC.Parser.Lexer, #else -#if MIN_VERSION_ghc(8,10,0) module GHC.Hs, -#else - module HsBinds, - module HsDecls, - module HsDoc, - module HsExtension, - noExtField, - module HsExpr, - module HsImpExp, - module HsLit, - module HsPat, - module HsSyn, - module HsTypes, - module HsUtils, -#endif module ExtractDocs, module Parser, module Lexer, @@ -492,6 +473,19 @@ module GHC.Unit.Env, module GHC.Driver.Phases, #endif +# if !MIN_VERSION_ghc(9,4,0) + pattern HsFieldBind, + hfbAnn, + hfbLHS, + hfbRHS, + hfbPun, +#endif +#if !MIN_VERSION_ghc_boot_th(9,4,1) + Extension(.., NamedFieldPuns), +#else + Extension(..), +#endif + UniqFM, ) where import qualified GHC @@ -526,7 +520,8 @@ import qualified GHC.Core.DataCon as DataCon import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM +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 @@ -543,8 +538,7 @@ import GHC.Core.TyCo.Ppr import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon -import GHC.Core.Type hiding (mkInfForAllTys, - mkVisFunTys) +import GHC.Core.Type hiding (mkInfForAllTys) import GHC.Core.Unify import GHC.Core.Utils @@ -595,7 +589,7 @@ #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Linker.Loader as Linker import GHC.Linker.Types -import GHC.Parser.Lexer hiding (initParserState) +import GHC.Parser.Lexer hiding (initParserState, getPsMessages) import GHC.Parser.Annotation (EpAnn (..)) import GHC.Platform.Ways import GHC.Runtime.Context (InteractiveImport (..)) @@ -695,29 +689,13 @@ import FamInst import FamInstEnv import Finder hiding (mkHomeModLocation) -#if MIN_VERSION_ghc(8,10,0) import GHC.Hs hiding (HsLet, LetStmt) -#endif import qualified GHCi import GhcMonad import HeaderInfo hiding (getImports) import Hooks import HscMain as GHC import HscTypes -#if !MIN_VERSION_ghc(8,10,0) --- Syntax imports -import HsBinds -import HsDecls -import HsDoc -import HsExpr hiding (HsLet, LetStmt) -import HsExtension -import HsImpExp -import HsLit -import HsPat -import HsSyn hiding (wildCardName, HsLet, LetStmt) -import HsTypes hiding (wildCardName) -import HsUtils -#endif import Id import IfaceSyn import InstEnv @@ -734,19 +712,12 @@ import NameEnv import NameSet import Packages -#if MIN_VERSION_ghc(8,8,0) import Panic hiding (try) import qualified PlainPanic as Plain -#else -import Panic hiding (GhcException, try) -import qualified Panic as Plain -#endif import Parser import PatSyn import RnFixity -#if MIN_VERSION_ghc(8,8,0) import Plugins -#endif import PprTyThing hiding (pprFamInst) import PrelInfo import PrelNames hiding (Unique, printName) @@ -764,37 +735,30 @@ allM, anyM, concatMapM, foldrM, mapMaybeM, (<$>)) import TcRnTypes -import TcType hiding (mkVisFunTys) +import TcType import qualified TcType import TidyPgm as GHC import qualified TyCoRep import TyCon -import Type hiding (mkVisFunTys) +import Type import TysPrim import TysWiredIn import Unify -import UniqFM +import UniqFM hiding (UniqFM) +import qualified UniqFM import UniqSupply import Var (Var (varName), setTyVarUnique, setVarUnique, varType) -#if MIN_VERSION_ghc(8,10,0) import Coercion (coercionKind) import Predicate import SrcLoc (Located, SrcLoc (UnhelpfulLoc), SrcSpan (UnhelpfulSpan)) -#else -import SrcLoc (RealLocated, - SrcLoc (UnhelpfulLoc), - SrcSpan (UnhelpfulSpan)) #endif -#endif -#if !MIN_VERSION_ghc(8,8,0) import Data.List (isSuffixOf) import System.FilePath -#endif #if MIN_VERSION_ghc(9,2,0) @@ -817,7 +781,12 @@ 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) + 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 @@ -901,11 +870,7 @@ #endif pattern FunTy :: Type -> Type -> Type -#if MIN_VERSION_ghc(8,10,0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#else -pattern FunTy arg res <- TyCoRep.FunTy arg res -#endif #if MIN_VERSION_ghc(9,0,0) -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) @@ -931,50 +896,17 @@ {-# COMPLETE L #-} #endif -#elif MIN_VERSION_ghc(8,8,0) +#else type HasSrcSpan = SrcLoc.HasSrcSpan getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan getLoc = SrcLoc.getLoc - -#else - -class HasSrcSpan a where - getLoc :: a -> SrcSpan -instance HasSrcSpan Name where - getLoc = nameSrcSpan -instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where - getLoc = SrcLoc.getLoc - #endif -getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan -#if !MIN_VERSION_ghc(8,8,0) -getRealSrcSpan = SrcLoc.getLoc -#else -getRealSrcSpan = SrcLoc.getRealSrcSpan -#endif - - -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation -#if !MIN_VERSION_ghc(8,8,0) -addBootSuffixLocnOut locn - = locn { Module.ml_hi_file = Module.addBootSuffix (Module.ml_hi_file locn) - , Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn) - } -#else addBootSuffixLocnOut = Module.addBootSuffixLocnOut -#endif - -dataConExTyCoVars :: DataCon -> [TyCoVar] -#if __GLASGOW_HASKELL__ >= 808 -dataConExTyCoVars = DataCon.dataConExTyCoVars -#else -dataConExTyCoVars = DataCon.dataConExTyVars -#endif - #if !MIN_VERSION_ghc(9,0,0) -- Linear Haskell type Scaled a = a @@ -985,14 +917,6 @@ unrestricted = id #endif -mkVisFunTys :: [Scaled Type] -> Type -> Type -mkVisFunTys = -#if __GLASGOW_HASKELL__ <= 808 - mkFunTys -#else - TcType.mkVisFunTys -#endif - mkInfForAllTys :: [TyVar] -> Type -> Type mkInfForAllTys = #if MIN_VERSION_ghc(9,0,0) @@ -1025,32 +949,12 @@ #endif -#if !MIN_VERSION_ghc(8,10,0) -noExtField :: GHC.NoExt -noExtField = GHC.noExt -#endif - -ml_hie_file :: GHC.ModLocation -> FilePath -#if !MIN_VERSION_ghc(8,8,0) -ml_hie_file ml - | "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot" - | otherwise = Module.ml_hi_file ml -<.> ".hie" -#else -ml_hie_file = Module.ml_hie_file -#endif - #if !MIN_VERSION_ghc(9,0,0) pattern NotBoot, IsBoot :: IsBootInterface pattern NotBoot = False pattern IsBoot = True #endif -#if MIN_VERSION_ghc(8,8,0) -type PlainGhcException = Plain.PlainGhcException -#else -type PlainGhcException = Plain.GhcException -#endif - #if MIN_VERSION_ghc(9,0,0) -- This is from the old api, but it still simplifies pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs @@ -1063,6 +967,25 @@ #endif #endif +conPatDetails :: Pat p -> Maybe (HsConPatDetails p) +#if MIN_VERSION_ghc(9,0,0) +conPatDetails (ConPat _ _ args) = Just args +conPatDetails _ = Nothing +#else +conPatDetails (ConPatIn _ args) = Just args +conPatDetails _ = Nothing +#endif + +mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p) +#if MIN_VERSION_ghc(9,0,0) +mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args +mapConPatDetail _ _ = Nothing +#else +mapConPatDetail f (ConPatIn ss args) = ConPatIn ss <$> f args +mapConPatDetail _ _ = Nothing +#endif + + initDynLinker, initObjLinker :: HscEnv -> IO () initDynLinker = #if !MIN_VERSION_ghc(9,0,0) @@ -1120,6 +1043,12 @@ #endif #if MIN_VERSION_ghc(9,2,0) +type LocatedA = GHC.LocatedA +#else +type LocatedA = GHC.Located +#endif + +#if MIN_VERSION_ghc(9,2,0) locA :: SrcSpanAnn' a -> SrcSpan locA = GHC.locA #else @@ -1191,15 +1120,11 @@ #endif mkIfaceTc hsc_env sf details ms tcGblEnv = -#if MIN_VERSION_ghc(8,10,0) GHC.mkIfaceTc hsc_env sf details #if MIN_VERSION_ghc(9,3,0) ms #endif tcGblEnv -#else - fst <$> GHC.mkIfaceTc hsc_env Nothing sf details tcGblEnv -#endif mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc @@ -1231,4 +1156,28 @@ #if !MIN_VERSION_ghc(9,3,0) hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } +#endif + +#if !MIN_VERSION_ghc(9,2,0) +match :: HsRecField' id arg -> ((), id, arg, Bool) +match (HsRecField lhs rhs pun) = ((), SrcLoc.unLoc lhs, rhs, pun) + +pattern HsFieldBind :: () -> id -> arg -> Bool -> HsRecField' id arg +pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- (match -> (hfbAnn, hfbLHS, hfbRHS, hfbPun)) where + HsFieldBind _ lhs rhs pun = HsRecField (SrcLoc.noLoc lhs) rhs pun +#elif !MIN_VERSION_ghc(9,4,0) +pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg +pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where + HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun +#endif + +#if !MIN_VERSION_ghc_boot_th(9,4,1) +pattern NamedFieldPuns :: Extension +pattern NamedFieldPuns = RecordPuns +#endif + +#if MIN_VERSION_ghc(9,0,0) +type UniqFM = UniqFM.UniqFM +#else +type UniqFM k = UniqFM.UniqFM #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -91,11 +91,6 @@ import Module #endif -#if MIN_VERSION_ghc(9,3,0) -hsc_EPS :: HscEnv -> UnitEnv -hsc_EPS = hsc_unit_env -#endif - #if MIN_VERSION_ghc(9,0,0) #if !MIN_VERSION_ghc(9,2,0) import qualified Data.Set as Set @@ -103,6 +98,11 @@ #endif #if !MIN_VERSION_ghc(9,2,0) import Data.IORef +#endif + +#if MIN_VERSION_ghc(9,3,0) +hsc_EPS :: HscEnv -> UnitEnv +hsc_EPS = hsc_unit_env #endif #if !MIN_VERSION_ghc(9,2,0) diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -8,7 +8,7 @@ import GHC #if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Session (targetProfile) +import GHC.Driver.Session (targetProfile) #endif #if MIN_VERSION_ghc(9,2,0) import qualified GHC.Iface.Load as Iface diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -25,7 +25,7 @@ import Outputable (queryQual) #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Error +import GHC.Types.Error #endif putLogHook :: Logger -> HscEnv -> HscEnv diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -27,6 +27,8 @@ -- * Error infrastructure DecoratedSDoc, MsgEnvelope, + ErrMsg, + WarnMsg, errMsgSpan, errMsgSeverity, formatErrorWithQual, @@ -79,9 +81,9 @@ import SrcLoc #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Logger -import GHC.Driver.Config.Diagnostic -import Data.Maybe +import Data.Maybe +import GHC.Driver.Config.Diagnostic +import GHC.Utils.Logger #endif -- | A compatible function to print `Outputable` instances @@ -190,6 +192,13 @@ type PsWarning = ErrMsg type PsError = ErrMsg +#endif + +#if MIN_VERSION_ghc(9,2,0) +type ErrMsg = MsgEnvelope DecoratedSDoc +#endif +#if MIN_VERSION_ghc(9,3,0) +type WarnMsg = MsgEnvelope DecoratedSDoc #endif mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore "Unused LANGUAGE pragma" #-} --- | Parser compaibility module. +-- | Parser compatibility module. module Development.IDE.GHC.Compat.Parser ( initParserOpts, initParserState, diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -2,57 +2,79 @@ -- | Plugin Compat utils. module Development.IDE.GHC.Compat.Plugins ( + -- * Plugin Compat Types, and initialisation Plugin(..), defaultPlugin, -#if __GLASGOW_HASKELL__ >= 808 PluginWithArgs(..), -#endif applyPluginsParsedResultAction, initializePlugins, + initPlugins, -- * Static plugins -#if MIN_VERSION_ghc(8,8,0) StaticPlugin(..), hsc_static_plugins, -#endif + + -- * Plugin messages + PsMessages(..), + getPsMessages ) where #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Driver.Env as Env +import qualified GHC.Driver.Env as Env #endif -import GHC.Driver.Plugins (Plugin (..), - PluginWithArgs (..), - StaticPlugin (..), +import GHC.Driver.Plugins (Plugin (..), + PluginWithArgs (..), + StaticPlugin (..), + defaultPlugin, + withPlugins) #if MIN_VERSION_ghc(9,3,0) - staticPlugins, - ParsedResult(..), - PsMessages(..), +import GHC.Driver.Plugins (ParsedResult (..), + PsMessages (..), + staticPlugins) +import qualified GHC.Parser.Lexer as Lexer +#else +import Data.Bifunctor (bimap) #endif - defaultPlugin, withPlugins) -import qualified GHC.Runtime.Loader as Loader -#elif MIN_VERSION_ghc(8,8,0) -import qualified DynamicLoading as Loader -import Plugins +import qualified GHC.Runtime.Loader as Loader #else -import qualified DynamicLoading as Loader -import Plugins (Plugin (..), defaultPlugin, - withPlugins) +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.Parser as Parser +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) -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do + +#if !MIN_VERSION_ghc(9,3,0) +type PsMessages = (Bag WarnMsg, Bag ErrMsg) +#endif + +getPsMessages :: PState -> DynFlags -> PsMessages +getPsMessages pst dflags = +#if MIN_VERSION_ghc(9,3,0) + uncurry PsMessages $ Lexer.getPsMessages pst +#else +#if MIN_VERSION_ghc(9,2,0) + bimap (fmap pprWarning) (fmap pprError) $ +#endif + getMessages pst +#if !MIN_VERSION_ghc(9,2,0) + dflags +#endif +#endif + +applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) +applyPluginsParsedResultAction env dflags ms hpm_annotations parsed msgs = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms #if MIN_VERSION_ghc(9,3,0) - fmap (hpm_module . parsedResultModule) $ + fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins #else - fmap hpm_module $ + fmap (\parsed_module -> (hpm_module parsed_module, msgs)) $ runHsc env $ withPlugins #endif - runHsc env $ withPlugins #if MIN_VERSION_ghc(9,3,0) (Env.hsc_plugins env) #elif MIN_VERSION_ghc(9,2,0) @@ -62,7 +84,7 @@ #endif applyPluginAction #if MIN_VERSION_ghc(9,3,0) - (ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty)) + (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs) #else (HsParsedModule parsed [] hpm_annotations) #endif @@ -76,8 +98,13 @@ pure $ hscSetFlags newDf env #endif +-- | Plugins aren't stored in ModSummary anymore since GHC 9.2, but this +-- function still returns it for compatibility with 8.10 +initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv) +initPlugins session modSummary = do + session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) + return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1) -#if MIN_VERSION_ghc(8,8,0) hsc_static_plugins :: HscEnv -> [StaticPlugin] #if MIN_VERSION_ghc(9,3,0) hsc_static_plugins = staticPlugins . Env.hsc_plugins @@ -85,5 +112,4 @@ hsc_static_plugins = Env.hsc_static_plugins #else hsc_static_plugins = staticPlugins . hsc_dflags -#endif #endif diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -52,11 +52,11 @@ showSDocForUser', ) where -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import Control.Monad +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 +import GHC.Unit.Home.ModInfo #endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0) diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -30,10 +30,8 @@ -- * Maybes MaybeErr(..), orElse, -#if MIN_VERSION_ghc(8,10,0) -- * Pair Pair(..), -#endif -- * EnumSet EnumSet, toList, @@ -97,10 +95,8 @@ import FastString import Fingerprint import Maybes -#if MIN_VERSION_ghc(8,10,0) -import Pair -#endif import Outputable (pprHsString) +import Pair import Panic hiding (try) import StringBuffer import UniqDFM diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -38,7 +38,7 @@ import GHC.Driver.Types #endif -#elif MIN_VERSION_ghc(8,6,0) +#else import Binary import BinFingerprint (fingerprintBinMem) import BinIface diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -24,6 +24,7 @@ , zeroSpan , realSpan , isInsideSrcSpan + , spanContainsRange , noSpan -- * utilities working with severities @@ -43,6 +44,7 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import GHC +import Language.LSP.Types (isSubrangeOf) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -118,6 +120,10 @@ p `isInsideSrcSpan` r = case srcSpanToRange r of Just (Range sp ep) -> sp <= p && p <= ep _ -> False + +-- Returns Nothing if the SrcSpan does not represent a valid range +spanContainsRange :: SrcSpan -> Range -> Maybe Bool +spanContainsRange srcSpan range = (range `isSubrangeOf`) <$> srcSpanToRange srcSpan -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -44,7 +44,7 @@ import ByteCodeTypes #endif #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.PkgQual +import GHC.Types.PkgQual #endif -- Orphan instances for types from the GHC API. @@ -104,11 +104,6 @@ instance NFData ModSummary where rnf = rwhnf -#if !MIN_VERSION_ghc(8,10,0) -instance NFData FastString where - rnf = rwhnf -#endif - #if MIN_VERSION_ghc(9,2,0) instance Ord FastString where compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) @@ -217,8 +212,8 @@ #if MIN_VERSION_ghc(9,3,0) instance NFData PkgQual where - rnf NoPkgQual = () - rnf (ThisPkg uid) = rnf uid + rnf NoPkgQual = () + rnf (ThisPkg uid) = rnf uid rnf (OtherPkg uid) = rnf uid instance NFData UnitId where diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -26,10 +26,12 @@ setHieDir, dontWriteHieFiles, disableWarningsAsErrors, - printOutputable + printOutputable, + 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) @@ -73,7 +75,7 @@ import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC +import GHC hiding (ParsedModule (..)) import GHC.IO.BufferedIO (BufferedIO) import GHC.IO.Device as IODevice import GHC.IO.Encoding @@ -81,6 +83,7 @@ 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 @@ -279,18 +282,21 @@ -------------------------------------------------------------------------------- -- Tracing exactprint terms --- Should in `Development.IDE.GHC.Orphans`, --- leave it here to prevent cyclic module dependency -#if !MIN_VERSION_ghc(8,10,0) -instance Outputable SDoc where - ppr = id -#endif - -- | Print a GHC value in `defaultUserStyle` without unique symbols. +-- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- --- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`. +-- This is the most common print utility. +-- It will do something additionally compared to what the 'Outputable' instance does. -- --- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`. +-- 1. print with a user-friendly style: `a_a4ME` as `a`. +-- 2. unescape escape sequences of printable unicode characters within a pair of double quotes printOutputable :: Outputable a => a -> T.Text -printOutputable = T.pack . printWithoutUniques +printOutputable = + -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. + -- Showing a String escapes non-ascii printable characters. We unescape it here. + -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. + unescape . T.pack . printWithoutUniques {-# INLINE printOutputable #-} + +getExtensions :: ParsedModule -> [Extension] +getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -1,7 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE CPP #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -49,8 +49,8 @@ attachReason (Just wr) d = d{_code = InR <$> showReason wr} where showReason = \case - WarningWithFlag flag -> showFlag flag - _ -> Nothing + WarningWithFlag flag -> showFlag flag + _ -> Nothing #else attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr} diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -28,7 +28,7 @@ import Data.Maybe import System.FilePath #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.PkgQual +import GHC.Types.PkgQual #endif data Import @@ -123,11 +123,12 @@ #if MIN_VERSION_ghc(9,3,0) OtherPkg uid | Just dirs <- lookup uid import_paths + -> lookupLocal uid dirs #else Just pkgName | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths -#endif -> lookupLocal uid dirs +#endif | otherwise -> lookupInPackageDB env #if MIN_VERSION_ghc(9,3,0) NoPkgQual -> do @@ -148,7 +149,7 @@ mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> lookupInPackageDB env + Nothing -> lookupInPackageDB env Just (uid, file) -> toModLocation uid file where dflags = hsc_dflags env @@ -182,7 +183,7 @@ mkError' = diagFromString "not found" DsError (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs - -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. + -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. lookupToFindResult = \case LookupFound _m _pkgConfig -> diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -248,11 +248,7 @@ (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> printOutputable ideclName , _kind = SkModule -#if MIN_VERSION_ghc(8,10,0) , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } -#else - , _detail = if ideclQualified then Just "qualified" else Nothing -#endif } documentSymbolForImport _ = Nothing diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -13,27 +13,22 @@ ,Log(..) ) where import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.STM.Stats (atomically, - dumpSTMStats) +import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) import Control.Monad.Extra (concatMapM, unless, when) -import qualified Data.Aeson.Encode.Pretty as A import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Foldable (traverse_) import Data.Hashable (hashed) import qualified Data.HashMap.Strict as HashMap import Data.List.Extra (intercalate, - isPrefixOf, nub, - nubOrd, partition) + isPrefixOf, nubOrd, + partition) import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.Text.Lazy.IO as LT -import Data.Typeable (typeOf) import Development.IDE (Action, GhcVersion (..), Priority (Debug, Error), @@ -47,24 +42,19 @@ import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick, setFilesOfInterest) -import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), - mainRule) +import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), GetHieAst (GetHieAst), - GhcSession (GhcSession), - GhcSessionDeps (GhcSessionDeps), TypeCheck (TypeCheck)) import Development.IDE.Core.Service (initialise, runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, - ShakeExtras (state), shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, setupLSP) @@ -103,8 +93,7 @@ defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (WithHieDb, - fromKeyType) +import Development.IDE.Types.Shake (WithHieDb) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -114,8 +103,6 @@ Config, checkParents, checkProject, getConfigFromNotification) -import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, - pluginsToVSCodeExtensionSchema) import Ide.PluginUtils (allLspCmdIds', getProcessID, idePluginsToPluginDesc, @@ -126,10 +113,8 @@ PluginId (PluginId), ipMap, pluginId) import qualified Language.LSP.Server as LSP -import qualified "list-t" ListT import Numeric.Natural (Natural) import Options.Applicative hiding (action) -import qualified StmContainers.Map as STM import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), exitWith) @@ -144,14 +129,13 @@ import System.Random (newStdGen) import System.Time.Extra (Seconds, offsetTime, showDuration) -import Text.Printf (printf) data Log = LogHeapStats !HeapStats.Log | LogLspStart [PluginId] | LogLspStartDuration !Seconds | LogShouldRunSubset !Bool - | LogOnlyPartialGhc92Support + | LogOnlyPartialGhc94Support | LogSetInitialDynFlagsException !SomeException | LogService Service.Log | LogShake Shake.Log @@ -175,8 +159,8 @@ "Started LSP server in" <+> pretty (showDuration duration) LogShouldRunSubset shouldRunSubset -> "shouldRunSubset:" <+> pretty shouldRunSubset - LogOnlyPartialGhc92Support -> - "Currently, HLS supports GHC 9.2 only partially. See [issue #2982](https://github.com/haskell/haskell-language-server/issues/2982) for more detail." + LogOnlyPartialGhc94Support -> + "Currently, HLS supports GHC 9.4 only partially. See [issue #3190](https://github.com/haskell/haskell-language-server/issues/3190) for more detail." LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e) LogService log -> pretty log @@ -192,8 +176,6 @@ | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} -- ^ Run a command in the hiedb | LSP -- ^ Run the LSP server - | PrintExtensionSchema - | PrintDefaultConfig | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show @@ -210,8 +192,6 @@ hsubparser(command "typecheck" (info (Check <$> fileCmd) fileInfo) <> command "hiedb" (info (Db <$> HieDb.optParser "" True <*> HieDb.cmdParser) hieInfo) <> command "lsp" (info (pure LSP) lspInfo) - <> command "vscode-extension-schema" extensionSchemaCommand - <> command "generate-default-config" generateDefaultConfigCommand <> pluginCommands ) where @@ -219,12 +199,6 @@ lspInfo = fullDesc <> progDesc "Start talking to an LSP client" fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" hieInfo = fullDesc <> progDesc "Query .hie files" - extensionSchemaCommand = - info (pure PrintExtensionSchema) - (fullDesc <> progDesc "Print generic config schema for plugins (used in the package.json of haskell vscode extension)") - generateDefaultConfigCommand = - info (pure PrintDefaultConfig) - (fullDesc <> progDesc "Print config supported by the server with default values") pluginCommands = mconcat [ command (T.unpack pId) (Custom <$> p) @@ -234,7 +208,6 @@ data Arguments = Arguments { argsProjectRoot :: Maybe FilePath - , argsOTMemoryProfiling :: Bool , argCommand :: Command , argsLogger :: IO Logger , argsRules :: Rules () @@ -252,15 +225,14 @@ , argsMonitoring :: IO Monitoring } -defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments -defaultArguments recorder logger = Arguments +defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments +defaultArguments recorder logger plugins = Arguments { argsProjectRoot = Nothing - , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = pure logger , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) + , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -290,14 +262,15 @@ } -testing :: Recorder (WithPriority Log) -> Logger -> Arguments -testing recorder logger = +testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments +testing recorder logger plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = + defaultArguments recorder logger plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ideOptions = \config sessionLoader -> + ideOptions config sessionLoader = let defOptions = argsIdeOptions config sessionLoader in @@ -324,7 +297,7 @@ hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } - argsOnConfigChange = getConfigFromNotification + argsOnConfigChange = getConfigFromNotification argsHlsPlugins rules = argsRules >> pluginRules plugins debouncer <- argsDebouncer @@ -332,13 +305,10 @@ outH <- argsHandleOut numProcessors <- getNumProcessors + let numCapabilities = max 1 $ maybe (numProcessors `div` 2) fromIntegral argsThreads case argCommand of - PrintExtensionSchema -> - LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins - PrintDefaultConfig -> - LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins - LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do + LSP -> withNumCapabilities numCapabilities $ do t <- offsetTime log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) @@ -371,9 +341,9 @@ , optRunSubset = runSubset } caps = LSP.resClientCapabilities env - -- FIXME: Remove this after GHC 9.2 gets fully supported - when (ghcVersion == GHC92) $ - log Warning LogOnlyPartialGhc92Support + -- FIXME: Remove this after GHC 9.4 gets fully supported + when (ghcVersion == GHC94) $ + log Warning LogOnlyPartialGhc94Support monitoring <- argsMonitoring initialise (cmapWithPrio LogService recorder) @@ -438,21 +408,6 @@ 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)" - - when argsOTMemoryProfiling $ do - let values = state $ shakeExtras ide - let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6) - consoleObserver (Just k) = return $ \size -> printf " - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3) - - stateContents <- atomically $ ListT.toList $ STM.listT values - printf "# Shake value store contents(%d):\n" (length stateContents) - let keys = - nub $ - typeOf GhcSession : - typeOf GhcSessionDeps : - [kty | (fromKeyType -> Just (kty,_), _) <- stateContents, kty /= typeOf GhcSessionIO] ++ - [typeOf GhcSessionIO] - measureMemory logger [keys] consoleObserver values unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs --- a/src/Development/IDE/Main/HeapStats.hs +++ b/src/Development/IDE/Main/HeapStats.hs @@ -59,8 +59,8 @@ threadDelay heapStatsInterval logHeapStats l --- | A helper function which lauches the 'heapStatsThread' and kills it --- appropiately when the inner action finishes. It also checks to see +-- | A helper function which launches the 'heapStatsThread' and kills it +-- appropriately when the inner action finishes. It also checks to see -- if `-T` is enabled. withHeapStats :: Recorder (WithPriority Log) -> IO r -> IO r withHeapStats l k = do diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.Completions ( descriptor @@ -8,47 +9,49 @@ , ghcideCompletionsPluginPriority ) where -import Control.Concurrent.Async (concurrently) -import Control.Concurrent.STM.Stats (readTVarIO) -import Control.Monad.Extra +import Control.Concurrent.Async (concurrently) +import Control.Concurrent.STM.Stats (readTVarIO) import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe +import Control.Lens ((&), (.~)) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Data.Aeson -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.List (find) import Data.Maybe -import qualified Data.Text as T +import qualified Data.Text as T import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (Log, - LogShake) -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.Service hiding (Log, LogShake) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (rangeToSrcSpan) -import Development.IDE.GHC.Util (printOutputable) +import Development.IDE.GHC.Util import Development.IDE.Graph +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports), - hscEnv) -import qualified Development.IDE.Types.KnownTargets as KT +import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), + hscEnv) +import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, - WithPriority, - cmapWithPrio) -import GHC.Exts (fromList, toList) -import Ide.Plugin.Config (Config) +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import Ide.Types -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types -import qualified Language.LSP.VFS as VFS +import qualified Language.LSP.Types.Lens as J +import qualified Language.LSP.VFS as VFS import Numeric.Natural -import Text.Fuzzy.Parallel (Scored (..)) +import Text.Fuzzy.Parallel (Scored (..)) +import Development.IDE.Core.Rules (usePropertyAction) +import qualified GHC.LanguageExtensions as LangExt +import qualified Ide.Plugin.Config as Config + data Log = LogShake Shake.Log deriving Show instance Pretty Log where @@ -62,10 +65,12 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP + <> mkPluginHandler SCompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } + produceCompletions :: Recorder (WithPriority Log) -> Rules () produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do @@ -78,7 +83,7 @@ _ -> return ([], Nothing) define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, - -- synthetizing a fake module with an empty body from the buffer + -- 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 @@ -90,8 +95,9 @@ (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do + visibleMods <- liftIO $ fmap (fromMaybe []) $ envVisibleModuleNames sess let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports + let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports return ([], Just cdata) (_diag, _) -> return ([], Nothing) @@ -107,6 +113,49 @@ f x = x in f <$> iDecl +resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) +resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} + | Just resolveData <- _xdata + , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData + , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri + = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do + msess <- useWithStaleFast GhcSessionDeps file + case msess of + Nothing -> pure (Right comp) -- File doesn't compile, return original completion item + Just (sess,_) -> do + let nc = ideNc $ shakeExtras ide +#if MIN_VERSION_ghc(9,3,0) + name <- liftIO $ lookupNameCache nc mod occ +#else + name <- liftIO $ upNameCache nc (lookupNameCache mod occ) +#endif + mdkm <- useWithStaleFast GetDocMap file + let (dm,km) = case mdkm of + Just (DKMap dm km, _) -> (dm,km) + Nothing -> (mempty, mempty) + doc <- case lookupNameEnv dm name of + Just doc -> pure $ spanDocToMarkdown doc + Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name + typ <- case lookupNameEnv km name of + _ | not needType -> pure Nothing + Just ty -> pure (safeTyThingType ty) + Nothing -> do + (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) + let det1 = case typ of + Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") + Nothing -> Nothing + doc1 = case _documentation of + Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) -> + CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc) + _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc + pure (Right $ comp & J.detail .~ (det1 <> _detail) + & J.documentation .~ Just doc1 + ) + where + stripForall ty = case splitForAllTyCoVars ty of + (_,res) -> res +resolveCompletion _ _ comp = pure (Right comp) + -- | Generate code actions. getCompletionsLSP :: IdeState @@ -121,7 +170,7 @@ fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do + (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath @@ -137,26 +186,46 @@ let exportsMap = fromMaybe mempty packageExportsMap <> projectExportsMap let moduleExports = getModuleExportsMap exportsMap - exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap + exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . nonDetOccEnvElts . getExportsMap $ exportsMap exportsCompls = mempty{anyQualCompls = exportsCompItems} let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules - pure (opts, fmap (,pm,binds) compls, moduleExports) + -- get HieAst if OverloadedRecordDot is enabled +#if MIN_VERSION_ghc(9,2,0) + let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags +#else + let uses_overloaded_record_dot _ = False +#endif + ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath + astres <- case ms of + Just ms' | uses_overloaded_record_dot ms' + -> useWithStaleFast GetHieAst npath + _ -> return Nothing + + pure (opts, fmap (,pm,binds) compls, moduleExports, astres) case compls of Just (cci', parsedMod, bindMap) -> do - pfix <- VFS.getCompletionPrefix position cnts + let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of - (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (InL $ List []) - (Just pfix', _) -> do + (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide - config <- getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports + config <- liftIO $ runAction "" ide $ getCompletionsConfig plId + + allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) _ -> return (InL $ List []) + +getCompletionsConfig :: PluginId -> Action CompletionsConfig +getCompletionsConfig pId = + CompletionsConfig + <$> usePropertyAction #snippetsOn pId properties + <*> usePropertyAction #autoExtendOn pId properties + <*> (Config.maxCompletions <$> getClientConfigAction) {- COMPLETION SORTING We return an ordered set of completions (local -> nonlocal -> global). diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -10,26 +10,28 @@ , localCompletionsForParsedModule , getCompletions , fromIdentInfo +, getCompletionPrefix ) where import Control.Applicative -import Data.Char (isUpper) +import Data.Char (isAlphaNum, isUpper) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, - mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, + isJust, listToMaybe, + mapMaybe, isNothing) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy import Control.Monad import Data.Aeson (ToJSON (toJSON)) -import Data.Either (fromRight) 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)) @@ -59,13 +61,19 @@ #endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), - IdePlugins(..), PluginId) + IdePlugins (..), + PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE + +import Development.IDE.Spans.AtPoint (pointCommand) + -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int chunkSize = 1000 @@ -144,16 +152,12 @@ | otherwise = Nothing importInline _ _ = Nothing -occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind -occNameToComKind ty oc +occNameToComKind :: OccName -> CompletionItemKind +occNameToComKind oc | isVarOcc oc = case occNameString oc of i:_ | isUpper i -> CiConstructor _ -> CiFunction - | isTcOcc oc = case ty of - Just t - | "Constraint" `T.isSuffixOf` t - -> CiInterface - _ -> CiStruct + | isTcOcc oc = CiStruct | isDataOcc oc = CiConstructor | otherwise = CiVariable @@ -162,19 +166,20 @@ showModName = T.pack . moduleNameString mkCompl :: Maybe PluginId -- ^ Plugin to use for the extend import command - -> IdeOptions -> CompItem -> CompletionItem + -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl pId IdeOptions {..} + uri CI { compKind, isInfix, insertText, provenance, - typeText, label, - docs, - additionalTextEdits + typeText, + additionalTextEdits, + nameDetails } = do let mbCommand = mkAdditionalEditsCommand pId =<< additionalTextEdits let ci = CompletionItem @@ -183,7 +188,7 @@ _tags = Nothing, _detail = case (typeText, provenance) of - (Just t,_) | not(T.null t) -> Just $ colon <> t + (Just t,_) | not(T.null t) -> Just $ ":: " <> t (_, ImportedFrom mod) -> Just $ "from " <> mod (_, DefinedIn mod) -> Just $ "from " <> mod _ -> Nothing, @@ -199,16 +204,15 @@ _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = mbCommand, - _xdata = Nothing} + _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails} removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind - docs' = imported : spanDocToMarkdown docs + docs' = [imported] imported = case provenance of Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n" ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n" DefinedIn mod -> "*Defined in '" <> mod <> "'*\n" - colon = if optNewColonConvention then ": " else ":: " documentation = Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs' @@ -222,22 +226,20 @@ mkAdditionalEditsCommand (Just pId) edits = Just $ mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) mkAdditionalEditsCommand _ _ = Nothing -mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkNameCompItem doc thingParent origName provenance thingType isInfix docs !imp = CI {..} +mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> Provenance -> Maybe Backtick -> Maybe (LImportDecl GhcPs) -> Maybe Module -> CompItem +mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..} where - compKind = occNameToComKind typeText origName + isLocalCompletion = True + nameDetails = NameDetails <$> mod <*> pure origName + compKind = occNameToComKind origName isTypeCompl = isTcOcc origName + typeText = Nothing label = stripPrefix $ printOutputable origName insertText = case isInfix of - Nothing -> case getArgText <$> thingType of - Nothing -> label - Just argText -> if T.null argText then label else label <> " " <> argText + Nothing -> label Just LeftSide -> label <> "`" Just Surrounded -> label - typeText - | Just t <- thingType = Just . stripForall $ printOutputable t - | otherwise = Nothing additionalTextEdits = imp <&> \x -> ExtendImport @@ -248,48 +250,6 @@ newThing = printOutputable origName } - stripForall :: T.Text -> T.Text - stripForall t - | T.isPrefixOf "forall" t = - -- We drop 2 to remove the '.' and the space after it - T.drop 2 (T.dropWhile (/= '.') t) - | otherwise = t - - getArgText :: Type -> T.Text - getArgText typ = argText - where - argTypes = getArgs typ - argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes - snippet :: Int -> Type -> T.Text - snippet i t = case t of - (TyVarTy _) -> noParensSnippet - (LitTy _) -> noParensSnippet - (TyConApp _ []) -> noParensSnippet - _ -> snippetText i ("(" <> showForSnippet t <> ")") - where - noParensSnippet = snippetText i (showForSnippet t) - snippetText i t = "${" <> T.pack (show i) <> ":" <> t <> "}" - getArgs :: Type -> [Type] - getArgs t - | isPredTy t = [] - | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) - | isFunTy t = - let (args, ret) = splitFunTys t - in if isForAllTy ret - then getArgs ret - else Prelude.filter (not . isDictTy) $ map scaledThing args - | isPiTy t = getArgs $ snd (splitPiTys t) -#if MIN_VERSION_ghc(8,10,0) - | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t - = getArgs t -#else - | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) -#endif - | otherwise = [] - - showForSnippet :: Outputable a => a -> T.Text #if MIN_VERSION_ghc(9,2,0) showForSnippet x = T.pack $ renderWithContext ctxt $ GHC.ppr x -- FIXme @@ -327,30 +287,31 @@ fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem -fromIdentInfo doc IdentInfo{..} q = CI - { compKind= occNameToComKind Nothing name - , insertText=rendered - , provenance = DefinedIn moduleNameText - , typeText=Nothing - , label=rendered +fromIdentInfo doc id@IdentInfo{..} q = CI + { compKind= occNameToComKind name + , insertText=rend + , provenance = DefinedIn mod + , label=rend + , typeText = Nothing , isInfix=Nothing - , docs=emptySpanDoc - , isTypeCompl= not isDatacon && isUpper (T.head rendered) + , isTypeCompl= not (isDatacon id) && isUpper (T.head rend) , additionalTextEdits= Just $ ExtendImport { doc, - thingParent = parent, - importName = moduleNameText, + thingParent = occNameText <$> parent, + importName = mod, importQual = q, - newThing = rendered + newThing = rend } + , nameDetails = Nothing + , isLocalCompletion = False } + where rend = rendered id + mod = moduleNameText id -cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions -cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do - let - packageState = hscEnv env - curModName = moduleName curMod +cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions +cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = + let curModName = moduleName curMod curModNameText = printOutputable curModName importMap = Map.fromList [ (l, imp) | imp@(L (locA -> (RealSrcSpan l _)) _) <- limports ] @@ -361,34 +322,44 @@ asNamespace :: ImportDecl GhcPs -> ModuleName asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp) -- Full canonical names of imported modules - importDeclerations = map unLoc limports + importDeclarations = map unLoc limports -- The given namespaces for the imported modules (ie. full name, or alias if used) - allModNamesAsNS = map (showModName . asNamespace) importDeclerations + allModNamesAsNS = map (showModName . asNamespace) importDeclarations rdrElts = globalRdrEnvElts globalEnv - foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b - foldMapM f xs = foldr step return xs mempty where - step x r z = f x >>= \y -> r $! z `mappend` y + -- construct a map from Parents(type) to their fields + fieldMap = Map.fromListWith (++) $ flip mapMaybe rdrElts $ \elt -> do +#if MIN_VERSION_ghc(9,2,0) + par <- greParent_maybe elt + flbl <- greFieldLabel elt + Just (par,[flLabel flbl]) +#else + case gre_par elt of + FldParent n ml -> do + l <- ml + Just (n, [l]) + _ -> Nothing +#endif - getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls) - getCompls = foldMapM getComplsForOne + getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls) + getCompls = foldMap getComplsForOne - getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls) + getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls) getComplsForOne (GRE n par True _) = - (, mempty) <$> toCompItem par curMod curModNameText n Nothing + (toCompItem par curMod curModNameText n Nothing, mempty) getComplsForOne (GRE n par False prov) = - flip foldMapM (map is_decl prov) $ \spec -> do + flip foldMap (map is_decl prov) $ \spec -> let originalImportDecl = do -- we don't want to extend import if it's already in scope guard . null $ lookupGRE_Name inScopeEnv n -- or if it doesn't have a real location loc <- realSpan $ is_dloc spec Map.lookup loc importMap - compItem <- toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl - let unqual + compItem = toCompItem par curMod (printOutputable $ is_mod spec) n originalImportDecl + unqual | is_qual spec = [] | otherwise = compItem qual @@ -396,38 +367,34 @@ | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] asMod = showModName (is_as spec) origMod = showModName (is_mod spec) - return (unqual,QualCompls qual) + in (unqual,QualCompls qual) - toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem] - toCompItem par m mn n imp' = do - docs <- getDocumentationTryGhc packageState curMod n + toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem] + toCompItem par m mn n imp' = + -- docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n) ParentIs n' -> (Just . T.pack $ printName n', nameOccName n) #if !MIN_VERSION_ghc(9,2,0) FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl) #endif - tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do - name' <- lookupName packageState m n - return ( name' >>= safeTyThingType - , guard (isJust mbParent) >> name' >>= safeTyThingForRecord - ) - let (ty, record_ty) = fromRight (Nothing, Nothing) tys - - let recordCompls = case record_ty of - Just (ctxStr, flds) | not (null flds) -> - [mkRecordSnippetCompItem uri mbParent ctxStr flds (ImportedFrom mn) docs imp'] + recordCompls = case par of + ParentIs parent + | isDataConName n + , Just flds <- Map.lookup parent fieldMap + , not (null flds) -> + [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS) flds) (ImportedFrom mn) imp'] _ -> [] - return $ mkNameCompItem uri mbParent originName (ImportedFrom mn) ty Nothing docs imp' - : recordCompls + in mkNameCompItem uri mbParent originName (ImportedFrom mn) Nothing imp' (nameModule_maybe n) + : recordCompls - (unquals,quals) <- getCompls rdrElts + (unquals,quals) = getCompls rdrElts - -- The list of all importable Modules from all packages - moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env + -- The list of all importable Modules from all packages + moduleNames = map showModName visibleMods - return $ CC + in CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals @@ -473,9 +440,9 @@ TyClD _ x -> let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) | id <- listify (\(_ :: LIdP GhcPs) -> True) x - , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + , let cl = occNameToComKind (rdrNameOcc $ unLoc id)] -- here we only have to look at the outermost type - recordCompls = findRecordCompl uri pm (Local pos) x + recordCompls = findRecordCompl uri (Local pos) x in -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls @@ -489,34 +456,28 @@ ] mkLocalComp pos n ctyp ty = - CI ctyp pn (Local pos) ensureTypeText pn Nothing doc (ctyp `elem` [CiStruct, CiInterface]) Nothing + CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True where - -- when sorting completions, we use the presence of typeText - -- to tell local completions and global completions apart - -- instead of using the empty string here, we should probably introduce a new field... - ensureTypeText = Just $ fromMaybe "" ty + occ = rdrNameOcc $ unLoc n pn = showForSnippet n - doc = SpanDocText (getDocumentation [pm] $ reLoc n) (SpanDocUris Nothing Nothing) -findRecordCompl :: Uri -> ParsedModule -> Provenance -> TyClDecl GhcPs -> [CompItem] -findRecordCompl uri pmod mn DataDecl {tcdLName, tcdDataDefn} = result +findRecordCompl :: Uri -> Provenance -> TyClDecl GhcPs -> [CompItem] +findRecordCompl uri mn DataDecl {tcdLName, tcdDataDefn} = result where result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName) - (printOutputable . unLoc $ con_name) field_labels mn doc Nothing + (printOutputable . unLoc $ con_name) field_labels mn Nothing | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn , Just con_details <- [getFlds con_args] , let field_names = concatMap extract con_details , let field_labels = printOutputable <$> field_names , (not . List.null) field_labels ] - doc = SpanDocText (getDocumentation [pmod] $ reLoc tcdLName) (SpanDocUris Nothing Nothing) getFlds conArg = case conArg of RecCon rec -> Just $ unLoc <$> unLoc rec PrefixCon{} -> Just [] _ -> Nothing - extract ConDeclField{..} -- NOTE: 'cd_fld_names' is grouped so that the fields -- sharing the same type declaration to fit in the same group; e.g. -- @@ -527,13 +488,15 @@ -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ -- Hence, we must concat nested arguments into one to get all the fields. #if MIN_VERSION_ghc(9,3,0) + extract ConDeclField{..} = map (foLabel . unLoc) cd_fld_names #else + extract ConDeclField{..} = map (rdrNameFieldOcc . unLoc) cd_fld_names #endif -- XConDeclField extract _ = [] -findRecordCompl _ _ _ _ = [] +findRecordCompl _ _ _ = [] toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = @@ -562,20 +525,22 @@ -> IdeOptions -> CachedCompletions -> Maybe (ParsedModule, PositionMapping) + -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) - -> VFS.PosPrefixInfo + -> PosPrefixInfo -> ClientCapabilities -> CompletionsConfig - -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) + -> ModuleNameEnv (HashSet.HashSet IdentInfo) + -> Uri -> IO [Scored CompletionItem] getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do - let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo - enteredQual = if T.null prefixModule then "" else prefixModule <> "." + maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap uri = do + let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo + enteredQual = if T.null prefixScope then "" else prefixScope <> "." fullPrefix = enteredQual <> prefixText -- Boolean labels to tag suggestions as qualified (or not) - qual = not(T.null prefixModule) + qual = not(T.null prefixScope) notQual = False {- correct the position by moving 'foo :: Int -> String -> ' @@ -583,7 +548,7 @@ to 'foo :: Int -> String -> ' ^ -} - pos = VFS.cursorPos prefixInfo + pos = cursorPos prefixInfo maxC = maxCompletions config @@ -606,6 +571,43 @@ hpos = upperRange position' in getCContext lpos pm <|> getCContext hpos pm + + -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work, + -- since it gets the record fields from the types. + -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields. + -- Requiring fresh hieast is fine for normal workflows, because it is generated while the user edits. + recordDotSyntaxCompls :: [(Bool, CompItem)] + recordDotSyntaxCompls = case maybe_ast_res of + Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) nodeCompletions + _ -> [] + where + nodeCompletions :: HieAST Type -> [(Bool, CompItem)] + nodeCompletions node = concatMap g (nodeType $ nodeInfo node) + g :: Type -> [(Bool, CompItem)] + g (TyConApp theTyCon _) = map (dotFieldSelectorToCompl (printOutputable $ GHC.tyConName theTyCon)) $ getSels theTyCon + g _ = [] + getSels :: GHC.TyCon -> [T.Text] + getSels tycon = let f fieldLabel = printOutputable fieldLabel + in map f $ tyConFieldLabels tycon + -- Completions can return more information that just the completion itself, but it will + -- require more than what GHC currently gives us in the HieAST, since it only gives the Type + -- of the fields, not where they are defined, etc. So for now the extra fields remain empty. + -- Also: additionalTextEdits is a todo, since we may want to import the record. It requires a way + -- to get the record's module, which isn't included in the type information used to get the fields. + dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem) + dotFieldSelectorToCompl recname label = (True, CI + { compKind = CiField + , insertText = label + , provenance = DefinedIn recname + , label = label + , typeText = Nothing + , isInfix = Nothing + , isTypeCompl = False + , additionalTextEdits = Nothing + , nameDetails = Nothing + , isLocalCompletion = False + }) + -- completions specific to the current context ctxCompls' = case mcc of Nothing -> compls @@ -616,26 +618,31 @@ ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls' infixCompls :: Maybe Backtick - infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos + infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos PositionMapping bDelta = bmapping - oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + oldPos = fromDelta bDelta $ cursorPos prefixInfo startLoc = lowerRange oldPos endLoc = upperRange oldPos localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc localBindsToCompItem :: Name -> Maybe Type -> CompItem - localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing + localBindsToCompItem name typ = CI ctyp pn thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True where occ = nameOccName name - ctyp = occNameToComKind Nothing occ + ctyp = occNameToComKind occ pn = showForSnippet name ty = showForSnippet <$> typ thisModName = Local $ nameSrcSpan name + dets = NameDetails <$> (nameModule_maybe name) <*> pure (nameOccName name) - compls = if T.null prefixModule - then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls) - else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls)) - ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls) + -- When record-dot-syntax completions are available, we return them exclusively. + -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled. + -- Anything that isn't a field is invalid, so those completion don't make sense. + compls + | T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ map (\compl -> (notQual, compl Nothing)) anyQualCompls + | not $ null recordDotSyntaxCompls = recordDotSyntaxCompls + | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls)) + ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls filtListWith f list = [ fmap f label @@ -646,7 +653,7 @@ filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName filtKeywordCompls - | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] if @@ -655,10 +662,10 @@ && (List.length (words (T.unpack fullLine)) >= 2) && "(" `isInfixOf` T.unpack fullLine -> do - let moduleName = T.pack $ words (T.unpack fullLine) !! 1 - funcs = HM.lookupDefault HashSet.empty moduleName moduleExportsMap - funs = map (show . name) $ HashSet.toList funcs - return $ filterModuleExports moduleName $ map T.pack funs + let moduleName = words (T.unpack fullLine) !! 1 + funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName + funs = map (renderOcc . name) $ HashSet.toList funcs + return $ filterModuleExports (T.pack moduleName) funs | "import " `T.isPrefixOf` fullLine -> return filtImportCompls -- we leave this condition here to avoid duplications and return empty list @@ -668,7 +675,7 @@ | otherwise -> do -- assumes that nubOrdBy is stable let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls - let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts) uniqueFiltCompls + let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls pId = lookupCommandProvider plugins (CommandId extendImportCommandId) return $ (fmap.fmap) snd $ @@ -694,6 +701,7 @@ + uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique = case compare (label candidate, compKind candidate) @@ -701,22 +709,17 @@ EQ -> -- preserve completions for duplicate record fields where the only difference is in the type -- remove redundant completions with less type info than the previous - if (typeText candidate == typeText unique && isLocalCompletion unique) + if (isLocalCompletion unique) -- filter global completions when we already have a local one || not(isLocalCompletion candidate) && isLocalCompletion unique then EQ else compare (importedFrom candidate, insertText candidate) (importedFrom unique, insertText unique) other -> other where - isLocalCompletion ci = isJust(typeText ci) - importedFrom :: CompItem -> T.Text importedFrom (provenance -> ImportedFrom m) = m importedFrom (provenance -> DefinedIn m) = m importedFrom (provenance -> Local _) = "local" -#if __GLASGOW_HASKELL__ < 810 - importedFrom _ = "" -#endif -- --------------------------------------------------------------------- -- helper functions for infix backticks @@ -809,17 +812,8 @@ ] -safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) -safeTyThingForRecord (AnId _) = Nothing -safeTyThingForRecord (AConLike dc) = - let ctxStr = printOutputable . occName . conLikeName $ dc - field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc - in - Just (ctxStr, field_names) -safeTyThingForRecord _ = Nothing - -mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem -mkRecordSnippetCompItem uri parent ctxStr compl importedFrom docs imp = r +mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem +mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where r = CI { compKind = CiSnippet @@ -828,7 +822,6 @@ , typeText = Nothing , label = ctxStr , isInfix = Nothing - , docs = docs , isTypeCompl = False , additionalTextEdits = imp <&> \x -> ExtendImport @@ -838,6 +831,8 @@ importQual = getImportQual x, newThing = ctxStr } + , nameDetails = Nothing + , isLocalCompletion = True } placeholder_pairs = zip compl ([1..]::[Int]) @@ -890,3 +885,32 @@ [] -> [] [xs] -> xs lists' -> merge_lists lists' + +-- |From the given cursor position, gets the prefix module or record for autocompletion +getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo +getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = + fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad + let headMaybe = listToMaybe + lastMaybe = headMaybe . reverse + + -- grab the entire line the cursor is at + curLine <- headMaybe $ T.lines $ Rope.toText + $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + let beforePos = T.take (fromIntegral c) curLine + -- the word getting typed, after previous space and before cursor + curWord <- + if | T.null beforePos -> Just "" + | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' + | otherwise -> lastMaybe (T.words beforePos) + + let parts = T.split (=='.') + $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord + case reverse parts of + [] -> Nothing + (x:xs) -> do + let modParts = reverse $ filter (not .T.null) xs + modName = T.intercalate "." modParts + return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos } + +completionPrefixPos :: PosPrefixInfo -> Position +completionPrefixPos PosPrefixInfo { cursorPos = Position ln co, prefixText = str} = Position ln (co - (fromInteger . toInteger . T.length $ str) - 1) diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -11,7 +12,8 @@ import qualified Data.Map as Map import qualified Data.Text as T -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson +import Data.Aeson.Types import Data.Hashable (Hashable) import Data.Text (Text) import Data.Typeable (Typeable) @@ -19,13 +21,14 @@ import Development.IDE.Graph (RuleResult) import Development.IDE.Spans.Common import GHC.Generics (Generic) -import Ide.Plugin.Config (Config) -import qualified Ide.Plugin.Config as Config import Ide.Plugin.Properties -import Ide.PluginUtils (getClientConfig, usePropertyLsp) -import Ide.Types (PluginId) -import Language.LSP.Server (MonadLsp) import Language.LSP.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Types as J +#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 @@ -60,14 +63,7 @@ "Extends the import list automatically when completing a out-of-scope identifier" True -getCompletionsConfig :: (MonadLsp Config m) => PluginId -> m CompletionsConfig -getCompletionsConfig pId = - CompletionsConfig - <$> usePropertyLsp #snippetsOn pId properties - <*> usePropertyLsp #autoExtendOn pId properties - <*> (Config.maxCompletions <$> getClientConfig) - data CompletionsConfig = CompletionsConfig { enableSnippets :: Bool, enableAutoExtend :: Bool, @@ -94,13 +90,14 @@ { compKind :: CompletionItemKind , insertText :: T.Text -- ^ Snippet for the completion , provenance :: Provenance -- ^ From where this item is imported from. - , typeText :: Maybe T.Text -- ^ Available type information. , label :: T.Text -- ^ Label to display to the user. + , typeText :: Maybe T.Text , isInfix :: Maybe Backtick -- ^ Did the completion happen -- in the context of an infix notation. - , docs :: SpanDoc -- ^ Available documentation. , isTypeCompl :: Bool , additionalTextEdits :: Maybe ExtendImport + , nameDetails :: Maybe NameDetails -- ^ For resolving purposes + , isLocalCompletion :: Bool -- ^ Is it from this module? } deriving (Eq, Show) @@ -136,3 +133,80 @@ instance Semigroup CachedCompletions where CC a b c d e <> CC a' b' c' d' e' = CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e') + + +-- | Describes the line at the current cursor position +data PosPrefixInfo = PosPrefixInfo + { fullLine :: !T.Text + -- ^ The full contents of the line the cursor is at + + , prefixScope :: !T.Text + -- ^ If any, the module name that was typed right before the cursor position. + -- For example, if the user has typed "Data.Maybe.from", then this property + -- will be "Data.Maybe" + -- If OverloadedRecordDot is enabled, "Shape.rect.width" will be + -- "Shape.rect" + + , prefixText :: !T.Text + -- ^ The word right before the cursor position, after removing the module part. + -- For example if the user has typed "Data.Maybe.from", + -- then this property will be "from" + , cursorPos :: !J.Position + -- ^ The cursor position + } deriving (Show,Eq) + + +-- | This is a JSON serialisable representation of a GHC Name that we include in +-- completion responses so that we can recover the original name corresponding +-- to the completion item. This is used to resolve additional details on demand +-- about the item like its type and documentation. +data NameDetails + = NameDetails Module OccName + deriving (Eq) + +-- NameSpace is abstract so need these +nsJSON :: NameSpace -> Value +nsJSON ns + | isVarNameSpace ns = String "v" + | isDataConNameSpace ns = String "c" + | isTcClsNameSpace ns = String "t" + | isTvNameSpace ns = String "z" + | otherwise = error "namespace not recognized" + +parseNs :: Value -> Parser NameSpace +parseNs (String "v") = pure Occ.varName +parseNs (String "c") = pure dataName +parseNs (String "t") = pure tcClsName +parseNs (String "z") = pure tvName +parseNs _ = mempty + +instance FromJSON NameDetails where + parseJSON v@(Array _) + = do + [modname,modid,namesp,occname] <- parseJSON v + mn <- parseJSON modname + mid <- parseJSON modid + ns <- parseNs namesp + occn <- parseJSON occname + pure $ NameDetails (mkModule (stringToUnit mid) (mkModuleName mn)) (mkOccName ns occn) + parseJSON _ = mempty +instance ToJSON NameDetails where + toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs] + where + mname = moduleNameString $ moduleName mdl + mid = unitIdString $ moduleUnitId mdl + ns = occNameSpace occ + occs = occNameString occ +instance Show NameDetails where + show = show . toJSON + +-- | The data that is acutally 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 + { itemFile :: Uri + , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item? + , itemName :: NameDetails + } + deriving stock Generic + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -13,13 +13,16 @@ import Control.Lens ((^.)) import Control.Monad import qualified Data.Aeson as J +import Data.Bifunctor (first) import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Either import qualified Data.List as List import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Some import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -38,6 +41,7 @@ import qualified Language.LSP.Types as J import qualified Language.LSP.Types.Lens as LSP import Language.LSP.VFS +import Prettyprinter.Render.String (renderString) import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) @@ -46,13 +50,19 @@ -- --------------------------------------------------------------------- -- -data Log = LogPluginError ResponseError - deriving Show - +data Log + = LogPluginError PluginId ResponseError + | LogNoPluginForMethod (Some SMethod) + | LogInvalidCommandIdentifier instance Pretty Log where pretty = \case - LogPluginError err -> prettyResponseError err + LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err + LogNoPluginForMethod (Some method) -> + "No plugin enabled for " <> pretty (show method) + LogInvalidCommandIdentifier-> "Invalid command identifier" +instance Show Log where show = renderString . layoutCompact . pretty + -- various error message specific builders prettyResponseError :: ResponseError -> Doc a prettyResponseError err = errorCode <> ":" <+> errorBody @@ -61,26 +71,32 @@ errorBody = pretty $ err ^. LSP.message pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text -pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins) +pluginNotEnabled method availPlugins = + "No plugin enabled for " <> T.pack (show method) <> ", available: " + <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text -commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are:\n" <> T.pack (unlines $ map (show . commandId) legalCmds) +commandDoesntExist (CommandId com) (PluginId pid) legalCmds = + "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are: " + <> (T.intercalate ", " $ map (\(PluginCommand{commandId = CommandId cid}) -> cid) legalCmds) failedToParseArgs :: CommandId -- ^ command that failed to parse -> PluginId -- ^ Plugin that created the command -> String -- ^ The JSON Error message -> J.Value -- ^ The Argument Values -> Text -failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg) +failedToParseArgs (CommandId com) (PluginId pid) err arg = + "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " + <> T.pack err <> ", arg = " <> T.pack (show arg) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) -logAndReturnError recorder errCode msg = do +logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError recorder p errCode msg = do let err = ResponseError errCode msg Nothing - logWith recorder Warning $ LogPluginError err + logWith recorder Warning $ LogPluginError p err pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. @@ -90,12 +106,17 @@ mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> mkPlugin (extensiblePlugins recorder) id <> mkPlugin (extensibleNotificationPlugins recorder) id <> - mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags + mkPluginFromDescriptor dynFlagsPlugins HLS.pluginModifyDynflags where + mkPlugin f = mkPluginFromDescriptor (f . map (first pluginId)) - mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config - mkPlugin maker selector = - case map (\p -> (pluginId p, selector p)) ls of + mkPluginFromDescriptor + :: ([(PluginDescriptor IdeState, b)] + -> Plugin Config) + -> (PluginDescriptor IdeState -> b) + -> Plugin Config + mkPluginFromDescriptor maker selector = + case map (\p -> (p, selector p)) ls of -- If there are no plugins that provide a descriptor, use mempty to -- create the plugin – otherwise we we end up declaring handlers for -- capabilities that there are no plugins for @@ -109,7 +130,7 @@ where rules = foldMap snd rs -dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config +dynFlagsPlugins :: [(PluginDescriptor c, DynFlagsModifications)] -> Plugin Config dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = flip foldMap rs $ \(plId, dflag_mods) cfg -> @@ -164,15 +185,17 @@ Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -- Couldn't parse the command identifier - _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier" + _ -> do + logWith recorder Warning LogInvalidCommandIdentifier + return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p) + Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs) + Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg) + J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg) J.Success a -> f ide a -- --------------------------------------------------------------------- @@ -195,15 +218,21 @@ let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') + Nothing -> do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = ResponseError InvalidRequest msg Nothing + msg = pluginNotEnabled m fs' + return $ Left err Just fs -> do let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently msg (show m) handlers ide params - let (errs,succs) = partitionEithers $ toList es - unless (null errs) $ forM_ errs $ \err -> logWith recorder Warning $ LogPluginError err + + let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es + unless (null errs) $ forM_ errs $ \(pId, err) -> + logWith recorder Warning $ LogPluginError pId err case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors errs + Nothing -> pure $ Left $ combineErrors $ map snd errs Just xs -> do caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs @@ -226,7 +255,8 @@ -- Only run plugins that are allowed to run on this request let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' case nonEmpty fs of - Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') + Nothing -> do + logWith recorder Warning (LogNoPluginForMethod $ Some m) Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last @@ -242,8 +272,8 @@ -- ^ Enabled plugin actions that we are allowed to run -> a -> b - -> m (NonEmpty (Either ResponseError d)) -runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do + -> m (NonEmpty(NonEmpty (Either ResponseError d))) +runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do f a b `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -54,7 +54,7 @@ <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), - pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False} + pluginConfigDescriptor = defaultConfigDescriptor } -- --------------------------------------------------------------------- diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -27,7 +27,8 @@ import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, define, - srcSpanToRange) + srcSpanToRange, + usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), @@ -49,8 +50,7 @@ import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties -import Ide.PluginUtils (mkLspCommand, - usePropertyLsp) +import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), @@ -105,7 +105,7 @@ CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do - mode <- usePropertyLsp #mode pId properties + mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath) diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -280,11 +280,7 @@ where ni = nodeInfo' x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] -#if MIN_VERSION_ghc(8,8,0) HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) -#else - HAppTy a b -> getTypes [a,b] -#endif HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) HForAllTy _ a -> getTypes [a] #if MIN_VERSION_ghc(9,0,1) diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -23,6 +23,7 @@ import GHC +import Data.Bifunctor (second) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util @@ -49,10 +50,11 @@ safeTyThingId _ = Nothing -- Possible documentation for an element in the code -data SpanDoc #if MIN_VERSION_ghc(9,3,0) +data SpanDoc = SpanDocString [HsDocString] SpanDocUris #else +data SpanDoc = SpanDocString HsDocString SpanDocUris #endif | SpanDocText [T.Text] SpanDocUris @@ -178,8 +180,12 @@ haddockToMarkdown (H.DocUnorderedList things) = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things) -haddockToMarkdown (H.DocOrderedList things) - = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things) +haddockToMarkdown (H.DocOrderedList things) = +#if MIN_VERSION_haddock_library(1,11,0) + '\n' : (unlines $ map ((\(num, str) -> show num ++ ". " ++ str) . second (trimStart . splitForList . haddockToMarkdown)) things) +#else + '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things) +#endif haddockToMarkdown (H.DocDefList things) = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -34,7 +34,7 @@ import Language.LSP.Types (filePathToUri, getUri) #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Unique.Map +import GHC.Types.Unique.Map #endif mkDocMap @@ -62,27 +62,30 @@ getDocs n map | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist | otherwise = do - doc <- getDocumentationTryGhc env mod n + doc <- getDocumentationTryGhc env n pure $ extendNameEnv map n doc getType n map - | isTcOcc $ occName n = do - kind <- lookupKind env mod n - pure $ maybe map (extendNameEnv map n) kind + | isTcOcc $ occName n + , Nothing <- lookupNameEnv map n + = do kind <- lookupKind env n + pure $ maybe map (extendNameEnv map n) kind | otherwise = pure map names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod -lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) -lookupKind env mod = - fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod +lookupKind :: HscEnv -> Name -> IO (Maybe TyThing) +lookupKind env = + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc -getDocumentationTryGhc env mod n = fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env mod [n] +getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc +getDocumentationTryGhc env n = + (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n]) + `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc) -getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc] -getDocumentationsTryGhc env mod names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names +getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc env names = do + res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names case res of Left _ -> return [] Right res -> zipWithM unwrap res names @@ -128,7 +131,7 @@ -- TODO : Build a version of GHC exactprint to extract this information -- more accurately. -- TODO : Implement this for GHC 9.2 with in-tree annotations --- (alternatively, just remove it and rely soley on GHC's parsing) +-- (alternatively, just remove it and rely solely on GHC's parsing) getDocumentation sources targetName = fromMaybe [] $ do #if MIN_VERSION_ghc(9,2,0) Nothing @@ -137,7 +140,7 @@ targetNameSpan <- realSpan $ getLoc targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse sources -- TODO : Is reversing the list here really neccessary? + $ reverse sources -- TODO : Is reversing the list here really necessary? -- Top level names bound by the module let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs --- a/src/Development/IDE/Spans/Pragmas.hs +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -6,7 +6,8 @@ ( NextPragmaInfo(..) , LineSplitTextEdits(..) , getNextPragmaInfo - , insertNewPragma ) where + , insertNewPragma + , getFirstPragma ) where import Data.Bits (Bits (setBit)) import Data.Function ((&)) @@ -14,11 +15,15 @@ import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text -import Development.IDE (srcSpanToRange) +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import GHC.LanguageExtensions.Type (Extension) import qualified Language.LSP.Types as LSP +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Ide.Types (PluginId(..)) +import qualified Data.Text as T +import Ide.PluginUtils (handleMaybeM) getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText = @@ -31,13 +36,29 @@ | otherwise -> NextPragmaInfo 0 Nothing +-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns` +-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4 +-- GHC as well, hence the replacement. +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156 +showExtension :: Extension -> Text +showExtension NamedFieldPuns = "NamedFieldPuns" +showExtension ext = pack (show ext) + insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit -insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" } :: LSP.TextEdit -insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> pack (show newPragma) <> " #-}\n" +insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._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 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo +getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do + ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp + (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp + case ghcSession of + Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents + Nothing -> pure Nothing + -- Pre-declaration comments parser ----------------------------------------------------- -- | Each mode represents the "strongest" thing we've seen so far. @@ -416,26 +437,10 @@ startRealSrcLoc = mkRealSrcLoc "asdf" 1 1 updateDynFlags = flip gopt_unset Opt_Haddock . flip gopt_set Opt_KeepRawTokenStream finalDynFlags = updateDynFlags dynFlags -#if !MIN_VERSION_ghc(8,8,1) - pState = mkPState finalDynFlags stringBuffer startRealSrcLoc - finalPState = pState{ use_pos_prags = False } -#elif !MIN_VERSION_ghc(8,10,1) - mkLexerParserFlags = - mkParserFlags' - <$> warningFlags - <*> extensionFlags - <*> homeUnitId_ - <*> safeImportsOn - <*> gopt Opt_Haddock - <*> gopt Opt_KeepRawTokenStream - <*> const False - finalPState = mkPStatePure (mkLexerParserFlags finalDynFlags) stringBuffer startRealSrcLoc -#else pState = initParserState (initParserOpts finalDynFlags) stringBuffer startRealSrcLoc PState{ options = pStateOptions } = pState finalExtBitsMap = setBit (pExtsBitmap pStateOptions) (fromEnum UsePosPragsBit) finalPStateOptions = pStateOptions{ pExtsBitmap = finalExtBitsMap } finalPState = pState{ options = finalPStateOptions } -#endif in finalPState diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -69,13 +69,13 @@ abortQueue x ActionQueue {..} = do qq <- flushTQueue newActions mapM_ (writeTQueue newActions) (filter (/= x) qq) - modifyTVar inProgress (Set.delete x) + modifyTVar' inProgress (Set.delete x) -- | Mark an action as complete when called after 'popQueue'. -- Has no effect otherwise doneQueue :: DelayedActionInternal -> ActionQueue -> STM () doneQueue x ActionQueue {..} = do - modifyTVar inProgress (Set.delete x) + modifyTVar' inProgress (Set.delete x) countQueue :: ActionQueue -> STM Natural countQueue ActionQueue{..} = do diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -5,25 +5,34 @@ ( IdentInfo(..), ExportsMap(..), + rendered, + moduleNameText, + occNameText, + renderOcc, + mkTypeOcc, + mkVarOrDataOcc, + isDatacon, createExportsMap, createExportsMapMg, - createExportsMapTc, buildModuleExportMapFrom, createExportsMapHieDb, size, + exportsMapSize, updateExportsMapMg ) where -import Control.DeepSeq (NFData (..)) +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.Text (Text, pack) +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 @@ -32,124 +41,144 @@ data ExportsMap = ExportsMap - { getExportsMap :: !(HashMap IdentifierText (HashSet IdentInfo)) - , getModuleExportsMap :: !(HashMap ModuleNameText (HashSet IdentInfo)) + { getExportsMap :: !(OccEnv (HashSet IdentInfo)) + , getModuleExportsMap :: !(ModuleNameEnv (HashSet IdentInfo)) } - deriving (Show) -deleteEntriesForModule :: ModuleNameText -> ExportsMap -> ExportsMap -deleteEntriesForModule m em = ExportsMap - { getExportsMap = - let moduleIds = Map.lookupDefault mempty m (getModuleExportsMap em) - in deleteAll - (rendered <$> Set.toList moduleIds) - (getExportsMap em) - , getModuleExportsMap = Map.delete m (getModuleExportsMap em) - } - where - deleteAll keys map = foldr Map.delete map keys +instance NFData ExportsMap where + rnf (ExportsMap a b) = foldOccEnv (\a b -> rnf a `seq` b) (seqEltsUFM rnf b) a +instance Show ExportsMap where + show (ExportsMap occs mods) = + unwords [ "ExportsMap { getExportsMap =" + , printWithoutUniques $ mapOccEnv (text . show) occs + , "getModuleExportsMap =" + , printWithoutUniques $ mapUFM (text . show) mods + , "}" + ] + +-- | `updateExportsMap old new` results in an export map containing +-- the union of old and new, but with all the module entries new overriding +-- those in old. +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 + } + 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 length . elems . getExportsMap +size = sum . map (Set.size) . nonDetOccEnvElts . getExportsMap +mkVarOrDataOcc :: Text -> OccName +mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t + where + mkOcc + | Just (c,_) <- uncons t + , c == ':' || isUpper c = mkDataOccFS + | otherwise = mkVarOccFS + +mkTypeOcc :: Text -> OccName +mkTypeOcc t = mkTcOccFS $ mkFastStringByteString $ encodeUtf8 t + +exportsMapSize :: ExportsMap -> Int +exportsMapSize = foldOccEnv (\_ x -> x+1) 0 . getExportsMap + instance Semigroup ExportsMap where - ExportsMap a b <> ExportsMap c d = ExportsMap (Map.unionWith (<>) a c) (Map.unionWith (<>) b d) + ExportsMap a b <> ExportsMap c d = ExportsMap (plusOccEnv_C (<>) a c) (plusUFM_C (<>) b d) instance Monoid ExportsMap where - mempty = ExportsMap Map.empty Map.empty + mempty = ExportsMap emptyOccEnv emptyUFM -type IdentifierText = Text -type ModuleNameText = Text +rendered :: IdentInfo -> Text +rendered = occNameText . name +-- | Render an identifier as imported or exported style. +-- TODO: pattern synonymoccNameText :: OccName -> Text +occNameText :: OccName -> Text +occNameText name + | isSymOcc name = "(" <> renderedOcc <> ")" + | isTcOcc name && isSymOcc name = "type (" <> renderedOcc <> ")" + | otherwise = renderedOcc + where + renderedOcc = renderOcc name + +renderOcc :: OccName -> Text +renderOcc = decodeUtf8 . bytesFS . occNameFS + +moduleNameText :: IdentInfo -> Text +moduleNameText = moduleNameText' . identModuleName + +moduleNameText' :: ModuleName -> Text +moduleNameText' = decodeUtf8 . bytesFS . moduleNameFS + data IdentInfo = IdentInfo - { name :: !OccName - , rendered :: Text - , parent :: !(Maybe Text) - , isDatacon :: !Bool - , moduleNameText :: !Text + { name :: !OccName + , parent :: !(Maybe OccName) + , identModuleName :: !ModuleName } deriving (Generic, Show) deriving anyclass Hashable +isDatacon :: IdentInfo -> Bool +isDatacon = isDataOcc . name + instance Eq IdentInfo where a == b = name a == name b && parent a == parent b - && isDatacon a == isDatacon b - && moduleNameText a == moduleNameText b + && identModuleName a == identModuleName b instance NFData IdentInfo where rnf IdentInfo{..} = -- deliberately skip the rendered field - rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText - --- | Render an identifier as imported or exported style. --- TODO: pattern synonym -renderIEWrapped :: Name -> Text -renderIEWrapped n - | isTcOcc occ && isSymOcc occ = "type " <> pack (printName n) - | otherwise = pack $ printName n - where - occ = occName n + rnf name `seq` rnf parent `seq` rnf identModuleName -mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] +mkIdentInfos :: ModuleName -> AvailInfo -> [IdentInfo] mkIdentInfos mod (AvailName n) = - [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) Nothing mod] mkIdentInfos mod (AvailFL fl) = - [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) Nothing mod] where n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod + = [ IdentInfo (nameOccName n) (Just $! nameOccName parent) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] - where - parentP = pack $ printName parent + [ IdentInfo (nameOccName n) Nothing mod] mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod + = [ IdentInfo (nameOccName n) Nothing mod | n <- nn ++ map flSelector flds ] createExportsMap :: [ModIface] -> ExportsMap createExportsMap modIface = do let exportList = concatMap doOne modIface - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList + let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList + force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace - concatMap (fmap (second Set.fromList) . getModDetails) (mi_exports modIFace) + concatMap (getModDetails) (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do let exportList = concatMap doOne modGuts - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList + let exportsMap = mkOccEnv_C (<>) $ map (\(a,_,c) -> (a, c)) exportList + force $ ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList -- UFM is lazy, so need to seq where doOne mi = do let getModuleName = moduleName $ mg_module mi - concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (mg_exports mi) + concatMap (unpackAvail getModuleName) (mg_exports mi) updateExportsMapMg :: [ModGuts] -> ExportsMap -> ExportsMap -updateExportsMapMg modGuts old = old' <> new +updateExportsMapMg modGuts old = updateExportsMap old new where new = createExportsMapMg modGuts - old' = deleteAll old (Map.keys $ getModuleExportsMap new) - deleteAll = foldl' (flip deleteEntriesForModule) -createExportsMapTc :: [TcGblEnv] -> ExportsMap -createExportsMapTc modIface = do - let exportList = concatMap doOne modIface - let exportsMap = Map.fromListWith (<>) $ map (\(a,_,c) -> (a, c)) exportList - ExportsMap exportsMap $ buildModuleExportMap $ map (\(_,b,c) -> (b, c)) exportList - where - doOne mi = do - let getModuleName = moduleName $ tcg_mod mi - concatMap (fmap (second Set.fromList) . unpackAvail getModuleName) (tcg_exports mi) - nonInternalModules :: ModuleName -> Bool nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString @@ -158,49 +187,44 @@ createExportsMapHieDb :: WithHieDb -> IO ExportsMap createExportsMapHieDb withHieDb = do mods <- withHieDb getAllIndexedMods - idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do + idents' <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m - mText = pack $ moduleNameString mn - fmap (wrap . unwrap mText) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) - let exportsMap = Map.fromListWith (<>) (concat idents) - return $ ExportsMap exportsMap $ buildModuleExportMap (concat idents) + fmap (unwrap mn) <$> withHieDb (\hieDb -> getExportsForModule hieDb mn) + let idents = concat idents' + let exportsMap = mkOccEnv_C (<>) (keyWith name idents) + return $!! ExportsMap exportsMap $ buildModuleExportMap (keyWith identModuleName idents) -- UFM is lazy so need to seq where - wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) - -- unwrap :: ExportRow -> IdentInfo - unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m - where - n = pack (occNameString exportName) - p = pack . occNameString <$> exportParent + unwrap m ExportRow{..} = IdentInfo exportName exportParent m + keyWith f xs = [(f x, Set.singleton x) | x <- xs] -unpackAvail :: ModuleName -> IfaceExport -> [(Text, Text, [IdentInfo])] +unpackAvail :: ModuleName -> IfaceExport -> [(OccName, ModuleName, HashSet IdentInfo)] unpackAvail mn - | nonInternalModules mn = map f . mkIdentInfos mod + | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where - !mod = pack $ moduleNameString mn - f id@IdentInfo {..} = (printOutputable name, moduleNameText,[id]) + f id@IdentInfo {..} = (name, mn, Set.singleton id) -identInfoToKeyVal :: IdentInfo -> (ModuleNameText, IdentInfo) +identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo) identInfoToKeyVal identInfo = - (moduleNameText identInfo, identInfo) + (identModuleName identInfo, identInfo) -buildModuleExportMap:: [(Text, HashSet IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo) +buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMap exportsMap = do let lst = concatMap (Set.toList. snd) exportsMap let lstThree = map identInfoToKeyVal lst sortAndGroup lstThree -buildModuleExportMapFrom:: [ModIface] -> Map.HashMap Text (HashSet IdentInfo) +buildModuleExportMapFrom:: [ModIface] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMapFrom modIfaces = do let exports = map extractModuleExports modIfaces - Map.fromListWith (<>) exports + listToUFM_C (<>) exports -extractModuleExports :: ModIface -> (Text, HashSet IdentInfo) +extractModuleExports :: ModIface -> (ModuleName, HashSet IdentInfo) extractModuleExports modIFace = do - let modName = pack $ moduleNameString $ moduleName $ mi_module modIFace + let modName = moduleName $ mi_module modIFace let functionSet = Set.fromList $ concatMap (mkIdentInfos modName) $ mi_exports modIFace (modName, functionSet) -sortAndGroup :: [(ModuleNameText, IdentInfo)] -> Map.HashMap ModuleNameText (HashSet IdentInfo) -sortAndGroup assocs = Map.fromListWith (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] +sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) +sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -43,9 +43,6 @@ -- ^ File extensions to search for code, defaults to Haskell sources (including @.hs@) , optShakeProfiling :: Maybe FilePath -- ^ Set to 'Just' to create a directory of profiling reports. - , optOTMemoryProfiling :: IdeOTMemoryProfiling - -- ^ Whether to record profiling information with OpenTelemetry. You must - -- also enable the -l RTS flag for this to have any effect , optTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress @@ -123,7 +120,6 @@ ,optPkgLocationOpts = defaultIdePkgLocationOptions ,optShakeOptions = shakeOptions ,optShakeProfiling = Nothing - ,optOTMemoryProfiling = IdeOTMemoryProfiling False ,optReportProgress = IdeReportProgress False ,optLanguageSyntax = "haskell" ,optNewColonConvention = False diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -26,7 +26,7 @@ import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes (FileVersion) -import Development.IDE.Graph (Key (..), RuleResult) +import Development.IDE.Graph (Key (..), RuleResult, newKey) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location @@ -75,7 +75,7 @@ | otherwise = False toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key -toKey = (Key.) . curry Q +toKey = (newKey.) . curry Q fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) fromKey (Key k) @@ -91,7 +91,7 @@ _ -> Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key -toNoFileKey k = Key $ Q (k, emptyFilePath) +toNoFileKey k = newKey $ Q (k, emptyFilePath) newtype Q k = Q (k, NormalizedFilePath) deriving newtype (Eq, Hashable, NFData) diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -91,8 +91,8 @@ -- match against the pattern. Runs with default settings where -- nothing is added around the matches, as case insensitive. -- --- >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"] --- ["vim","virtual machine"] +-- >>> simpleFilter 1000 10 "vm" ["vim", "emacs", "virtual machine"] +-- [Scored {score = 4, original = "vim"},Scored {score = 4, original = "virtual machine"}] {-# INLINABLE simpleFilter #-} simpleFilter :: Int -- ^ Chunk size. 1000 works well. -> Int -- ^ Max. number of results wanted diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -{-# OPTIONS_GHC -w #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - - -import qualified Control.Exception as Exception -import qualified Data.List as List -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir `joinFileName` name) - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath - - - -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath -bindir = "/home/zubin/.cabal/bin" -libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace" -dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" -datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" -libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" -sysconfdir = "/home/zubin/.cabal/etc" - -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - - - - -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (List.last dir) = dir ++ fname - | otherwise = dir ++ pathSeparator : fname - -pathSeparator :: Char -pathSeparator = '/' - -isPathSeparator :: Char -> Bool -isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -{-# OPTIONS_GHC -w #-} -module Paths_a ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - - -import qualified Control.Exception as Exception -import qualified Data.List as List -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir `joinFileName` name) - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath - - - -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath -bindir = "/home/zubin/.cabal/bin" -libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace-a-test" -dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" -datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" -libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" -sysconfdir = "/home/zubin/.cabal/etc" - -getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) - - - - -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (List.last dir) = dir ++ fname - | otherwise = dir ++ pathSeparator : fname - -pathSeparator :: Char -pathSeparator = '/' - -isPathSeparator :: Char -> Bool -isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -{-# OPTIONS_GHC -w #-} -module Paths_b ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - - -import qualified Control.Exception as Exception -import qualified Data.List as List -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir `joinFileName` name) - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath - - - -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath -bindir = "/home/zubin/.cabal/bin" -libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0-inplace" -dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" -datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" -libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" -sysconfdir = "/home/zubin/.cabal/etc" - -getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) - - - - -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (List.last dir) = dir ++ fname - | otherwise = dir ++ pathSeparator : fname - -pathSeparator :: Char -pathSeparator = '/' - -isPathSeparator :: Char -> Bool -isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoRebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} -{-# OPTIONS_GHC -w #-} -module Paths_c ( - version, - getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, - getDataFileName, getSysconfDir - ) where - - -import qualified Control.Exception as Exception -import qualified Data.List as List -import Data.Version (Version(..)) -import System.Environment (getEnv) -import Prelude - - -#if defined(VERSION_base) - -#if MIN_VERSION_base(4,0,0) -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#else -catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a -#endif - -#else -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#endif -catchIO = Exception.catch - -version :: Version -version = Version [1,0,0] [] - -getDataFileName :: FilePath -> IO FilePath -getDataFileName name = do - dir <- getDataDir - return (dir `joinFileName` name) - -getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath - - - -bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath -bindir = "/home/zubin/.cabal/bin" -libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0-inplace" -dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" -datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" -libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" -sysconfdir = "/home/zubin/.cabal/etc" - -getBinDir = catchIO (getEnv "c_bindir") (\_ -> return bindir) -getLibDir = catchIO (getEnv "c_libdir") (\_ -> return libdir) -getDynLibDir = catchIO (getEnv "c_dynlibdir") (\_ -> return dynlibdir) -getDataDir = catchIO (getEnv "c_datadir") (\_ -> return datadir) -getLibexecDir = catchIO (getEnv "c_libexecdir") (\_ -> return libexecdir) -getSysconfDir = catchIO (getEnv "c_sysconfdir") (\_ -> return sysconfdir) - - - - -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname - | isPathSeparator (List.last dir) = dir ++ fname - | otherwise = dir ++ pathSeparator : fname - -pathSeparator :: Char -pathSeparator = '/' - -isPathSeparator :: Char -> Bool -isPathSeparator c = c == '/' diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1,6 +1,31 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{- + NOTE On enforcing determinism + + The tests below use two mechanisms to enforce deterministic LSP sequences: + + 1. Progress reporting: waitForProgress(Begin|Done) + 2. Diagnostics: expectDiagnostics + + Either is fine, but diagnostics are generally more reliable. + + Mixing them both in the same test is NOT FINE as it will introduce race + conditions since multiple interleavings are possible. In other words, + the sequence of diagnostics and progress reports is not deterministic. + For example: + + < do something > + waitForProgressDone + expectDiagnostics [...] + + - When the diagnostics arrive after the progress done message, as they usually do, the test will pass + - When the diagnostics arrive before the progress done msg, when on a slow machine occasionally, the test will timeout + + Therefore, avoid mixing both progress reports and diagnostics in the same test + -} + {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} @@ -239,7 +264,7 @@ testGroup "initialize response capabilities" [ chk " text doc sync" _textDocumentSync tds , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False)) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True)) , chk "NO signature help" _signatureHelpProvider Nothing , chk " goto definition" _definitionProvider (Just $ InL True) , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) @@ -593,7 +618,7 @@ [ ( "Foo.hs" -- The test is to make sure that warnings contain unqualified names -- where appropriate. The warning should use an unqualified name 'Ord', not - -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to -- test this is fairly arbitrary. , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") ] @@ -1184,10 +1209,32 @@ void (openTestDataDoc (dir fp)) diag + pluginSimpleTests :: TestTree pluginSimpleTests = - ignoreInWindowsForGHC88And810 $ - ignoreForGHC92Plus "blocked on ghc-typelits-natnormalise" $ + ignoreInWindowsForGHC810 $ + -- Build profile: -w ghc-9.4.2 -O1 + -- In order, the following will be built (use -v for more details): + -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) + -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) + -- - plugin-1.0.0 (lib) (first run) + -- Starting ghc-typelits-natnormalise-0.7.7 (lib) + -- Building ghc-typelits-natnormalise-0.7.7 (lib) + + -- Failed to build ghc-typelits-natnormalise-0.7.7. + -- Build log ( + -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log + -- ): + -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. + -- Building library for ghc-typelits-natnormalise-0.7.7.. + -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) + -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) + -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) + -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory + + -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is + -- required by plugin-1.0.0). See the build log above for details. + ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" liftIO $ writeFile (dir"hie.yaml") @@ -1201,7 +1248,7 @@ pluginParsedResultTests :: TestTree pluginParsedResultTests = - ignoreInWindowsForGHC88And810 $ + ignoreInWindowsForGHC810 $ ignoreForGHC92Plus "No need for this plugin anymore!" $ testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do _ <- openDoc (dir "RecordDot.hs") "haskell" @@ -1370,7 +1417,7 @@ _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , ignoreInWindowsForGHC88 $ testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do + , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do -- This test defines a TH value with the meaning "data A = A" in A.hs -- Loads and export the template in B.hs @@ -1492,22 +1539,29 @@ , testGroup "doc" completionDocTests ] -completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree completionTest name src pos expected = testSessionWait name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics compls <- getCompletions docId pos let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - liftIO $ do - let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do - when expectedSig $ - assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do + CompletionItem{..} <- + if expectedSig || expectedDocs + then do + rsp <- request SCompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) topLevelCompletionTests :: [TestTree] @@ -1531,14 +1585,14 @@ [("xxx", CiFunction, "xxx", True, True, Nothing)], completionTest "type" - ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] (Position 0 9) - [("Xxx", CiStruct, "Xxx", False, True, Nothing)], + [("Xzz", CiStruct, "Xzz", False, True, Nothing)], completionTest "class" - ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"] + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] (Position 0 9) - [("Xxx", CiInterface, "Xxx", False, True, Nothing)], + [("Xzz", CiInterface, "Xzz", False, True, Nothing)], completionTest "records" ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] @@ -1656,18 +1710,18 @@ nonLocalCompletionTests :: [TestTree] nonLocalCompletionTests = - [ completionTest + [ brokenForWinGhc $ completionTest "variable" ["module A where", "f = hea"] (Position 1 7) - [("head", CiFunction, "head ${1:([a])}", True, True, Nothing)], + [("head", CiFunction, "head", True, True, Nothing)], completionTest "constructor" ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] (Position 2 8) [ ("True", CiConstructor, "True", True, True, Nothing) ], - completionTest + brokenForWinGhc $ completionTest "type" ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] (Position 2 8) @@ -1677,13 +1731,13 @@ "qualified" ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] (Position 2 15) - [ ("head", CiFunction, "head ${1:([a])}", True, True, Nothing) + [ ("head", CiFunction, "head", True, True, Nothing) ], completionTest "duplicate import" ["module A where", "import Data.List", "import Data.List", "f = permu"] (Position 3 9) - [ ("permutations", CiFunction, "permutations ${1:([a])}", False, False, Nothing) + [ ("permutations", CiFunction, "permutations", False, False, Nothing) ], completionTest "dont show hidden items" @@ -1701,7 +1755,7 @@ ,"f = BS.read" ] (Position 2 10) - [("readFile", CiFunction, "readFile ${1:FilePath}", True, True, Nothing)] + [("readFile", CiFunction, "readFile", True, True, Nothing)] ], -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls completionTest @@ -1713,6 +1767,8 @@ (Position 0 13) [] ] + where + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94]) "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ @@ -1753,7 +1809,7 @@ _ <- waitForDiagnostics compls <- getCompletions docA $ Position 2 4 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ take 2 compls' @?= ["member ${1:Bar}", "member ${1:Foo}"], + liftIO $ take 2 compls' @?= ["member"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines @@ -1820,7 +1876,7 @@ _ <- waitForDiagnostics compls <- getCompletions doc (Position 3 13) let duplicate = - find + filter (\case CompletionItem { _insertText = Just "fromList" @@ -1830,7 +1886,7 @@ "GHC.Exts" `T.isInfixOf` d _ -> False ) compls - liftIO $ duplicate @?= Nothing + liftIO $ length duplicate @?= 1 , testSessionWait "non-local before global" $ do -- non local completions are more specific @@ -1848,7 +1904,7 @@ , _label == "fromList" ] liftIO $ take 3 compls' @?= - map Just ["fromList ${1:([Item l])}"] + map Just ["fromList"] ] projectCompletionTests :: [TestTree] @@ -1944,15 +2000,15 @@ , "bar = fo" ] test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , brokenForGhc9 $ testSession "local single line doc without '\\n'" $ do + , testSession "local single line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- |docdoc" , "foo = ()" , "bar = fo" ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\ndocdoc\n"] - , brokenForGhc9 $ testSession "local multi line doc with '\\n'" $ do + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] + , testSession "local multi line doc with '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -1960,8 +2016,8 @@ , "foo = ()" , "bar = fo" ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n abcabc\n"] - , brokenForGhc9 $ testSession "local multi line doc without '\\n'" $ do + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] + , testSession "local multi line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -1970,7 +2026,7 @@ , "foo = ()" , "bar = fo" ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n abcabc\n\ndef\n"] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] , testSession "extern empty doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" @@ -2008,12 +2064,17 @@ test doc pos label mn expected = do _ <- waitForDiagnostics compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + rsp <- request SCompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x let compls' = [ -- We ignore doc uris since it points to the local path which determined by specific machines case mn of Nothing -> txt Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- compls + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- rcompls , _label == label ] liftIO $ compls' @?= expected @@ -2273,17 +2334,13 @@ ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) -ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -ignoreInWindowsForGHC88And810 = - ignoreFor (BrokenSpecific Windows [GHC88, GHC810]) "tests are unreliable in windows for ghc 8.8 and 8.10" +ignoreInWindowsForGHC810 :: TestTree -> TestTree +ignoreInWindowsForGHC810 = + ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" ignoreForGHC92Plus :: String -> TestTree -> TestTree ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94]) -ignoreInWindowsForGHC88 :: TestTree -> TestTree -ignoreInWindowsForGHC88 = - ignoreFor (BrokenSpecific Windows [GHC88]) "tests are unreliable in windows for ghc 8.8" - knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) @@ -2397,6 +2454,34 @@ , "" ] ) + , testCase "ordered list" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) ] where checkHaddock s txt = spanDocToMarkdownForTest s @?= txt @@ -2455,7 +2540,7 @@ dependentFileTest :: TestTree dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [ignoreInWindowsForGHC88 $ testSession' "test" test] + [testGroup "file-changed" [testSession' "test" test] ] where test dir = do @@ -2569,7 +2654,7 @@ checkDefs locs (pure [fooL]) expectNoMoreDiagnostics 0.5 --- Like simpleMultiTest but open the files in component 'a' in a seperate session +-- Like simpleMultiTest but open the files in component 'a' in a separate session simpleMultiDefTest :: TestTree simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do let aPath = dir "a/A.hs" @@ -2646,7 +2731,7 @@ -- Change [TH]a from () to Bool liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - -- Check that the change propogates to C + -- Check that the change propagates to C changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) @@ -2666,26 +2751,25 @@ expectDiagnostics [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - waitForProgressDone - -- Change y from Int to B changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propogates to A + -- save so that we can that the error propagates to A sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - -- Check that the error propogates to A + -- Check that the error propagates to A expectDiagnostics [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - -- Check that we wrote the interfaces for B when we saved hidir <- getInterfaceFilesDir bdoc hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists pdoc <- openDoc pPath "haskell" - waitForProgressDone + expectDiagnostics + [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + ] changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] -- Now in P we have -- bar = x :: Int @@ -3204,7 +3288,7 @@ ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ reverse <$> readIORef orderRef