From f63627fa811a47b1bdc12fa65575ced1519d40c5 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 5 Oct 2022 11:30:16 +0100 Subject: [PATCH] Simplify implementation of eval plugin and make it work with GHC 9.4 The plugin was implemented by calling "load" which circumvents all of HLSs caching mechanisms for interface files and linkables. Instead we should work like the other typechecking functions which get all the stuff we need using HLS rules and setup the HscEnv with all the state in the right places. The key part to this is setting up all the HPT modules with linkables if they are depenedencies of the module we are trying to run a function from. - ban load functions from GHC driver - Enable CI for hls-eval-plugin and fix a bug due to clearing of mi_globals --- .github/workflows/test.yml | 2 +- .hlint.yaml | 10 + ghcide/src/Development/IDE/Core/Compile.hs | 22 -- ghcide/src/Development/IDE/Core/Rules.hs | 1 + ghcide/src/Development/IDE/GHC/Compat.hs | 24 ++ ghcide/src/Development/IDE/GHC/Compat/Core.hs | 2 +- .../Development/IDE/GHC/Compat/Outputable.hs | 8 + ghcide/src/Development/IDE/GHC/Compat/Util.hs | 7 +- haskell-language-server.cabal | 2 +- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 8 - .../src/Ide/Plugin/Eval/Code.hs | 8 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 282 ++++++------------ .../src/Ide/Plugin/Eval/Util.hs | 23 +- plugins/hls-eval-plugin/test/Main.hs | 26 +- 14 files changed, 180 insertions(+), 245 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 43e03c349..a9313b393 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -148,7 +148,7 @@ jobs: name: Test hls-pragmas-plugin run: cabal test hls-pragmas-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-pragmas-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '9.4.4' + - if: matrix.test name: Test hls-eval-plugin run: cabal test hls-eval-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-eval-plugin --test-options="$TEST_OPTS" diff --git a/.hlint.yaml b/.hlint.yaml index 17f0b0baa..2cc24901a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -208,6 +208,16 @@ - name: "GHC.Arr.!" within: [] + # We do not want to use functions from the + # GHC driver. Instead use hls rules to construct + # an appropriate GHC session + - name: "load" + within: [] + - name: "load'" + within: [] + - name: "loadWithCache" + within: [] + # Tracing functions # We ban an explicit list rather than the # Debug.Trace, because that module also diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index d491766cc..9d511e9f4 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -1008,28 +1008,6 @@ handleGenerationErrors' dflags source action = . (("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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 71f278b79..934df8ced 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -57,6 +57,7 @@ module Development.IDE.Core.Rules( typeCheckRuleDefinition, getRebuildCount, getSourceFileSource, + currentLinkables, GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 49f2869a3..4c9ca9c9a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -104,6 +104,7 @@ module Development.IDE.GHC.Compat( icInteractiveModule, HomePackageTable, lookupHpt, + loadModulesHome, #if MIN_VERSION_ghc(9,3,0) Dependencies(dep_direct_mods), #else @@ -653,3 +654,26 @@ combineRealSrcSpans span1 span2 (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 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 4dc0e2211..e4b1b2b6d 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -874,7 +874,7 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr 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 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index f34f03658..10200cd12 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -20,6 +20,13 @@ module Development.IDE.GHC.Compat.Outputable ( #if MIN_VERSION_ghc(9,3,0) DiagnosticReason(..), renderDiagnosticMessageWithHints, + pprMsgEnvelopeBagWithLoc, + Error.getMessages, + renderWithContext, + defaultSDocContext, + errMsgDiagnostic, + unDecorated, + diagnosticMessage, #else pprWarning, pprError, @@ -29,6 +36,7 @@ module Development.IDE.GHC.Compat.Outputable ( MsgEnvelope, ErrMsg, WarnMsg, + SourceError(..), errMsgSpan, errMsgSeverity, formatErrorWithQual, diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index c726bfad4..b0ef8e121 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs @@ -24,9 +24,7 @@ module Development.IDE.GHC.Compat.Util ( LBooleanFormula, BooleanFormula(..), -- * OverridingBool -#if !MIN_VERSION_ghc(9,3,0) OverridingBool(..), -#endif -- * Maybes MaybeErr(..), orElse, @@ -104,6 +102,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/haskell-language-server.cabal b/haskell-language-server.cabal index 587626d3c..1012b86f4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -237,7 +237,7 @@ common haddockComments cpp-options: -Dhls_haddockComments common eval - if flag(eval) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds)) + if flag(eval) build-depends: hls-eval-plugin ^>= 1.4 cpp-options: -Dhls_eval diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 91631564e..0a3204ba4 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -37,10 +37,6 @@ source-repository head location: https://github.com/haskell/haskell-language-server library - if impl(ghc >= 9.3) - buildable: False - else - buildable: True exposed-modules: Ide.Plugin.Eval Ide.Plugin.Eval.Types @@ -101,10 +97,6 @@ library TypeOperators test-suite tests - if impl(ghc >= 9.3) - buildable: False - else - buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index dd109f0b4..10efbd05c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} -- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) import Control.Monad.IO.Class @@ -80,12 +80,6 @@ asStmts (Property t _ _) = ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] --- |GHC declarations required for expression evaluation -evalSetup :: Ghc () -evalSetup = do - preludeAsP <- parseImportDecl "import qualified Prelude as P" - context <- getContext - setContext (IIDecl preludeAsP : context) -- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 160a3924f..08e3586d9 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-type-defaults -Wno-unused-imports #-} {- | A plugin inspired by the REPLoid feature of , 's Examples and Properties and . @@ -29,84 +29,80 @@ import Control.Exception (try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, join, +import Control.Monad (guard, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) import Data.Char (isSpace) -import Data.Default import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse) -import Data.Maybe (catMaybes, - fromMaybe) +import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime) import Data.Typeable (Typeable) -import Development.IDE (GetDependencyInformation (..), - GetLinkable (..), - GetModSummary (..), - GhcSessionIO (..), - IdeState, - ModSummaryResult (..), - NeedsCompilation (NeedsCompilation), - VFSModified (..), - evalGhcEnv, - hscEnvWithImportPaths, - linkableHomeMod, - printOutputable, - runAction, - textToStringBuffer, - toNormalizedFilePath', - uriToFilePath', - useNoFile_, - useWithStale_, - use_, uses_) -import Development.IDE.Core.Rules (GhcSessionDepsConfig (..), - ghcSessionDepsDefinition) +import Development.IDE.Core.RuleTypes + ( NeedsCompilation(NeedsCompilation), + LinkableResult(linkableHomeMod), + tmrTypechecked, + TypeCheck(..)) +import Development.IDE.Core.Rules ( runAction, IdeState ) +import Development.IDE.Core.Shake + ( useWithStale_, + use_, + uses_ ) +import Development.IDE.GHC.Util + ( printOutputable, evalGhcEnv, modifyDynFlags ) +import Development.IDE.Types.Location + ( toNormalizedFilePath', uriToFilePath' ) import Development.IDE.GHC.Compat hiding (typeKind, unitState) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as SrcLoc import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..)) import Development.IDE.Import.DependencyInformation (reachableModules) -import Development.IDE.Types.Options import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, GhcMonad, - LoadHowMuch (LoadAllTargets), NamedThing (getName), defaultFixity, execOptions, exprType, getInfo, getInteractiveDynFlags, - isImport, isStmt, - load, parseName, + isImport, isStmt, parseName, pprFamInst, pprInstance, - setTargets, typeKind) + + +import Development.IDE.Core.RuleTypes + ( ModSummaryResult(msrModSummary), + GetModSummary(GetModSummary), + GhcSessionDeps(GhcSessionDeps), + GetDependencyInformation(GetDependencyInformation), + GetLinkable(GetLinkable) ) +import Development.IDE.Core.Shake ( VFSModified(VFSUnmodified) ) +import Development.IDE.Types.HscEnvEq ( HscEnvEq(hscEnv) ) +import qualified Development.IDE.GHC.Compat.Core as Compat + ( InteractiveImport(IIModule) ) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc + ( unLoc, HasSrcSpan(getLoc) ) #if MIN_VERSION_ghc(9,2,0) -import GHC (Fixity) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Types.Shake (toKey) -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #endif import Ide.Plugin.Eval.Code (Statement, asStatements, - evalSetup, myExecStmt, propSetup, resultRange, @@ -137,16 +133,6 @@ import Language.LSP.Types hiding import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) -#if MIN_VERSION_ghc(9,2,0) -#elif MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Session (unitDatabases, - unitState) -import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) -#else -import DynFlags -#endif - - {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -230,112 +216,22 @@ runEvalCmd plId st EvalParams{..} = let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri - -- enable codegen + -- enable codegen for the module which we need to evaluate. liftIO $ queueForEvaluation st nfp liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval" + -- Setup a session with linkables for all dependencies and GHCi specific options + final_hscEnv <- liftIO $ initialiseSessionForEval + (needsQuickCheck tests) + st nfp - session <- runGetSession st nfp - - ms <- fmap msrModSummary $ - liftIO $ - runAction "runEvalCmd.getModSummary" st $ - use_ GetModSummary nfp - - now <- liftIO getCurrentTime - - let modName = moduleName $ ms_mod ms - thisModuleTarget = - Target - (TargetFile fp Nothing) - False - (Just (textToStringBuffer mdlText, now)) - - -- Setup environment for evaluation - hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do - env <- getSession - - -- Install the module pragmas and options - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - - -- Restore the original import paths - let impPaths = importPaths $ hsc_dflags env - df <- return df{importPaths = impPaths} - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df - - -- property tests need QuickCheck - when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] - dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests - dbg "QUICKCHECK HAS" $ hasQuickCheck df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - -- set the identical DynFlags as GHCi - -- Source: https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483 - -- This needs to be done manually since the default flags are not visible externally. - let df' = flip xopt_set LangExt.ExtendedDefaultRules - . flip xopt_unset LangExt.MonomorphismRestriction - $ idflags - setInteractiveDynFlags $ df' -#if MIN_VERSION_ghc(9,0,0) - { - packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#else - { pkgState = - pkgState - df - , pkgDatabase = - pkgDatabase - df - , packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#endif - - -- Load the module with its current content (as the saved module might not be up to date) - eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] - dbg "setTarget" eSetTarget - - -- load the module in the interactive environment - loadResult <- perf "loadModule" $ load LoadAllTargets - dbg "LOAD RESULT" $ printOutputable loadResult - case loadResult of - Failed -> liftIO $ do - let err = "" - dbg "load ERR" err - return $ Left err - Succeeded -> do - -- Evaluation takes place 'inside' the module - setContext [Compat.IIModule modName] - Right <$> getSession evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId - -- Get linkables for all modules below us - -- This can be optimised to only get the linkables for the symbols depended on by - -- the statement we are parsing - lbs <- liftIO $ runAction "eval: GetLinkables" st $ do - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module - let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } - + -- Perform the evaluation of the command edits <- perf "edits" $ liftIO $ - evalGhcEnv hscEnv'' $ - runTests - evalCfg - (st, fp) - tests + evalGhcEnv final_hscEnv $ do + runTests evalCfg (st, fp) tests let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing @@ -345,6 +241,50 @@ runEvalCmd plId st EvalParams{..} = withIndefiniteProgress "Evaluating" Cancellable $ response' cmd +-- | Create an HscEnv which is suitable for performing interactive evaluation. +-- All necessary home modules will have linkables and the current module will +-- also be loaded into the environment. +-- +-- The interactive context and interactive dynamic flags are also set appropiately. +initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv +initialiseSessionForEval needs_quickcheck st nfp = do + (ms, env1) <- runAction "runEvalCmd" st $ do + + ms <- msrModSummary <$> use_ GetModSummary nfp + deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + + linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp + linkables <- uses_ GetLinkable linkables_needed + -- We unset the global rdr env in mi_globals when we generate interfaces + -- See Note [Clearing mi_globals after generating an iface] + -- However, the eval plugin (setContext specifically) requires the rdr_env + -- for the current module - so get it from the Typechecked Module and add + -- it back to the iface for the current module. + rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp + let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc + addRdrEnv hmi + | iface <- hm_iface hmi + , ms_mod ms == mi_module iface + = hmi { hm_iface = iface { mi_globals = Just rdr_env } } + | otherwise = hmi + + return (ms, linkable_hsc) + -- Bit awkward we need to use evalGhcEnv here but setContext requires to run + -- in the Ghc monad + env2 <- evalGhcEnv env1 $ do + setContext [Compat.IIModule (moduleName (ms_mod ms))] + let df = flip xopt_set LangExt.ExtendedDefaultRules + . flip xopt_unset LangExt.MonomorphismRestriction + . flip gopt_set Opt_ImplicitImportQualified + . flip gopt_unset Opt_DiagnosticsShowCaret + $ (ms_hspp_opts ms) { + useColor = Never + , canUseColor = False } + modifyDynFlags (const df) + when needs_quickcheck $ void $ addPackages ["QuickCheck"] + getSession + return env2 + addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = @@ -374,6 +314,12 @@ testsBySection sections = ] type TEnv = (IdeState, String) +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] runTests EvalConfig{..} e@(_st, _) tests = do @@ -387,7 +333,6 @@ runTests EvalConfig{..} e@(_st, _) tests = do processTest e@(st, fp) df (section, test) = do let dbg = logWith st let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) - rs <- runTest e df test dbg "TEST RESULTS" rs @@ -560,22 +505,6 @@ prettyWarn Warn{..} = T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv -runGetSession st nfp = liftIO $ runAction "eval" st $ do - -- Create a new GHC Session rather than reusing an existing one - -- to avoid interfering with ghcide - -- UPDATE: I suspect that this doesn't really work, we always get the same Session - -- we probably cache hscEnvs in the Session state - IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - let fp = fromNormalizedFilePath nfp - ((_, res),_) <- liftIO $ loadSessionFun fp - let env = fromMaybe (error $ "Unknown file: " <> fp) res - ghcSessionDepsConfig = def - { checkForImportCycles = False - } - res <- fmap hscEnvWithImportPaths <$> ghcSessionDepsDefinition True ghcSessionDepsConfig env nfp - return $ fromMaybe (error $ "Unable to load file: " <> fp) res - needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) @@ -698,20 +627,20 @@ doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) doKindCmd False df arg = do let input = T.strip arg (_, kind) <- typeKind False $ T.unpack input - let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind + let kindText = text (T.unpack input) <+> "::" <+> pprSigmaType kind pure $ Just $ T.pack (showSDoc df kindText) doKindCmd True df arg = do let input = T.strip arg (ty, kind) <- typeKind True $ T.unpack input - let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind - tyDoc = "=" <+> pprTypeForUser ty + let kindDoc = text (T.unpack input) <+> "::" <+> pprSigmaType kind + tyDoc = "=" <+> pprSigmaType ty pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do let (emod, expr) = parseExprMode arg ty <- GHC.exprType emod $ T.unpack expr - let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty + let rawType = T.strip $ T.pack $ showSDoc dflags $ pprSigmaType ty broken = T.any (\c -> c == '\r' || c == '\n') rawType pure $ Just $ @@ -720,7 +649,7 @@ doTypeCmd dflags arg = do T.pack $ showSDoc dflags $ text (T.unpack expr) - $$ nest 2 ("::" <+> pprTypeForUser ty) + $$ nest 2 ("::" <+> pprSigmaType ty) else expr <> " :: " <> rawType <> "\n" parseExprMode :: Text -> (TcRnExprMode, T.Text) @@ -756,22 +685,3 @@ parseGhciLikeCmd input = do (':', rest) <- T.uncons $ T.stripStart input pure $ second T.strip $ T.break isSpace rest -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags -setupDynFlagsForGHCiLike env dflags = do - let dflags3 = setInterpreterLinkerOptions dflags - platform = targetPlatform dflags3 - evalWays = Compat.hostFullWays - dflags3a = setWays evalWays dflags3 - dflags3b = - foldl gopt_set dflags3a $ - concatMap (Compat.wayGeneralFlags platform) evalWays - dflags3c = - foldl gopt_unset dflags3b $ - concatMap (Compat.wayUnsetGeneralFlags platform) evalWays - dflags4 = - dflags3c - `gopt_set` Opt_ImplicitImportQualified - `gopt_set` Opt_IgnoreOptimChanges - `gopt_set` Opt_IgnoreHpcChanges - `gopt_unset` Opt_DiagnosticsShowCaret - Compat.hsc_dflags <$> Compat.initializePlugins (Compat.hscSetFlags dflags4 env) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index a4acb19ca..80e5df641 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -- |Debug utilities module Ide.Plugin.Eval.Util ( @@ -11,7 +12,7 @@ module Ide.Plugin.Eval.Util ( logWith, ) where -import Control.Exception (SomeException, evaluate) +import Control.Exception (SomeException, evaluate, fromException) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (Value (Null)) @@ -19,7 +20,8 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), ideLogger, logPriority) -import Development.IDE.GHC.Compat.Util (MonadCatch, catch) +import Development.IDE.GHC.Compat.Util (MonadCatch, catch, bagToList) +import Development.IDE.GHC.Compat.Outputable import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, @@ -79,4 +81,17 @@ gevaluate :: MonadIO m => a -> m a gevaluate = liftIO . evaluate showErr :: Monad m => SomeException -> m (Either String b) -showErr = return . Left . show +showErr e = +#if MIN_VERSION_ghc(9,3,0) + case fromException e of + -- On GHC 9.4+, the show instance adds the error message span + -- We don't want this for the plugin + -- So render without the span. + Just (SourceError msgs) -> return $ Left $ renderWithContext defaultSDocContext + $ vcat + $ bagToList + $ fmap (vcat . unDecorated . diagnosticMessage . errMsgDiagnostic) + $ getMessages msgs + _ -> +#endif + return . Left . show $ e diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 03df1913f..c33b2c3aa 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -74,29 +74,29 @@ tests = evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ if - | ghcVersion == GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’" | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’" evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input" evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" - , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs" - , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" + , knownBrokenForGhcVersions [GHC92, GHC94] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" - , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" , expectFailBecause "known issue - see a note in P.R. #361" $ - goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , testCase ":type handles a multilined result properly" $ evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ "-- fun", if - | ghcVersion == GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." + | ghcVersion >= GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." | otherwise -> "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", @@ -106,7 +106,7 @@ tests = , testCase ":type does \"dovetails\" for short identifiers" $ evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ if - | ghcVersion == GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." + | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", @@ -125,17 +125,17 @@ tests = , goldenWithEval "Transitive local dependency" "TTransitive" "hs" -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" - , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") , testCase ":set -fprint-explicit-foralls works" $ do evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" - (if ghcVersion == GHC92 + (if ghcVersion >= GHC92 then "-- id :: forall a. a -> a" else "-- id :: forall {a}. a -> a") , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" , goldenWithEval "Property checking" "TProperty" "hs" - , goldenWithEval "Property checking with exception" "TPropertyError" "hs" + , goldenWithEval' "Property checking with exception" "TPropertyError" "hs" (if ghcVersion >= GHC94 then "ghc94.expected" else "expected") , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"