diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -77,7 +77,7 @@ -- stderr recorder just for plugin cli commands pluginCliRecorder <- cmapWithPrio pretty - <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info + <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer @@ -94,7 +94,7 @@ let minPriority = if argsVerbose then Debug else Info - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.9.1.0 +version: 1.10.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -68,14 +68,14 @@ hls-plugin-api ^>= 1.6, lens, list-t, - hiedb == 0.4.2.*, + hiedb == 0.4.3.*, lsp-types ^>= 1.6.0.0, lsp ^>= 1.6.0.0 , mtl, optparse-applicative, parallel, prettyprinter-ansi-terminal, - prettyprinter >= 1.6, + prettyprinter >= 1.7, random, regex-tdfa >= 1.3.1.0, text-rope, @@ -91,7 +91,6 @@ transformers, unordered-containers >= 0.2.10.0, vector, - hslogger, Diff ^>=0.4.0, vector, opentelemetry >=0.6.1, @@ -103,7 +102,7 @@ ghc-check >=0.5.0.8, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios ^>= 0.11.0, + hie-bios == 0.12.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 diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -262,7 +262,7 @@ let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir - libDirRes <- getRuntimeGhcLibDir cradle + libDirRes <- getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do @@ -725,7 +725,7 @@ case cradleRes of CradleSuccess r -> do -- Now get the GHC lib dir - libDirRes <- getRuntimeGhcLibDir cradle + libDirRes <- getRuntimeGhcLibDir logger cradle case libDirRes of -- This is the successful path CradleSuccess libDir -> pure (Right (r, libDir)) diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -10,6 +10,7 @@ , useNoFileE , usesE , workspaceSymbols +, lookupMod ) where import Control.Monad.Reader diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -36,6 +36,7 @@ , TypecheckHelpers(..) ) where +import Control.Monad.IO.Class import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse) import Control.DeepSeq (NFData (..), force, liftRnf, @@ -133,6 +134,11 @@ import qualified GHC.Types.Error as Error #endif +#if MIN_VERSION_ghc(9,5,0) +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Core.Lint.Interactive +#endif + -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions @@ -467,7 +473,11 @@ 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 +#if MIN_VERSION_ghc(9,5,0) + Nothing +#endif + tcGblEnv let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface] pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing @@ -482,20 +492,19 @@ ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm - (details, mguts) <- - if mg_hsc_src simplified_guts == HsBootFile - then do - details <- mkBootModDetailsTc session tcGblEnv - pure (details, Nothing) - else do + (details, guts) <- do -- write core file -- give variables unique OccNames tidy_opts <- initTidyOpts session (guts, details) <- tidyProgram tidy_opts simplified_guts - pure (details, Just guts) + pure (details, guts) #if MIN_VERSION_ghc(9,0,1) - let !partial_iface = force $ mkPartialIface session details + let !partial_iface = force $ mkPartialIface session +#if MIN_VERSION_ghc(9,5,0) + (cg_binds guts) +#endif + details #if MIN_VERSION_ghc(9,3,0) ms #endif @@ -513,9 +522,7 @@ let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface] -- Write the core file now - core_file <- case mguts of - Nothing -> pure Nothing -- no guts, likely boot file - Just guts -> do + core_file <- do let core_fp = ml_core_file $ ms_location ms core_file = codeGutsToCoreFile iface_hash guts iface_hash = getModuleHash final_iface @@ -538,13 +545,23 @@ Just (core, _) | optVerifyCoreFile -> do let core_fp = ml_core_file $ ms_location ms traceIO $ "Verifying " ++ core_fp - let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of - Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists" - Just g -> g + let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts mod = ms_mod ms data_tycons = filter isDataTyCon tycons CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core +#if MIN_VERSION_ghc(9,5,0) + cp_cfg <- initCorePrepConfig session +#endif + + let corePrep = corePrepPgm +#if MIN_VERSION_ghc(9,5,0) + (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session)) +#else + session +#endif + mod (ms_location ms) + -- Run corePrep first as we want to test the final version of the program that will -- get translated to STG/Bytecode #if MIN_VERSION_ghc(9,3,0) @@ -552,13 +569,13 @@ #else (prepd_binds , _) #endif - <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons + <- corePrep unprep_binds data_tycons #if MIN_VERSION_ghc(9,3,0) prepd_binds' #else (prepd_binds', _) #endif - <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons + <- corePrep unprep_binds' data_tycons let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds' @@ -683,7 +700,7 @@ let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) -- TODO: maybe settings ms_hspp_opts is unnecessary? summary' = summary { ms_hspp_opts = hsc_dflags session } - hscInteractive session guts + hscInteractive session (mkCgInteractiveGuts guts) (ms_location summary') let unlinked = BCOs bytecode sptEntries let linkable = LM time (ms_mod summary) [unlinked] @@ -1008,28 +1025,6 @@ . (("Error during " ++ T.unpack source) ++) . show @SomeException ] --- | Load modules, quickly. Input doesn't need to be desugared. --- A module must be loaded before dependent modules can be typechecked. --- This variant of loadModuleHome will *never* cause recompilation, it just --- modifies the session. --- The order modules are loaded is important when there are hs-boot files. --- In particular you should make sure to load the .hs version of a file after the --- .hs-boot version. -loadModulesHome - :: [HomeModInfo] - -> HscEnv - -> HscEnv -loadModulesHome mod_infos e = -#if MIN_VERSION_ghc(9,3,0) - 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 - , hsc_type_env_var = Nothing - } - where - mod_name = moduleName . mi_module . hm_iface -#endif -- Merge the HPTs, module graphs and FinderCaches -- See Note [GhcSessionDeps] in Development.IDE.Core.Rules @@ -1242,7 +1237,9 @@ => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -#if MIN_VERSION_ghc(9,0,1) +#if MIN_VERSION_ghc(9,5,0) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +#elif MIN_VERSION_ghc(9,0,1) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) @@ -1574,13 +1571,13 @@ 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 emptyHomeModInfoLinkable)) session initIfaceLoad hsc' (typecheckIface iface) coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts coreFileToCgGuts session iface details core_file = do let act hpt = addToHpt hpt (moduleName this_mod) - (HomeModInfo iface details Nothing) + (HomeModInfo iface details emptyHomeModInfoLinkable) this_mod = mi_module iface types_var <- newIORef (md_types details) let hsc_env' = hscUpdateHPT act (session { @@ -1594,7 +1591,10 @@ -- Implicit binds aren't saved, so we need to regenerate them ourselves. let implicit_binds = concatMap getImplicitBinds tyCons tyCons = typeEnvTyCons (md_types details) -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,5,0) + -- In GHC 9.6, the implicit binds are tidied and part of core_binds + pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] +#elif MIN_VERSION_ghc(9,3,0) pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #else pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] @@ -1604,9 +1604,9 @@ coreFileToLinkable linkableType session ms iface details core_file t = do cgi_guts <- coreFileToCgGuts session iface details core_file (warns, lb) <- case linkableType of - BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts - ObjectLinkable -> generateObjectCode session ms cgi_guts - pure (warns, HomeModInfo iface details . Just <$> lb) + BCOLinkable -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts + ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts + pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable -- | Non-interactive, batch version of 'InteractiveEval.getDocs'. -- The interactive paths create problems in ghc-lib builds diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -204,7 +204,7 @@ -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work -- and means location information is correct - doCpp env1 True filename out + doCpp env1 filename out liftIO $ Util.hGetStringBuffer out Just contents -> do @@ -218,7 +218,7 @@ let inp = dir "___GHCIDE_MAGIC___" withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents - doCpp env2 True inp out + doCpp env2 inp out -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -57,11 +57,13 @@ typeCheckRuleDefinition, getRebuildCount, getSourceFileSource, + currentLinkables, GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), ) where +import Control.Applicative import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.DeepSeq @@ -160,6 +162,9 @@ import GHC.Unit.Module.Graph import GHC.Unit.Env #endif +#if MIN_VERSION_ghc(9,5,0) +import GHC.Unit.Home.ModInfo +#endif data Log = LogShake Shake.Log @@ -775,7 +780,7 @@ depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps - let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces + let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) 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 descendants of the current module. To get the keys for the descendants @@ -1099,10 +1104,10 @@ else pure Nothing case mobj_time of Just obj_t - | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ 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, and unload old versions - whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do + whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) $ \(LM time mod _) -> do compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction liftIO $ modifyVar compiledLinkables $ \old -> do let !to_keep = extendModuleEnv old mod time diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -307,13 +307,17 @@ getShakeExtras :: Action ShakeExtras getShakeExtras = do + -- Will fail the action with a pattern match failure, but be caught Just x <- getShakeExtra @ShakeExtras return x getShakeExtrasRules :: Rules ShakeExtras getShakeExtrasRules = do - Just x <- getShakeExtraRules @ShakeExtras - return x + mExtras <- getShakeExtraRules @ShakeExtras + case mExtras of + Just x -> return x + -- This will actually crash HLS + Nothing -> liftIO $ fail "missing ShakeExtras" -- | Returns the client configuration, creating a build dependency. -- You should always use this function when accessing client configuration @@ -978,7 +982,10 @@ -- -- Run via 'runIdeAction'. newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup) + +-- https://hub.darcs.net/ross/transformers/issue/86 +deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a) runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -15,6 +15,7 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where +import Control.Monad import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Util import GHC @@ -26,6 +27,11 @@ import qualified DriverPipeline as Pipeline import ToolSettings #endif + +#if MIN_VERSION_ghc(9,5,0) +import qualified GHC.SysTools.Cpp as Pipeline +#endif + #if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Pipeline.Execute as Pipeline #endif @@ -39,11 +45,24 @@ fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } -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 +doCpp :: HscEnv -> FilePath -> FilePath -> IO () +doCpp env input_fn output_fn = + -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850 + -- this function/Pipeline.doCpp previously had a raw parameter + -- always set to True that corresponded to these settings + +#if MIN_VERSION_ghc(9,5,0) + let cpp_opts = Pipeline.CppOpts + { cppUseCc = False + , cppLinePragmas = True + } in #else - Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn + let cpp_opts = True in +#endif + +#if MIN_VERSION_ghc(9,2,0) + Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) cpp_opts input_fn output_fn +#else + Pipeline.doCpp (hsc_dflags env) cpp_opts input_fn output_fn #endif diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -104,6 +104,7 @@ icInteractiveModule, HomePackageTable, lookupHpt, + loadModulesHome, #if MIN_VERSION_ghc(9,3,0) Dependencies(dep_direct_mods), #else @@ -134,6 +135,11 @@ coreExprToBCOs, linkExpr, #endif + extract_cons, + recDotDot, +#if MIN_VERSION_ghc(9,5,0) + XModulePs(..), +#endif ) where import Data.Bifunctor @@ -156,7 +162,15 @@ #if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,5,0) +import GHC.Core.Lint.Interactive (interactiveInScope) +import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) +import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) +import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) +import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) +#else import GHC.Core.Lint (lintInteractiveExpr) +#endif import qualified GHC.Core.Opt.Pipeline as GHC import GHC.Core.Tidy (tidyExpr) import GHC.CoreToStg.Prep (corePrepPgm) @@ -309,7 +323,11 @@ binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") (mkPseudoUniqueE 0) +#if MIN_VERSION_ghc(9,5,0) + ManyTy +#else Many +#endif (exprType prepd_expr) (stg_binds, prov_map, collected_ccs) <- myCoreToStg logger @@ -342,7 +360,13 @@ this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod ml prepd_binds + coreToStg +#if MIN_VERSION_ghc(9,5,0) + (initCoreToStgOpts dflags) +#else + dflags +#endif + this_mod ml prepd_binds #if MIN_VERSION_ghc(9,4,2) (stg_binds2,_) @@ -351,8 +375,14 @@ #endif <- {-# SCC "Stg2Stg" #-} #if MIN_VERSION_ghc(9,3,0) - stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds + stg2stg logger +#if MIN_VERSION_ghc(9,5,0) + (interactiveInScope ictxt) #else + ictxt +#endif + (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds +#else stg2stg logger dflags ictxt this_mod stg_binds #endif @@ -379,10 +409,21 @@ simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr #if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,5,0) +simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env)) +#else simplifyExpr _ = GHC.simplifyExpr +#endif corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +#if MIN_VERSION_ghc(9,5,0) +corePrepExpr _ env exp = do + cfg <- initCorePrepConfig env + GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg exp +#else corePrepExpr _ = GHC.corePrepExpr +#endif + #else simplifyExpr df _ = GHC.simplifyExpr df #endif @@ -574,13 +615,16 @@ | GHC90 | GHC92 | GHC94 + | GHC96 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +ghcVersion = GHC96 +#elif MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) ghcVersion = GHC94 #elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) ghcVersion = GHC92 @@ -652,4 +696,41 @@ (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 +#endif + +-- | Load modules, quickly. Input doesn't need to be desugared. +-- A module must be loaded before dependent modules can be typechecked. +-- This variant of loadModuleHome will *never* cause recompilation, it just +-- modifies the session. +-- The order modules are loaded is important when there are hs-boot files. +-- In particular you should make sure to load the .hs version of a file after the +-- .hs-boot version. +loadModulesHome + :: [HomeModInfo] + -> HscEnv + -> HscEnv +loadModulesHome mod_infos e = +#if MIN_VERSION_ghc(9,3,0) + 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 + , hsc_type_env_var = Nothing + } + where + mod_name = moduleName . mi_module . hm_iface +#endif + +recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int +recDotDot x = +#if MIN_VERSION_ghc(9,5,0) + unRecFieldsDotDot <$> +#endif + unLoc <$> rec_dotdot x + +#if MIN_VERSION_ghc(9,5,0) +extract_cons (NewTypeCon x) = [x] +extract_cons (DataTypeCons _ xs) = xs +#else +extract_cons = id #endif diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -263,7 +263,7 @@ SrcLoc.noSrcSpan, SrcLoc.noSrcLoc, SrcLoc.noLoc, - SrcLoc.mapLoc, + mapLoc, -- * Finder FindResult(..), mkHomeModLocation, @@ -447,6 +447,7 @@ -- * Syntax re-exports #if MIN_VERSION_ghc(9,0,0) module GHC.Hs, + module GHC.Hs.Binds, module GHC.Parser, module GHC.Parser.Header, module GHC.Parser.Lexer, @@ -486,6 +487,15 @@ Extension(..), #endif UniqFM, + mkCgInteractiveGuts, + justBytecode, + justObjects, + emptyHomeModInfoLinkable, + homeModInfoByteCode, + homeModInfoObject, +# if !MIN_VERSION_ghc(9,5,0) + field_label, +#endif ) where import qualified GHC @@ -786,6 +796,7 @@ -- (until the CPP extension is actually needed). import GHC.LanguageExtensions.Type hiding (Cpp) +import GHC.Hs.Binds mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) @@ -872,7 +883,7 @@ pattern FunTy :: Type -> Type -> Type pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(8,10,0) -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) -- type HasSrcSpan x = () :: Constraint @@ -1180,4 +1191,35 @@ type UniqFM = UniqFM.UniqFM #else type UniqFM k = UniqFM.UniqFM +#endif + +#if MIN_VERSION_ghc(9,5,0) +mkVisFunTys = mkScaledFunctionTys +mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b +mapLoc = fmap +#else +mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b +mapLoc = SrcLoc.mapLoc +#endif + + +#if !MIN_VERSION_ghc(9,5,0) +mkCgInteractiveGuts :: CgGuts -> CgGuts +mkCgInteractiveGuts = id + +emptyHomeModInfoLinkable :: Maybe Linkable +emptyHomeModInfoLinkable = Nothing + +justBytecode :: Linkable -> Maybe Linkable +justBytecode = Just + +justObjects :: Linkable -> Maybe Linkable +justObjects = Just + +homeModInfoByteCode, homeModInfoObject :: HomeModInfo -> Maybe Linkable +homeModInfoByteCode = hm_linkable +homeModInfoObject = hm_linkable + +field_label :: a -> a +field_label = id #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -82,7 +82,11 @@ #endif import GHC.Driver.Hooks (Hooks) import GHC.Driver.Session hiding (mkHomeModule) +#if __GLASGOW_HASKELL__ >= 905 +import Language.Haskell.Syntax.Module.Name +#else import GHC.Unit.Module.Name +#endif import GHC.Unit.Types (Module, Unit, UnitId, mkModule) #else import DynFlags @@ -230,7 +234,9 @@ setBytecodeLinkerOptions :: DynFlags -> DynFlags setBytecodeLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) + , backend = noBackend +#elif MIN_VERSION_ghc(9,2,0) , backend = NoBackend #else , hscTarget = HscNothing @@ -241,7 +247,9 @@ setInterpreterLinkerOptions :: DynFlags -> DynFlags setInterpreterLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) + , backend = interpreterBackend +#elif MIN_VERSION_ghc(9,2,0) , backend = Interpreter #else , hscTarget = HscInterpreted diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -49,7 +49,11 @@ -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. logActionCompat :: LogActionCompat -> LogAction +#if MIN_VERSION_ghc(9,5,0) +logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify +#else logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify +#endif logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify #else diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -9,7 +9,6 @@ ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, - mkPrintUnqualified, mkPrintUnqualifiedDefault, PrintUnqualified(..), defaultUserStyle, @@ -17,9 +16,20 @@ -- * Parser errors PsWarning, PsError, +#if MIN_VERSION_ghc(9,5,0) + defaultDiagnosticOpts, + GhcMessage, +#endif #if MIN_VERSION_ghc(9,3,0) DiagnosticReason(..), renderDiagnosticMessageWithHints, + pprMsgEnvelopeBagWithLoc, + Error.getMessages, + renderWithContext, + defaultSDocContext, + errMsgDiagnostic, + unDecorated, + diagnosticMessage, #else pprWarning, pprError, @@ -29,12 +39,14 @@ MsgEnvelope, ErrMsg, WarnMsg, + SourceError(..), errMsgSpan, errMsgSeverity, formatErrorWithQual, mkWarnMsg, mkSrcErr, srcErrorMessages, + textDoc, ) where @@ -80,12 +92,19 @@ import qualified Outputable as Out import SrcLoc #endif +#if MIN_VERSION_ghc(9,5,0) +import GHC.Driver.Errors.Types (GhcMessage) +#endif #if MIN_VERSION_ghc(9,3,0) import Data.Maybe import GHC.Driver.Config.Diagnostic import GHC.Utils.Logger #endif +#if MIN_VERSION_ghc(9,5,0) +type PrintUnqualified = NamePprCtx +#endif + -- | A compatible function to print `Outputable` instances -- without unique symbols. -- @@ -203,7 +222,11 @@ mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualifiedDefault env = -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) + mkNamePprCtx ptc (hsc_unit_env env) + where + ptc = initPromotionTickContext (hsc_dflags env) +#elif MIN_VERSION_ghc(9,2,0) -- GHC 9.2 version -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified (hsc_unit_env env) @@ -212,9 +235,14 @@ #endif #if MIN_VERSION_ghc(9,3,0) -renderDiagnosticMessageWithHints :: Diagnostic a => a -> DecoratedSDoc -renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage a) (mkDecorated $ map ppr $ diagnosticHints a) +renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc +renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc + (diagnosticMessage +#if MIN_VERSION_ghc(9,5,0) + (defaultDiagnosticOpts @a) #endif + a) (mkDecorated $ map ppr $ diagnosticHints a) +#endif #if MIN_VERSION_ghc(9,3,0) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc @@ -235,3 +263,6 @@ #else defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags #endif + +textDoc :: String -> SDoc +textDoc = text diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -120,7 +120,11 @@ #endif #if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,5,0) +pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +#else pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +#endif pattern HsParsedModule { hpm_module , hpm_src_files diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -99,6 +99,7 @@ import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import Data.Map (Map) #endif @@ -400,7 +401,7 @@ #endif isInplace p = Right p -showSDocForUser' :: HscEnv -> GHC.PrintUnqualified -> SDoc -> String +showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> String #if MIN_VERSION_ghc(9,2,0) showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env) #else diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -24,9 +24,7 @@ LBooleanFormula, BooleanFormula(..), -- * OverridingBool -#if !MIN_VERSION_ghc(9,3,0) OverridingBool(..), -#endif -- * Maybes MaybeErr(..), orElse, @@ -103,6 +101,11 @@ import Unique import Util #endif + +#if MIN_VERSION_ghc(9,3,0) +import GHC.Data.Bool +#endif + #if !MIN_VERSION_ghc(9,0,0) type MonadCatch = Exception.ExceptionMonad diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -10,7 +10,8 @@ , typecheckCoreFile , readBinCoreFile , writeBinCoreFile - , getImplicitBinds) where + , getImplicitBinds + , occNamePrefixes) where import Control.Monad import Control.Monad.IO.Class @@ -18,6 +19,7 @@ import Data.IORef import Data.List (isPrefixOf) import Data.Maybe +import qualified Data.Text as T import GHC.Fingerprint import Development.IDE.GHC.Compat @@ -134,8 +136,12 @@ :: Fingerprint -- ^ Hash of the interface this was generated from -> CgGuts -> CoreFile -codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash - +#if MIN_VERSION_ghc(9,5,0) +-- In GHC 9.6, implicit binds are tidied and part of core binds +codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash +#else +codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash +#endif -- | Implicit binds can be generated from the interface and are not tidied, -- so we must filter them out isNotImplictBind :: CoreBind -> Bool @@ -163,21 +169,21 @@ get_defn :: Id -> CoreBind get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) -toIfaceTopBndr :: Module -> Id -> IfaceId -toIfaceTopBndr mod id +toIfaceTopBndr1 :: Module -> Id -> IfaceId +toIfaceTopBndr1 mod id = IfaceId (mangleDeclName mod $ getName id) (toIfaceType (idType id)) (toIfaceIdDetails (idDetails id)) (toIfaceIdInfo (idInfo id)) -toIfaceTopBind :: Module -> Bind Id -> TopIfaceBinding IfaceId -toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIfaceExpr r) -toIfaceTopBind mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs] +toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId +toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r) +toIfaceTopBind1 mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr1 mod b, toIfaceExpr r) | (b,r) <- prs] typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) = initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do - tcTopIfaceBindings type_var prepd_binding + tcTopIfaceBindings1 type_var prepd_binding -- | Internal names can't be serialized, so we mange them -- to an external name and restore at deserialization time @@ -199,9 +205,9 @@ isGhcideName :: Name -> Bool isGhcideName = isGhcideModule . nameModule -tcTopIfaceBindings :: IORef TypeEnv -> [TopIfaceBinding IfaceId] +tcTopIfaceBindings1 :: IORef TypeEnv -> [TopIfaceBinding IfaceId] -> IfL [CoreBind] -tcTopIfaceBindings ty_var ver_decls +tcTopIfaceBindings1 ty_var ver_decls = do int <- mapM (traverse $ tcIfaceId) ver_decls let all_ids = concatMap toList int @@ -228,3 +234,45 @@ tc_iface_bindings (TopIfaceRec vs) = do vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs pure $ Rec vs' + +-- | Prefixes that can occur in a GHC OccName +occNamePrefixes :: [T.Text] +occNamePrefixes = + [ + -- long ones + "$con2tag_" + , "$tag2con_" + , "$maxtag_" + + -- four chars + , "$sel:" + , "$tc'" + + -- three chars + , "$dm" + , "$co" + , "$tc" + , "$cp" + , "$fx" + + -- two chars + , "$W" + , "$w" + , "$m" + , "$b" + , "$c" + , "$d" + , "$i" + , "$s" + , "$f" + , "$r" + , "C:" + , "N:" + , "D:" + , "$p" + , "$L" + , "$f" + , "$t" + , "$c" + , "$m" + ] diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -46,6 +46,9 @@ #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual #endif +#if MIN_VERSION_ghc(9,5,0) +import GHC.Unit.Home.ModInfo +#endif -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable @@ -92,8 +95,10 @@ instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable #endif +#if !MIN_VERSION_ghc(9,5,0) instance (NFData l, NFData e) => NFData (GenLocated l e) where rnf (L l e) = rnf l `seq` rnf e +#endif instance Show ModSummary where show = show . ms_mod @@ -184,8 +189,10 @@ instance Show a => Show (Bag a) where show = show . bagToList +#if !MIN_VERSION_ghc(9,5,0) instance NFData HsDocString where rnf = rwhnf +#endif instance Show ModGuts where show _ = "modguts" @@ -195,7 +202,9 @@ instance NFData (ImportDecl GhcPs) where rnf = rwhnf -#if MIN_VERSION_ghc(9,0,1) +#if MIN_VERSION_ghc(9,5,0) +instance (NFData (HsModule a)) where +#elif MIN_VERSION_ghc(9,0,1) instance (NFData HsModule) where #else instance (NFData (HsModule a)) where @@ -220,5 +229,10 @@ rnf = rwhnf instance NFData NodeKey where + rnf = rwhnf +#endif + +#if MIN_VERSION_ghc(9,5,0) +instance NFData HomeModLinkable where rnf = rwhnf #endif diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -11,6 +11,7 @@ import Control.Monad.IO.Class import Data.Functor +import Data.Foldable (toList) import Data.Generics hiding (Prefix) import Data.Maybe import qualified Data.Text as T @@ -30,7 +31,7 @@ TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL), uriToFilePath) #if MIN_VERSION_ghc(9,2,0) -import Data.List.NonEmpty (nonEmpty, toList) +import Data.List.NonEmpty (nonEmpty) #endif moduleOutline @@ -111,7 +112,7 @@ #if MIN_VERSION_ghc(9,2,0) , _children = List . toList <$> nonEmpty childs } - | con <- dd_cons + | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con , let childs = mapMaybe cvtFld flds , L (locA -> RealSrcSpan l' _) n <- cs @@ -291,7 +292,7 @@ -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (names, flds) + -> (toList names, flds) where flds = get_flds_gadt args @@ -318,3 +319,5 @@ -> ([LFieldOcc GhcPs]) get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) #endif + + diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -106,8 +106,13 @@ -- Drop any explicit imports in ImportDecl if not hidden dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let +#if MIN_VERSION_ghc(9,5,0) + f d@ImportDecl {ideclImportList} = case ideclImportList of + Just (Exactly, _) -> d {ideclImportList=Nothing} +#else f d@ImportDecl {ideclHiding} = case ideclHiding of Just (False, _) -> d {ideclHiding=Nothing} +#endif -- if hiding or Nothing just return d _ -> d f x = x diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -41,6 +41,7 @@ import Development.IDE.GHC.Compat hiding (ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -74,6 +75,10 @@ import Development.IDE.Spans.AtPoint (pointCommand) +#if MIN_VERSION_ghc(9,5,0) +import Language.Haskell.Syntax.Basic +#endif + -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int chunkSize = 1000 @@ -137,17 +142,29 @@ importGo :: GHC.LImportDecl GhcPs -> Maybe Context importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r +#if MIN_VERSION_ghc(9,5,0) + = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) +#else = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) +#endif <|> Just (ImportContext importModuleName) | otherwise = Nothing where importModuleName = moduleNameString $ unLoc $ ideclName impDecl - importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context + -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context +#if MIN_VERSION_ghc(9,5,0) + importInline modName (Just (EverythingBut, L r _)) +#else importInline modName (Just (True, L r _)) +#endif | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing +#if MIN_VERSION_ghc(9,5,0) + importInline modName (Just (Exactly, L r _)) +#else importInline modName (Just (False, L r _)) +#endif | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing importInline _ _ = Nothing @@ -383,7 +400,7 @@ | isDataConName n , Just flds <- Map.lookup parent fieldMap , not (null flds) -> - [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS) flds) (ImportedFrom mn) imp'] + [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS . field_label) flds) (ImportedFrom mn) imp'] _ -> [] in mkNameCompItem uri mbParent originName (ImportedFrom mn) Nothing imp' (nameModule_maybe n) @@ -466,7 +483,7 @@ where result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName) (printOutputable . unLoc $ con_name) field_labels mn Nothing - | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn + | ConDeclH98{..} <- unLoc <$> (extract_cons $ dd_cons tcdDataDefn) , Just con_details <- [getFlds con_args] , let field_names = concatMap extract con_details , let field_labels = printOutputable <$> field_names @@ -767,50 +784,7 @@ -- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. stripPrefix :: T.Text -> T.Text stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $ - getFirst $ foldMap (First . (`T.stripPrefix` name)) prefixes - --- | Prefixes that can occur in a GHC OccName -prefixes :: [T.Text] -prefixes = - [ - -- long ones - "$con2tag_" - , "$tag2con_" - , "$maxtag_" - - -- four chars - , "$sel:" - , "$tc'" - - -- three chars - , "$dm" - , "$co" - , "$tc" - , "$cp" - , "$fx" - - -- two chars - , "$W" - , "$w" - , "$m" - , "$b" - , "$c" - , "$d" - , "$i" - , "$s" - , "$f" - , "$r" - , "C:" - , "N:" - , "D:" - , "$p" - , "$L" - , "$f" - , "$t" - , "$c" - , "$m" - ] - + getFirst $ foldMap (First . (`T.stripPrefix` name)) occNamePrefixes mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -20,6 +20,8 @@ , getNamesAtPoint , toCurrentLocation , rowToLoc + , nameToLocation + , LookupModule ) where import Development.IDE.GHC.Error @@ -225,10 +227,19 @@ wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" info = nodeInfoH kind ast names = M.assocs $ nodeIdentifiers info + -- Check for evidence bindings + isInternal :: (Identifier, IdentifierDetails a) -> Bool + isInternal (Right _, dets) = +#if MIN_VERSION_ghc(9,0,1) + any isEvidenceContext $ identInfo dets +#else + False +#endif + isInternal (Left _, _) = False + filteredNames = filter (not . isInternal) names types = nodeType info - prettyNames :: [T.Text] - prettyNames = map prettyName names + prettyNames = map prettyName filteredNames prettyName (Right n, dets) = T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -34,7 +34,11 @@ type KindMap = NameEnv TyThing -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. +#if MIN_VERSION_ghc(9,5,0) +unqualIEWrapName :: IEWrappedName GhcPs -> T.Text +#else unqualIEWrapName :: IEWrappedName RdrName -> T.Text +#endif unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName -- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -51,9 +51,9 @@ instance Show ExportsMap where show (ExportsMap occs mods) = unwords [ "ExportsMap { getExportsMap =" - , printWithoutUniques $ mapOccEnv (text . show) occs + , printWithoutUniques $ mapOccEnv (textDoc . show) occs , "getModuleExportsMap =" - , printWithoutUniques $ mapUFM (text . show) mods + , printWithoutUniques $ mapUFM (textDoc . show) mods , "}" ] diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -19,7 +19,7 @@ , cfilter , withDefaultRecorder , makeDefaultStderrRecorder - , priorityToHsLoggerPriority + , makeDefaultHandleRecorder , LoggingColumn(..) , cmapWithPrio , withBacklog @@ -39,8 +39,7 @@ readTVarIO, writeTBQueue, writeTVar) import Control.Exception (IOException) -import Control.Monad (forM_, unless, when, - (>=>)) +import Control.Monad (unless, when, (>=>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Foldable (for_) import Data.Functor.Contravariant (Contravariant (contramap)) @@ -76,12 +75,7 @@ import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, - hSetEncoding, openFile, - stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger + openFile, stderr) import UnliftIO (MonadUnliftIO, displayException, finally, try) @@ -170,31 +164,24 @@ Recorder { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } --- | Priority is actually for hslogger compatibility -makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a))) -makeDefaultStderrRecorder columns minPriority = do +makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a))) +makeDefaultStderrRecorder columns = do lock <- liftIO newLock - makeDefaultHandleRecorder columns minPriority lock stderr + makeDefaultHandleRecorder columns lock stderr -- | If no path given then use stderr, otherwise use file. --- Kinda complicated because we also need to setup `hslogger` for --- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our --- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can --- be removed completely. See `setupHsLogger` comment. withDefaultRecorder :: MonadUnliftIO m => Maybe FilePath -- ^ Log file path. `Nothing` uses stderr -> Maybe [LoggingColumn] -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` - -> Priority - -- ^ min priority for hslogger compatibility -> (Recorder (WithPriority (Doc d)) -> m a) -- ^ action given a recorder -> m a -withDefaultRecorder path columns minPriority action = do +withDefaultRecorder path columns action = do lock <- liftIO newLock - let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock + let makeHandleRecorder = makeDefaultHandleRecorder columns lock case path of Nothing -> do recorder <- makeHandleRecorder stderr @@ -216,64 +203,19 @@ :: MonadIO m => Maybe [LoggingColumn] -- ^ built-in logging columns to display. Nothing uses the default - -> Priority - -- ^ min priority for hslogger compatibility -> Lock -- ^ lock to take when outputting to handle -> Handle -- ^ handle to output to -> m (Recorder (WithPriority (Doc a))) -makeDefaultHandleRecorder columns minPriority lock handle = do +makeDefaultHandleRecorder columns lock handle = do let Recorder{ logger_ } = textHandleRecorder handle let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } let loggingColumns = fromMaybe defaultLoggingColumns columns let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder - -- see `setupHsLogger` comment - liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority) pure (cmap docToText textWithPriorityRecorder) where docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) - -priorityToHsLoggerPriority :: Priority -> HsLogger.Priority -priorityToHsLoggerPriority = \case - Debug -> HsLogger.DEBUG - Info -> HsLogger.INFO - Warning -> HsLogger.WARNING - Error -> HsLogger.ERROR - --- | The purpose of setting up `hslogger` at all is that `hie-bios` uses --- `hslogger` to output compilation logs. The easiest way to merge these logs --- with our log output is to setup an `hslogger` that uses the same handle --- and same lock as our loggers. That way the output from our loggers and --- `hie-bios` don't interleave strangely. --- It may be possible to have `hie-bios` use our logger by decorating the --- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from --- `HieBios.findCradle`, but I remember trying that and something not good --- happened. I'd have to try it again to remember if that was a real issue. --- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all --- references to `hslogger` can be removed entirely. -setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO () -setupHsLogger lock handle extraLogNames level = do - hSetEncoding handle utf8 - - logH <- HSL.streamHandler handle level - - let logHandle = logH - { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s } - logFormatter = HSL.tfLogFormatter logDateFormat logFormat - logHandler = HSL.setFormatter logHandle logFormatter - - HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle]) - HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler] - HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level - - -- Also route the additional log names to the same log - forM_ extraLogNames $ \logName -> do - HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler] - HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level - where - logFormat = "$time [$tid] $prio $loggername:\t$msg" - logDateFormat = "%Y-%m-%d %H:%M:%S%Q" data LoggingColumn = TimeColumn diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs --- a/test/data/hover/GotoHover.hs +++ b/test/data/hover/GotoHover.hs @@ -64,3 +64,7 @@ hole2 :: a -> Maybe a hole2 = _ + +-- A comment above a type defnition with a deriving clause +data Example = Example + deriving (Eq) diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal --- a/test/data/multi/a/a.cabal +++ b/test/data/multi/a/a.cabal @@ -4,6 +4,6 @@ cabal-version: >= 1.2 library - build-depends: base, async + build-depends: base, async >= 2.0 exposed-modules: A hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project --- a/test/data/multi/cabal.project +++ b/test/data/multi/cabal.project @@ -1,1 +1,3 @@ packages: a b c + +allow-newer: base diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/a-1.0.0/t/a-test/build/a-test/autogen/Paths_a.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0-inplace-a-test" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/a-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/b-1.0.0/build/autogen/Paths_b.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_b ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/b-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-linux/ghc-9.4.0.20220623/c-1.0.0/build/autogen/Paths_c.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -w #-} +module Paths_c ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + + +import qualified Control.Exception as Exception +import qualified Data.List as List +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir `joinFileName` name) + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath + + + +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath +bindir = "/home/zubin/.cabal/bin" +libdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0-inplace" +dynlibdir = "/home/zubin/.cabal/lib/x86_64-linux-ghc-9.4.0.20220623" +datadir = "/home/zubin/.cabal/share/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" +libexecdir = "/home/zubin/.cabal/libexec/x86_64-linux-ghc-9.4.0.20220623/c-1.0.0" +sysconfdir = "/home/zubin/.cabal/etc" + +getBinDir = catchIO (getEnv "c_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "c_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "c_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "c_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "c_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "c_sysconfdir") (\_ -> return sysconfdir) + + + + +joinFileName :: String -> String -> FilePath +joinFileName "" fname = fname +joinFileName "." fname = fname +joinFileName dir "" = dir +joinFileName dir fname + | isPathSeparator (List.last dir) = dir ++ fname + | otherwise = dir ++ pathSeparator : fname + +pathSeparator :: Char +pathSeparator = '/' + +isPathSeparator :: Char -> Bool +isPathSeparator c = c == '/' diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -200,7 +200,7 @@ main :: IO () main = do - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) let docWithFilteredPriorityRecorder@Recorder{ logger_ } = docWithPriorityRecorder @@ -596,13 +596,19 @@ expectDiagnostics [ ( "Main.hs" , [(DsError, (6, 9), - if ghcVersion >= GHC94 - then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else "Not in scope: \8216ThisList.map\8217") + if ghcVersion >= GHC96 then + "Variable not in scope: ThisList.map" + else if ghcVersion >= GHC94 then + "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216ThisList.map\8217") ,(DsError, (7, 9), - if ghcVersion >= GHC94 - then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else "Not in scope: \8216BaseList.x\8217") + if ghcVersion >= GHC96 then + "Variable not in scope: BaseList.x" + else if ghcVersion >= GHC94 then + "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216BaseList.x\8217") ] ) ] @@ -950,7 +956,7 @@ , ("head = 233", "head :: Integer") , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") - , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") + , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") ] @@ -1026,6 +1032,7 @@ ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover _ -> pure () -- all other expectations not relevant to hover @@ -1054,6 +1061,11 @@ (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) (part `T.isInfixOf` whole) + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + sourceFilePath = T.unpack sourceFileName sourceFileName = "GotoHover.hs" @@ -1130,6 +1142,7 @@ imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] in mkFindTests -- def hover look expect @@ -1173,6 +1186,7 @@ , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" + , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" , if ghcVersion >= GHC90 then test no yes docL41 constr "type constraint in hover info #1012" else @@ -1234,6 +1248,7 @@ -- 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 (BrokenForGHC [GHC96]) "fragile, frequently times out" $ 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" @@ -1768,7 +1783,7 @@ [] ] where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94]) "Windows has strange things in scope for some reason" + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ @@ -2000,7 +2015,7 @@ , "bar = fo" ] test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , testSession "local single line doc without '\\n'" $ do + , testSession "local single line doc without newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- |docdoc" @@ -2008,7 +2023,7 @@ , "bar = fo" ] 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 + , testSession "local multi line doc with newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -2017,7 +2032,7 @@ , "bar = fo" ] 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 + , testSession "local multi line doc without newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -2057,10 +2072,10 @@ test doc (Position 1 7) "id" (Just $ T.length expected) [expected] ] where - brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9" + brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9" brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2" -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9" + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" test doc pos label mn expected = do _ <- waitForDiagnostics compls <- getCompletions doc pos @@ -2108,7 +2123,7 @@ , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] - , knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $ + , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics @@ -2339,7 +2354,7 @@ ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" ignoreForGHC92Plus :: String -> TestTree -> TestTree -ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94]) +ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) @@ -2390,6 +2405,7 @@ -- | ExpectDefRange Range -- Only gotoDef should report this range | ExpectHoverRange Range -- Only hover should report this range | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets | ExpectHoverTextRegex T.Text -- the hover message must match this pattern | ExpectExternFail -- definition lookup in other file expected to fail | ExpectNoDefinitions