mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-08-16 20:10:30 +03:00
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
This commit is contained in:
Matthew Pickering
wz1000
parent
a73c07c51b
commit
f63627fa81
2
.github/workflows/test.yml
vendored
2
.github/workflows/test.yml
vendored
@ -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"
|
||||
|
||||
|
||||
10
.hlint.yaml
10
.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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -57,6 +57,7 @@ module Development.IDE.Core.Rules(
|
||||
typeCheckRuleDefinition,
|
||||
getRebuildCount,
|
||||
getSourceFileSource,
|
||||
currentLinkables,
|
||||
GhcSessionDepsConfig(..),
|
||||
Log(..),
|
||||
DisplayTHWarning(..),
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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 <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user