diff --git a/hls-eval-plugin.cabal b/hls-eval-plugin.cabal --- a/hls-eval-plugin.cabal +++ b/hls-eval-plugin.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/Eval.hs b/src/Ide/Plugin/Eval.hs --- a/src/Ide/Plugin/Eval.hs +++ b/src/Ide/Plugin/Eval.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/Code.hs b/src/Ide/Plugin/Eval/Code.hs --- a/src/Ide/Plugin/Eval/Code.hs +++ b/src/Ide/Plugin/Eval/Code.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/CodeLens.hs b/src/Ide/Plugin/Eval/CodeLens.hs --- a/src/Ide/Plugin/Eval/CodeLens.hs +++ b/src/Ide/Plugin/Eval/CodeLens.hs @@ -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 diff --git a/src/Ide/Plugin/Eval/Parse/Comments.hs b/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -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 = "" - , 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 diff --git a/src/Ide/Plugin/Eval/Rules.hs b/src/Ide/Plugin/Eval/Rules.hs --- a/src/Ide/Plugin/Eval/Rules.hs +++ b/src/Ide/Plugin/Eval/Rules.hs @@ -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)) diff --git a/src/Ide/Plugin/Eval/Types.hs b/src/Ide/Plugin/Eval/Types.hs --- a/src/Ide/Plugin/Eval/Types.hs +++ b/src/Ide/Plugin/Eval/Types.hs @@ -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) diff --git a/src/Ide/Plugin/Eval/Util.hs b/src/Ide/Plugin/Eval/Util.hs --- a/src/Ide/Plugin/Eval/Util.hs +++ b/src/Ide/Plugin/Eval/Util.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)