hls-eval-plugin 2.0.0.1 → 2.1.0.0
raw patch · 9 files changed
+222/−195 lines, 9 filesdep +bytestringdep +row-typesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utilsPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, row-types
Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils
API changes (from Hackage documentation)
+ Ide.Plugin.Eval.Types: IsEvaluating :: IsEvaluating
+ Ide.Plugin.Eval.Types: data IsEvaluating
+ Ide.Plugin.Eval.Types: instance Control.DeepSeq.NFData Ide.Plugin.Eval.Types.IsEvaluating
+ Ide.Plugin.Eval.Types: instance Data.Hashable.Class.Hashable Ide.Plugin.Eval.Types.IsEvaluating
+ Ide.Plugin.Eval.Types: instance GHC.Classes.Eq Ide.Plugin.Eval.Types.IsEvaluating
+ Ide.Plugin.Eval.Types: instance GHC.Generics.Generic Ide.Plugin.Eval.Types.IsEvaluating
+ Ide.Plugin.Eval.Types: instance GHC.Show.Show Ide.Plugin.Eval.Types.IsEvaluating
Files
- hls-eval-plugin.cabal +6/−4
- src/Ide/Plugin/Eval.hs +13/−13
- src/Ide/Plugin/Eval/Code.hs +17/−17
- src/Ide/Plugin/Eval/CodeLens.hs +67/−68
- src/Ide/Plugin/Eval/Parse/Comments.hs +15/−18
- src/Ide/Plugin/Eval/Rules.hs +22/−12
- src/Ide/Plugin/Eval/Types.hs +11/−3
- src/Ide/Plugin/Eval/Util.hs +46/−38
- test/Main.hs +25/−22
hls-eval-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin-version: 2.0.0.1+version: 2.1.0.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -55,6 +55,7 @@ build-depends: , aeson , base >=4.12 && <5+ , bytestring , containers , data-default , deepseq@@ -66,10 +67,10 @@ , ghc , ghc-boot-th , ghc-paths- , ghcide == 2.0.0.1+ , ghcide == 2.1.0.0 , hashable , hls-graph- , hls-plugin-api == 2.0.0.1+ , hls-plugin-api == 2.1.0.0 , lens , lsp , lsp-types@@ -111,7 +112,8 @@ , filepath , hls-eval-plugin , hls-plugin-api- , hls-test-utils == 2.0.0.1+ , hls-test-utils == 2.1.0.0 , lens , lsp-types , text+ , row-types
src/Ide/Plugin/Eval.hs view
@@ -11,19 +11,19 @@ Log(..) ) where -import Development.IDE (IdeState)-import Development.IDE.Types.Logger (Pretty (pretty), Recorder,- WithPriority, cmapWithPrio)-import qualified Ide.Plugin.Eval.CodeLens as CL+import Development.IDE (IdeState)+import Ide.Logger (Pretty (pretty), Recorder,+ WithPriority, cmapWithPrio)+import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config-import Ide.Plugin.Eval.Rules (rules)-import qualified Ide.Plugin.Eval.Rules as EvalRules-import Ide.Types (ConfigDescriptor (..),- PluginDescriptor (..), PluginId,- defaultConfigDescriptor,- defaultPluginDescriptor,- mkCustomConfig, mkPluginHandler)-import Language.LSP.Types+import Ide.Plugin.Eval.Rules (rules)+import qualified Ide.Plugin.Eval.Rules as EvalRules+import Ide.Types (ConfigDescriptor (..),+ PluginDescriptor (..), PluginId,+ defaultConfigDescriptor,+ defaultPluginDescriptor,+ mkCustomConfig, mkPluginHandler)+import Language.LSP.Protocol.Message newtype Log = LogEvalRules EvalRules.Log deriving Show @@ -35,7 +35,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId)- { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens+ { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand plId] , pluginRules = rules (cmapWithPrio LogEvalRules recorder) , pluginConfigDescriptor = defaultConfigDescriptor
src/Ide/Plugin/Eval/Code.hs view
@@ -6,28 +6,28 @@ -- | Expression execution module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where -import Control.Lens ((^.))+import Control.Lens ((^.)) import Control.Monad.IO.Class-import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff)-import qualified Data.List.NonEmpty as NE-import Data.String (IsString)-import qualified Data.Text as T+import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff)+import qualified Data.List.NonEmpty as NE+import Data.String (IsString)+import qualified Data.Text as T import Development.IDE.GHC.Compat-import Development.IDE.Types.Location (Position (..), Range (..))-import GHC (ExecOptions, ExecResult (..),- execStmt)-import Ide.Plugin.Eval.Types (Language (Plain), Loc,- Located (..),- Section (sectionLanguage),- Test (..), Txt, locate,- locate0)-import Language.LSP.Types.Lens (line, start)-import System.IO.Extra (newTempFile, readFile')+import GHC (ExecOptions, ExecResult (..),+ execStmt)+import Ide.Plugin.Eval.Types (Language (Plain), Loc,+ Located (..),+ Section (sectionLanguage),+ Test (..), Txt, locate, locate0)+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Types (Position (Position),+ Range (Range))+import System.IO.Extra (newTempFile, readFile') -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range) testRanges tst =- let startLine = testRange tst ^. start.line+ let startLine = testRange tst ^. L.start . L.line (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst resLine = startLine + exprLines in ( Range@@ -72,7 +72,7 @@ type Statement = Loc String asStatements :: Test -> [Statement]-asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt)+asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. L.start . L.line) (asStmts lt) asStmts :: Test -> [Txt] asStmts (Example e _ _) = NE.toList e
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -25,46 +25,46 @@ import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second, (>>>))-import Control.Exception (try)+import Control.Exception (try, bracket_) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.))-import Control.Monad (guard,- void, when)+import Control.Monad (guard, void,+ when) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Except (ExceptT (..))+import Control.Monad.Trans.Except (ExceptT (..),+ runExceptT) import Data.Aeson (toJSON) import Data.Char (isSpace) import Data.Foldable (toList)-import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse)+import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable)-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.Core.Rules (IdeState,+ runAction)+import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod),+ NeedsCompilation (NeedsCompilation),+ TypeCheck (..),+ tmrTypechecked)+import Development.IDE.Core.Shake (useWithStale_, useNoFile_,+ use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..))-import Development.IDE.Import.DependencyInformation (reachableModules)+import Development.IDE.GHC.Util (evalGhcEnv,+ modifyDynFlags,+ printOutputable)+import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps)+import Development.IDE.Types.Location (toNormalizedFilePath',+ uriToFilePath') import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst,@@ -75,33 +75,36 @@ exprType, getInfo, getInteractiveDynFlags,- isImport, isStmt, parseName,+ isImport, isStmt,+ parseName, pprFamInst, pprInstance, 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) )+import Development.IDE.Core.RuleTypes (GetModuleGraph (GetModuleGraph),+ GetLinkable (GetLinkable),+ GetModSummary (GetModSummary),+ GhcSessionDeps (GhcSessionDeps),+ ModSummaryResult (msrModSummary))+import Development.IDE.Core.Shake (VFSModified (VFSUnmodified))+import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule))+import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc),+ unLoc)+import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) #if MIN_VERSION_ghc(9,2,0) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) import Development.IDE.Core.FileStore (setSomethingModified)+import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #endif+import Ide.Plugin.Error (PluginError (PluginInternalError),+ handleMaybe,+ handleMaybeM) import Ide.Plugin.Eval.Code (Statement, asStatements, myExecStmt,@@ -117,39 +120,35 @@ showDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (parseSetFlags)-import Ide.Plugin.Eval.Rules (queueForEvaluation)+import Ide.Plugin.Eval.Rules (queueForEvaluation, unqueueForEvaluation) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, logWith, response', timed)-import Ide.PluginUtils (handleMaybe,- handleMaybeM,- pluginResponse) import Ide.Types+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types import Language.LSP.Server-import Language.LSP.Types hiding- (SemanticTokenAbsolute (length, line),- SemanticTokenRelative (length))-import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -}-codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens+codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg in perf "codeLens" $- pluginResponse $ do+ do let TextDocumentIdentifier uri = _textDocument- fp <- handleMaybe "uri" $ uriToFilePath' uri+ fp <- uriToFilePathE uri let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp dbg "fp" fp- (comments, _) <- liftIO $- runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetEvalComments nfp+ (comments, _) <-+ runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp -- dbg "excluded comments" $ show $ DL.toList $ -- foldMap (\(L a b) -> -- case b of@@ -171,7 +170,7 @@ args = EvalParams (setupSections ++ [section]) _textDocument ident cmd' = (cmd :: Command)- { _arguments = Just (List [toJSON args])+ { _arguments = Just [toJSON args] , _title = if trivial resultRange then "Evaluate..."@@ -192,7 +191,7 @@ , "lenses." ] - return $ List lenses+ return $ InL lenses where trivial (Range p p') = p == p' @@ -208,22 +207,22 @@ runEvalCmd plId st EvalParams{..} = let dbg = logWith st perf = timed dbg- cmd :: ExceptT String (LspM Config) WorkspaceEdit+ cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections let TextDocumentIdentifier{_uri} = module_- fp <- handleMaybe "uri" $ uriToFilePath' _uri+ fp <- uriToFilePathE _uri let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri -- 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+ final_hscEnv <- liftIO $ bracket_+ (do queueForEvaluation st nfp+ setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")+ (do unqueueForEvaluation st nfp+ setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")+ (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId @@ -234,13 +233,13 @@ evalGhcEnv final_hscEnv $ do runTests evalCfg (st, fp) tests - let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)]+ let workspaceEditsMap = Map.fromList [(_uri, addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing return workspaceEdits- in perf "evalCmd" $+ in perf "evalCmd" $ ExceptT $ withIndefiniteProgress "Evaluating" Cancellable $- response' cmd+ runExceptT $ response' cmd -- | Create an HscEnv which is suitable for performing interactive evaluation. -- All necessary home modules will have linkables and the current module will@@ -254,8 +253,8 @@ ms <- msrModSummary <$> use_ GetModSummary nfp deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp- linkables <- uses_ GetLinkable linkables_needed+ linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp+ linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps 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@@ -272,7 +271,7 @@ 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+ env2 <- liftIO $ evalGhcEnv env1 $ do setContext [Compat.IIModule (moduleName (ms_mod ms))] let df = flip xopt_set LangExt.ExtendedDefaultRules . flip xopt_unset LangExt.MonomorphismRestriction@@ -300,9 +299,9 @@ p = Position l c in TextEdit (Range p p) "\n" -moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text+moduleText :: MonadLsp c m => Uri -> ExceptT PluginError m Text moduleText uri =- handleMaybeM "mdlText" $+ handleMaybeM (PluginInternalError "mdlText") $ (virtualFileText <$>) <$> getVirtualFile (toNormalizedUri uri)@@ -355,18 +354,18 @@ asEdit :: Format -> Test -> [Text] -> TextEdit asEdit (MultiLine commRange) test resultLines -- A test in a block comment, ending with @-\}@ without newline in-between.- | testRange test ^. end.line == commRange ^. end . line+ | testRange test ^. L.end . L.line == commRange ^. L.end . L.line = TextEdit (Range- (testRange test ^. end)- (resultRange test ^. end)+ (testRange test ^. L.end)+ (resultRange test ^. L.end) ) ("\n" <> T.unlines (resultLines <> ["-}"])) asEdit _ test resultLines = TextEdit (resultRange test) (T.unlines resultLines) -{-+{- | The result of evaluating a test line can be: * a value * nothing
src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -33,14 +33,11 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Void (Void)-import Development.IDE (Position,- Range (Range))-import Development.IDE.Types.Location (Position (..)) import GHC.Generics hiding (UInt, to) import Ide.Plugin.Eval.Types-import Language.LSP.Types (UInt)-import Language.LSP.Types.Lens (character, end, line,- start)+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Types+ import qualified Text.Megaparsec as P import Text.Megaparsec import Text.Megaparsec.Char (alphaNumChar, char,@@ -73,7 +70,7 @@ { isLhs :: Bool , blockRange :: Range }- deriving (Read, Show, Eq, Ord)+ deriving (Show, Eq, Ord) makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L")))@@ -109,7 +106,7 @@ -- | Single line or block comments? data CommentStyle = Line | Block Range- deriving (Read, Show, Eq, Ord, Generic)+ deriving (Show, Eq, Ord, Generic) makePrisms ''CommentStyle @@ -124,8 +121,8 @@ ( \lcs -> let theRan = Range- (view start $ fst $ NE.head lcs)- (view end $ fst $ NE.last lcs)+ (view L.start $ fst $ NE.head lcs)+ (view L.end $ fst $ NE.last lcs) in case parseMaybe lineGroupP $ NE.toList lcs of Nothing -> mempty Just (mls, rs) ->@@ -147,8 +144,8 @@ -- non-zero base indentation level! ( \pos _ -> if isLHS- then pos ^. start . character == 2- else pos ^. start . character == 0+ then pos ^. L.start . L.character == 2+ else pos ^. L.start . L.character == 0 ) lineComments (blockSeed, blockSetupSeeds) =@@ -205,7 +202,7 @@ st { statePosState = (statePosState st)- { pstateSourcePos = positionToSourcePos $ blockRange ^. start+ { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start } } p@@ -330,8 +327,8 @@ positionToSourcePos pos = P.SourcePos { sourceName = "<block comment>"- , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line- , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character+ , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. L.line+ , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. L.character } sourcePosToPosition :: SourcePos -> Position@@ -420,7 +417,7 @@ convexHullRange :: NonEmpty Range -> Range convexHullRange nes =- Range (NE.head nes ^. start) (NE.last nes ^. end)+ Range (NE.head nes ^. L.start) (NE.last nes ^. L.end) exampleLineGP :: LineGroupParser (Range, ExampleLine) exampleLineGP =@@ -496,7 +493,7 @@ Line -> (,) <$> takeRest <*> getPosition Block {} -> manyTill_ anySingle (getPosition <* eob) -getPosition :: (Ord v, TraversableStream s) => ParsecT v s m Position+getPosition :: (Monad m, Ord v, TraversableStream s) => ParsecT v s m Position getPosition = sourcePosToPosition <$> getSourcePos -- | Parses example test line.@@ -568,5 +565,5 @@ groupLineComments :: Map Range a -> [NonEmpty (Range, a)] groupLineComments =- contiguousGroupOn (fst >>> view start >>> view line &&& view character)+ contiguousGroupOn (fst >>> view L.start >>> view L.line &&& view L.character) . Map.toList
src/Ide/Plugin/Eval/Rules.hs view
@@ -5,7 +5,7 @@ -- To avoid warning "Pattern match has inaccessible right hand side" {-# OPTIONS_GHC -Wno-overlapping-patterns #-}-module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where+module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashSet (HashSet)@@ -24,7 +24,8 @@ fromNormalizedFilePath, msrModSummary, realSrcSpanToRange,- useWithStale_)+ useWithStale_,+ use_) import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags, needsCompilationRule)@@ -38,7 +39,7 @@ import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun)-import Development.IDE.Types.Logger (Pretty (pretty),+import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) #if MIN_VERSION_ghc(9,2,0)@@ -46,6 +47,8 @@ #endif import Ide.Plugin.Eval.Types +import qualified Data.ByteString as BS+ newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where@@ -56,6 +59,7 @@ rules recorder = do evalParsedModuleRule recorder redefinedNeedsCompilation recorder+ isEvaluatingRule recorder addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))@@ -64,8 +68,14 @@ queueForEvaluation :: IdeState -> NormalizedFilePath -> IO () queueForEvaluation ide nfp = do EvaluatingVar var <- getIdeGlobalState ide- modifyIORef var (Set.insert nfp)+ atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ())) +unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()+unqueueForEvaluation ide nfp = do+ EvaluatingVar var <- getIdeGlobalState ide+ -- remove the module from the Evaluating state, so that next time it won't evaluate to True+ atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ())+ #if MIN_VERSION_ghc(9,2,0) #if MIN_VERSION_ghc(9,5,0) getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment]@@ -133,6 +143,13 @@ fingerPrint = fromString $ if nullComments comments then "" else "1" return (Just fingerPrint, Just comments) +isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()+isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do+ alwaysRerun+ EvaluatingVar var <- getIdeGlobalAction+ b <- liftIO $ (f `Set.member`) <$> readIORef var+ return (Just (if b then BS.singleton 1 else BS.empty), Just b)+ -- Redefine the NeedsCompilation rule to set the linkable type to Just _ -- whenever the module is being evaluated -- This will ensure that the modules are loaded with linkables@@ -140,19 +157,12 @@ -- leading to much better performance of the evaluate code lens redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules () redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do- alwaysRerun-- EvaluatingVar var <- getIdeGlobalAction- isEvaluating <- liftIO $ (f `elem`) <$> readIORef var-+ isEvaluating <- use_ IsEvaluating f if not isEvaluating then needsCompilationRule f else do ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f let df' = ms_hspp_opts ms linkableType = computeLinkableTypeForDynFlags df' fp = encodeLinkableType $ Just linkableType-- -- remove the module from the Evaluating state- liftIO $ modifyIORef var (Set.delete f) pure (Just fp, Just (Just linkableType))
src/Ide/Plugin/Eval/Types.hs view
@@ -28,8 +28,9 @@ unLoc, Txt, EvalParams(..),- GetEvalComments(..)- ,nullComments)+ GetEvalComments(..),+ IsEvaluating(..),+ nullComments) where import Control.DeepSeq (deepseq)@@ -41,7 +42,7 @@ import Development.IDE (Range, RuleResult) import Development.IDE.Graph.Classes import GHC.Generics (Generic)-import Language.LSP.Types (TextDocumentIdentifier)+import Language.LSP.Protocol.Types (TextDocumentIdentifier) import qualified Text.Megaparsec as P -- | A thing with a location attached.@@ -95,6 +96,13 @@ = Example {testLines :: NonEmpty Txt, testOutput :: [Txt], testRange :: Range} | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)++data IsEvaluating = IsEvaluating+ deriving (Eq, Show, Typeable, Generic)+instance Hashable IsEvaluating+instance NFData IsEvaluating++type instance RuleResult IsEvaluating = Bool data GetEvalComments = GetEvalComments deriving (Eq, Show, Typeable, Generic)
src/Ide/Plugin/Eval/Util.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -- |Debug utilities@@ -13,25 +13,35 @@ logWith, ) where -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))-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, bagToList)+import Control.Exception (SomeException, evaluate,+ fromException)+import Control.Monad.Error.Class (MonadError (throwError))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Except (ExceptT (..),+ runExceptT)+import Data.Aeson (Value)+import Data.Bifunctor (second)+import Data.String (IsString (fromString))+import qualified Data.Text as T+import Development.IDE (IdeState, Priority (..),+ ideLogger, logPriority)+import qualified Development.IDE.Core.PluginUtils as PluginUtils import Development.IDE.GHC.Compat.Outputable-import GHC.Exts (toList)-import GHC.Stack (HasCallStack, callStack,- srcLocFile, srcLocStartCol,- srcLocStartLine)+import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList,+ catch)+import GHC.Exts (toList)+import GHC.Stack (HasCallStack, callStack,+ srcLocFile,+ srcLocStartCol,+ srcLocStartLine)+import Ide.Plugin.Error+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types import Language.LSP.Server-import Language.LSP.Types-import System.FilePath (takeExtension)-import System.Time.Extra (duration, showDuration)-import UnliftIO.Exception (catchAny)+import System.FilePath (takeExtension)+import System.Time.Extra (duration, showDuration)+import UnliftIO.Exception (catchAny) timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b timed out name op = do@@ -61,43 +71,41 @@ isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value)+response' :: ExceptT PluginError (LspM c) WorkspaceEdit -> ExceptT PluginError (LspM c) (Value |? Null) response' act = do- res <- runExceptT act- `catchAny` showErr- case res of- Left e ->- return $ Left (ResponseError InternalError (fromString e) Nothing)- Right a -> do- _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ())- return $ Right Null+ res <- ExceptT (runExceptT act+ `catchAny` \e -> do+ res <- showErr e+ pure . Left . PluginInternalError $ fromString res)+ _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing res) (\_ -> pure ())+ pure $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = catch (op >>= fmap Right . gevaluate)- showErr+ (fmap Left . showErr) gevaluate :: MonadIO m => a -> m a gevaluate = liftIO . evaluate -showErr :: Monad m => SomeException -> m (Either String b)+showErr :: Monad m => SomeException -> m String 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+ Just (SourceError msgs) -> return $ renderWithContext defaultSDocContext+ $ vcat+ $ bagToList+ $ fmap (vcat . unDecorated+ . diagnosticMessage #if MIN_VERSION_ghc(9,5,0)- (defaultDiagnosticOpts @GhcMessage)+ (defaultDiagnosticOpts @GhcMessage) #endif- . errMsgDiagnostic)- $ getMessages msgs+ . errMsgDiagnostic)+ $ getMessages msgs _ -> #endif- return . Left . show $ e+ return . show $ e
test/Main.hs view
@@ -1,30 +1,33 @@ {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-}- module Main ( main ) where -import Control.Lens (_Just, folded, preview, toListOf,- view, (^..))-import Data.Aeson (Value (Object), fromJSON, object,- toJSON, (.=))-import Data.Aeson.Types (Pair, Result (Success))-import Data.List (isInfixOf)-import Data.List.Extra (nubOrdOn)-import qualified Data.Map as Map-import qualified Data.Text as T-import Ide.Plugin.Config (Config)-import qualified Ide.Plugin.Config as Plugin-import qualified Ide.Plugin.Eval as Eval-import Ide.Plugin.Eval.Types (EvalParams (..), Section (..),- testOutput)-import Ide.Types (IdePlugins (IdePlugins))-import Language.LSP.Types.Lens (arguments, command, range, title)-import System.FilePath ((</>))+import Control.Lens (_Just, folded, preview,+ toListOf, view, (^..))+import Data.Aeson (Value (Object), fromJSON,+ object, toJSON, (.=))+import Data.Aeson.Types (Pair, Result (Success))+import Data.List (isInfixOf)+import Data.List.Extra (nubOrdOn)+import qualified Data.Map as Map+import Data.Row+import qualified Data.Text as T+import Ide.Plugin.Config (Config)+import qualified Ide.Plugin.Config as Plugin+import qualified Ide.Plugin.Eval as Eval+import Ide.Plugin.Eval.Types (EvalParams (..), Section (..),+ testOutput)+import Ide.Types (IdePlugins (IdePlugins))+import Language.LSP.Protocol.Lens (arguments, command, range,+ title)+import Language.LSP.Protocol.Message hiding (error)+import System.FilePath ((</>)) import Test.Hls main :: IO ()@@ -249,14 +252,14 @@ nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses] actSectionId :: Command -> Int-actSectionId Command{_arguments = Just (List [fromJSON -> Success EvalParams{..}])} = evalId+actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId actSectionId _ = error "Invalid CodeLens" -- Execute command and wait for result executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd- _ <- skipManyTill anyMessage (message SWorkspaceApplyEdit)+ _ <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- liftIO $ print _resp pure () @@ -269,7 +272,7 @@ codeLensTestOutput :: CodeLens -> [String] codeLensTestOutput codeLens = do CodeLens { _command = Just command } <- [codeLens]- Command { _arguments = Just (List args) } <- [command]+ Command { _arguments = Just args } <- [command] Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args Section { sectionTests = sectionTests } <- sections testOutput =<< sectionTests@@ -304,7 +307,7 @@ doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e- changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing withEval]+ changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval] executeLensesBackwards doc result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc liftIO $ result @?= Just (T.strip expected)