ghcide 1.8.0.0 → 1.9.0.0
raw patch · 54 files changed
+1308/−1797 lines, 54 filesdep +implicit-hiedep −heapsizedep ~ghcdep ~haddock-librarydep ~hie-bios
Dependencies added: implicit-hie
Dependencies removed: heapsize
Dependency ranges changed: ghc, haddock-library, hie-bios, hiedb, hls-graph, hls-plugin-api, unordered-containers
Files
- CHANGELOG.md +2/−2
- README.md +1/−19
- exe/Main.hs +2/−3
- ghcide.cabal +19/−25
- session-loader/Development/IDE/Session.hs +9/−9
- src/Development/IDE.hs +3/−2
- src/Development/IDE/Core/Compile.hs +83/−112
- src/Development/IDE/Core/FileStore.hs +1/−2
- src/Development/IDE/Core/Preprocessor.hs +27/−22
- src/Development/IDE/Core/RuleTypes.hs +7/−1
- src/Development/IDE/Core/Rules.hs +27/−32
- src/Development/IDE/Core/Shake.hs +73/−41
- src/Development/IDE/Core/Tracing.hs +8/−170
- src/Development/IDE/GHC/CPP.hs +4/−21
- src/Development/IDE/GHC/Compat.hs +44/−88
- src/Development/IDE/GHC/Compat/CPP.hs +0/−204
- src/Development/IDE/GHC/Compat/Core.hs +91/−142
- src/Development/IDE/GHC/Compat/Env.hs +5/−5
- src/Development/IDE/GHC/Compat/Iface.hs +1/−1
- src/Development/IDE/GHC/Compat/Logger.hs +1/−1
- src/Development/IDE/GHC/Compat/Outputable.hs +12/−3
- src/Development/IDE/GHC/Compat/Parser.hs +1/−1
- src/Development/IDE/GHC/Compat/Plugins.hs +55/−29
- src/Development/IDE/GHC/Compat/Units.hs +4/−4
- src/Development/IDE/GHC/Compat/Util.hs +1/−5
- src/Development/IDE/GHC/CoreFile.hs +1/−1
- src/Development/IDE/GHC/Error.hs +6/−0
- src/Development/IDE/GHC/Orphans.hs +3/−8
- src/Development/IDE/GHC/Util.hs +18/−12
- src/Development/IDE/GHC/Warnings.hs +3/−3
- src/Development/IDE/Import/FindImports.hs +5/−4
- src/Development/IDE/LSP/Outline.hs +0/−4
- src/Development/IDE/Main.hs +22/−67
- src/Development/IDE/Main/HeapStats.hs +2/−2
- src/Development/IDE/Plugin/Completions.hs +108/−39
- src/Development/IDE/Plugin/Completions/Logic.hs +196/−172
- src/Development/IDE/Plugin/Completions/Types.hs +89/−15
- src/Development/IDE/Plugin/HLS.hs +56/−26
- src/Development/IDE/Plugin/HLS/GhcIde.hs +1/−1
- src/Development/IDE/Plugin/TypeLenses.hs +4/−4
- src/Development/IDE/Spans/AtPoint.hs +0/−4
- src/Development/IDE/Spans/Common.hs +9/−3
- src/Development/IDE/Spans/Documentation.hs +18/−15
- src/Development/IDE/Spans/Pragmas.hs +26/−21
- src/Development/IDE/Types/Action.hs +2/−2
- src/Development/IDE/Types/Exports.hs +114/−90
- src/Development/IDE/Types/Options.hs +0/−4
- src/Development/IDE/Types/Shake.hs +3/−3
- src/Text/Fuzzy/Parallel.hs +2/−2
- test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs +0/−74
- 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 +0/−74
- test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs +0/−74
- test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs +0/−74
- test/exe/Main.hs +139/−55
CHANGELOG.md view
@@ -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
README.md view
@@ -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
exe/Main.hs view
@@ -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
ghcide.cabal view
@@ -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
session-loader/Development/IDE/Session.hs view
@@ -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
src/Development/IDE.hs view
@@ -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,
src/Development/IDE/Core/Compile.hs view
@@ -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 "<ghcide>") 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
src/Development/IDE/Core/FileStore.hs view
@@ -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
src/Development/IDE/Core/Preprocessor.hs view
@@ -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
src/Development/IDE/Core/RuleTypes.hs view
@@ -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
src/Development/IDE/Core/Rules.hs view
@@ -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
src/Development/IDE/Core/Shake.hs view
@@ -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
src/Development/IDE/Core/Tracing.hs view
@@ -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
src/Development/IDE/GHC/CPP.hs view
@@ -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
src/Development/IDE/GHC/Compat.hs view
@@ -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 ()
− src/Development/IDE/GHC/Compat/CPP.hs
@@ -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
src/Development/IDE/GHC/Compat/Core.hs view
@@ -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
src/Development/IDE/GHC/Compat/Env.hs view
@@ -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)
src/Development/IDE/GHC/Compat/Iface.hs view
@@ -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
src/Development/IDE/GHC/Compat/Logger.hs view
@@ -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
src/Development/IDE/GHC/Compat/Outputable.hs view
@@ -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
src/Development/IDE/GHC/Compat/Parser.hs view
@@ -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,
src/Development/IDE/GHC/Compat/Plugins.hs view
@@ -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
src/Development/IDE/GHC/Compat/Units.hs view
@@ -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)
src/Development/IDE/GHC/Compat/Util.hs view
@@ -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
src/Development/IDE/GHC/CoreFile.hs view
@@ -38,7 +38,7 @@ import GHC.Driver.Types #endif -#elif MIN_VERSION_ghc(8,6,0)+#else import Binary import BinFingerprint (fingerprintBinMem) import BinIface
src/Development/IDE/GHC/Error.hs view
@@ -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).
src/Development/IDE/GHC/Orphans.hs view
@@ -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
src/Development/IDE/GHC/Util.hs view
@@ -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
src/Development/IDE/GHC/Warnings.hs view
@@ -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}
src/Development/IDE/Import/FindImports.hs view
@@ -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 ->
src/Development/IDE/LSP/Outline.hs view
@@ -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
src/Development/IDE/Main.hs view
@@ -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
src/Development/IDE/Main/HeapStats.hs view
@@ -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
src/Development/IDE/Plugin/Completions.hs view
@@ -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).
src/Development/IDE/Plugin/Completions/Logic.hs view
@@ -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)
src/Development/IDE/Plugin/Completions/Types.hs view
@@ -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)
src/Development/IDE/Plugin/HLS.hs view
@@ -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)
src/Development/IDE/Plugin/HLS/GhcIde.hs view
@@ -54,7 +54,7 @@ <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), - pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False}+ pluginConfigDescriptor = defaultConfigDescriptor } -- ---------------------------------------------------------------------
src/Development/IDE/Plugin/TypeLenses.hs view
@@ -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)
src/Development/IDE/Spans/AtPoint.hs view
@@ -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)
src/Development/IDE/Spans/Common.hs view
@@ -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)
src/Development/IDE/Spans/Documentation.hs view
@@ -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
src/Development/IDE/Spans/Pragmas.hs view
@@ -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
src/Development/IDE/Types/Action.hs view
@@ -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
src/Development/IDE/Types/Exports.hs view
@@ -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]
src/Development/IDE/Types/Options.hs view
@@ -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
src/Development/IDE/Types/Shake.hs view
@@ -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)
src/Text/Fuzzy/Parallel.hs view
@@ -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
− test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs
@@ -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 == '/'
− 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
@@ -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 == '/'
− test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs
@@ -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 == '/'
− test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs
@@ -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 == '/'
test/exe/Main.hs view
@@ -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