hls-eval-plugin 1.1.2.0 → 1.2.0.1
raw patch · 9 files changed
+320/−292 lines, 9 filesdep +data-defaultdep +hls-graphdep −ghc-api-compatdep ~ghcide
Dependencies added: data-default, hls-graph
Dependencies removed: ghc-api-compat
Dependency ranges changed: ghcide
Files
- hls-eval-plugin.cabal +7/−20
- src/Ide/Plugin/Eval.hs +2/−0
- src/Ide/Plugin/Eval/Code.hs +2/−4
- src/Ide/Plugin/Eval/CodeLens.hs +110/−213
- src/Ide/Plugin/Eval/GHC.hs +11/−18
- src/Ide/Plugin/Eval/Rules.hs +117/−0
- src/Ide/Plugin/Eval/Types.hs +28/−11
- src/Ide/Plugin/Eval/Util.hs +24/−24
- test/Main.hs +19/−2
hls-eval-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin-version: 1.1.2.0+version: 1.2.0.1 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -48,12 +48,14 @@ Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Option+ Ide.Plugin.Eval.Rules Ide.Plugin.Eval.Util build-depends: , aeson , base >=4.12 && <5 , containers+ , data-default , deepseq , Diff ^>=0.4.0 , directory@@ -63,8 +65,9 @@ , ghc , ghc-boot-th , ghc-paths- , ghcide >=1.2 && <1.5+ , ghcide >=1.5.0 && <1.6 , hashable+ , hls-graph , hls-plugin-api ^>=1.2 , lens , lsp@@ -82,24 +85,8 @@ , unliftio , unordered-containers - if impl(ghc < 8.10.5)- build-depends:- ghc-api-compat ==8.6- elif impl(ghc == 8.10.5)- build-depends:- ghc-api-compat ==8.10.5- elif impl(ghc == 8.10.6)- build-depends:- ghc-api-compat ==8.10.6- elif impl(ghc == 8.10.7)- build-depends:- ghc-api-compat ==8.10.7- elif impl(ghc == 9.0.1)- build-depends:- ghc-api-compat ==9.0.1- ghc-options:- -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors+ -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -fno-ignore-asserts if flag(pedantic) ghc-options: -Werror@@ -114,7 +101,7 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts build-depends: , aeson , base
src/Ide/Plugin/Eval.hs view
@@ -11,6 +11,7 @@ import Development.IDE (IdeState) import qualified Ide.Plugin.Eval.CodeLens as CL+import Ide.Plugin.Eval.Rules (rules) import Ide.Types (PluginDescriptor (..), PluginId, defaultPluginDescriptor, mkPluginHandler)@@ -22,4 +23,5 @@ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand]+ , pluginRules = rules }
src/Ide/Plugin/Eval/Code.hs view
@@ -6,22 +6,20 @@ module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where 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 Development.IDE.GHC.Compat import Development.IDE.Types.Location (Position (..), Range (..)) import GHC (ExecOptions, ExecResult (..), execStmt)-import GhcMonad (Ghc, liftIO, modifySession)-import HscTypes import Ide.Plugin.Eval.Types (Language (Plain), Loc, Located (..), Section (sectionLanguage), Test (..), Txt, locate, locate0)-import InteractiveEval (getContext, parseImportDecl,- runDecls, setContext) import Language.LSP.Types.Lens (line, start) import System.IO.Extra (newTempFile, readFile')
src/Ide/Plugin/Eval/CodeLens.hs view
@@ -25,162 +25,91 @@ evalCommand, ) where -import CmdLineParser-import Control.Applicative (Alternative ((<|>)))-import Control.Arrow (second, (>>>))-import Control.Exception (try)-import qualified Control.Exception as E-import Control.Lens (_1, _3, (%~), (<&>),- (^.))-import Control.Monad (guard, join, void, when)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Except (ExceptT (..))-import Data.Aeson (toJSON)-import Data.Char (isSpace)-import qualified Data.DList as DL-import qualified Data.HashMap.Strict as HashMap-import Data.List (dropWhileEnd, find,- intercalate, intersperse)-import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, fromMaybe)-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 (Action,- GetDependencies (..),- GetModIface (..),- GetModSummary (..),- GetParsedModuleWithComments (..),- GhcSessionIO (..),- HiFileResult (hirHomeMod, hirModSummary),- HscEnvEq, IdeState,- ModSummaryResult (..),- evalGhcEnv,- hscEnvWithImportPaths,- prettyPrint,- realSrcSpanToRange,- runAction,- textToStringBuffer,- toNormalizedFilePath',- uriToFilePath',- useNoFile_,- useWithStale_, use_,- uses_)-import Development.IDE.Core.Compile (loadModulesHome,- setupFinderCache)-import Development.IDE.Core.PositionMapping (toCurrentRange)-import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))-import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment),- GenLocated (L),- GhcException, HscEnv,- ParsedModule (..),- SrcSpan (UnhelpfulSpan),- moduleName,- setInteractiveDynFlags,- srcSpanFile)-import qualified Development.IDE.GHC.Compat as SrcLoc+import Control.Applicative (Alternative ((<|>)))+import Control.Arrow (second, (>>>))+import Control.Exception (try)+import qualified Control.Exception as E+import Control.Lens (_1, _3, (%~), (<&>), (^.))+import Control.Monad (guard, join, 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.String (IsString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (getCurrentTime)+import Data.Typeable (Typeable)+import Development.IDE (GetModSummary (..),+ GhcSessionIO (..), IdeState,+ ModSummaryResult (..),+ NeedsCompilation (NeedsCompilation),+ evalGhcEnv, hscEnv,+ hscEnvWithImportPaths,+ prettyPrint, runAction,+ textToStringBuffer,+ toNormalizedFilePath',+ uriToFilePath', useNoFile_,+ useWithStale_, use_)+import Development.IDE.Core.Rules (GhcSessionDepsConfig (..),+ ghcSessionDepsDefinition)+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.Types.Options-import DynamicLoading (initializePlugins)-import FastString (unpackFS)-import GHC (ClsInst,- ExecOptions (execLineNumber, execSourceFile),- FamInst, Fixity,- GeneralFlag (..), Ghc,- GhcLink (LinkInMemory),- GhcMode (CompManager),- GhcMonad (getSession),- HscTarget (HscInterpreted),- LoadHowMuch (LoadAllTargets),- ModSummary (ms_hspp_opts),- NamedThing (getName, getOccName),- SuccessFlag (Failed, Succeeded),- TcRnExprMode (..),- TyThing, defaultFixity,- execOptions, exprType,- getInfo,- getInteractiveDynFlags,- getSessionDynFlags,- isImport, isStmt, load,- parseName, pprFamInst,- pprInstance, runDecls,- setContext, setLogAction,- setSessionDynFlags,- setTargets, typeKind)-import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..))-import GhcPlugins (DynFlags (..),- defaultLogActionHPutStrDoc,- elemNameSet, gopt_set,- gopt_unset, hsc_dflags,- isSymOcc, mkNameSet,- parseDynamicFlagsCmdLine,- pprDefinedAt,- pprInfixName,- targetPlatform,- tyThingParent_maybe,- xopt_set, xopt_unset)+import GHC (ClsInst,+ ExecOptions (execLineNumber, execSourceFile),+ FamInst, GhcMonad,+ LoadHowMuch (LoadAllTargets),+ NamedThing (getName),+ defaultFixity, execOptions,+ exprType, getInfo,+ getInteractiveDynFlags,+ isImport, isStmt, load,+ parseName, pprFamInst,+ pprInstance, setLogAction,+ setTargets, typeKind)+import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) -import HscTypes (InteractiveImport (IIModule),- ModSummary (ms_mod),- Target (Target),- TargetId (TargetFile))-import Ide.Plugin.Eval.Code (Statement, asStatements,- evalSetup, myExecStmt,- propSetup, resultRange,- testCheck, testRanges)-import Ide.Plugin.Eval.GHC (addImport, addPackages,- hasPackage, showDynFlags)-import Ide.Plugin.Eval.Parse.Comments (commentsToSections)-import Ide.Plugin.Eval.Parse.Option (parseSetFlags)+import Development.IDE.Core.FileStore (setSomethingModified)+import Development.IDE.Types.Shake (toKey)+import Ide.Plugin.Eval.Code (Statement, asStatements,+ evalSetup, myExecStmt,+ propSetup, resultRange,+ testCheck, testRanges)+import Ide.Plugin.Eval.GHC (addImport, addPackages,+ hasPackage, 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.Types-import Ide.Plugin.Eval.Util (asS, gStrictTry,- handleMaybe,- handleMaybeM, isLiterate,- logWith, response,- response', timed)+import Ide.Plugin.Eval.Util (asS, gStrictTry, handleMaybe,+ handleMaybeM, isLiterate,+ logWith, response, response',+ timed) import Ide.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)-import Outputable (SDoc, empty, hang, nest,- ppr, showSDoc, text,- vcat, ($$), (<+>))-import System.FilePath (takeFileName)-import System.IO (hClose)-import UnliftIO.Temporary (withSystemTempFile)-import Util (OverridingBool (Never))--import IfaceSyn (showToHeader)-import PprTyThing (pprTyThingInContext,- pprTypeForUser)-#if MIN_VERSION_ghc(9,0,0)-import GHC.Driver.Ways (hostFullWays,- wayGeneralFlags,- wayUnsetGeneralFlags)-import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments))-import GHC.Parser.Lexer (mkParserFlags)-import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive))-#else-import GhcPlugins (interpWays, updateWays,- wayGeneralFlags,- wayUnsetGeneralFlags)-#endif+import Language.LSP.Types hiding+ (SemanticTokenAbsolute (length, line),+ SemanticTokenRelative (length))+import Language.LSP.Types.Lens (end, line)+import Language.LSP.VFS (virtualFileText)+import System.FilePath (takeFileName)+import System.IO (hClose)+import UnliftIO.Temporary (withSystemTempFile) #if MIN_VERSION_ghc(9,0,0)-pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan-pattern RealSrcSpanAlready x = x-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]-apiAnnComments' = apiAnnRogueComments+import GHC.Driver.Session (unitDatabases, unitState)+import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]-apiAnnComments' = concat . Map.elems . snd--pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan-pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x+import DynFlags #endif @@ -198,36 +127,16 @@ let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp dbg "fp" fp- (ParsedModule{..}, posMap) <- liftIO $- runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp- let comments =- foldMap (\case- L (RealSrcSpanAlready real) bdy- | unpackFS (srcSpanFile real) ==- fromNormalizedFilePath nfp- , let ran0 = realSrcSpanToRange real- , Just curRan <- toCurrentRange posMap ran0- ->-- -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',- -- we can concentrate on these two- case bdy of- AnnLineComment cmt ->- mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }- AnnBlockComment cmt ->- mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }- _ -> mempty- _ -> mempty- )- $ apiAnnComments' pm_annotations- dbg "excluded comments" $ show $ DL.toList $- foldMap (\(L a b) ->- case b of- AnnLineComment{} -> mempty- AnnBlockComment{} -> mempty- _ -> DL.singleton (a, b)- )- $ apiAnnComments' pm_annotations+ (comments, _) <- liftIO $+ runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetEvalComments nfp+ -- dbg "excluded comments" $ show $ DL.toList $+ -- foldMap (\(L a b) ->+ -- case b of+ -- AnnLineComment{} -> mempty+ -- AnnBlockComment{} -> mempty+ -- _ -> DL.singleton (a, b)+ -- )+ -- $ apiAnnComments' pm_annotations dbg "comments" $ show comments -- Extract tests from source code@@ -287,6 +196,10 @@ let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri + -- enable codegen+ liftIO $ queueForEvaluation st nfp+ liftIO $ setSomethingModified st [toKey NeedsCompilation nfp] "Eval"+ session <- runGetSession st nfp ms <- fmap msrModSummary $@@ -387,7 +300,7 @@ return $ Left err Succeeded -> do -- Evaluation takes place 'inside' the module- setContext [IIModule modName]+ setContext [Compat.IIModule modName] Right <$> getSession edits <-@@ -601,11 +514,10 @@ dbg "{DECL " stmt void $ runDecls stmt return Nothing+ pf = initParserOpts df #if !MIN_VERSION_ghc(9,0,0)- pf = df unhelpfulReason = "<interactive>" #else- pf = mkParserFlags df unhelpfulReason = UnhelpfulInteractive #endif exec stmt l =@@ -617,29 +529,23 @@ prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg -ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv-ghcSessionDepsDefinition env file = do- let hsc = hscEnvWithImportPaths env- deps <- use_ GetDependencies file- let tdeps = transitiveModuleDeps deps- ifaces <- uses_ GetModIface tdeps-- -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.- -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.- -- Long-term we might just want to change the order returned by GetDependencies- let inLoadOrder = reverse (map hirHomeMod ifaces)-- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc- 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 hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res- ghcSessionDepsDefinition hscEnv nfp+ let env = fromMaybe (error $ "Unknown file: " <> fp) res+ ghcSessionDepsConfig = def+ { forceLinkables = True+ , checkForImportCycles = False+ , fullModSummary = True+ }+ res <- fmap hscEnvWithImportPaths <$> ghcSessionDepsDefinition ghcSessionDepsConfig env nfp+ return $ fromMaybe (error $ "Unable to load file: " <> fp) res needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd)@@ -766,7 +672,7 @@ doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do let (emod, expr) = parseExprMode arg- ty <- exprType emod $ T.unpack expr+ ty <- GHC.exprType emod $ T.unpack expr let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty broken = T.any (\c -> c == '\r' || c == '\n') rawType pure $@@ -812,29 +718,20 @@ setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags setupDynFlagsForGHCiLike env dflags = do- let dflags3 =- dflags- { hscTarget = HscInterpreted- , ghcMode = CompManager- , ghcLink = LinkInMemory- }+ let dflags3 = setInterpreterLinkerOptions dflags platform = targetPlatform dflags3-#if MIN_VERSION_ghc(9,0,0)- evalWays = hostFullWays-#else- evalWays = interpWays-#endif- dflags3a = dflags3{ways = evalWays}+ evalWays = Compat.hostFullWays+ dflags3a = setWays evalWays dflags3 dflags3b = foldl gopt_set dflags3a $- concatMap (wayGeneralFlags platform) evalWays+ concatMap (Compat.wayGeneralFlags platform) evalWays dflags3c = foldl gopt_unset dflags3b $- concatMap (wayUnsetGeneralFlags platform) evalWays+ concatMap (Compat.wayUnsetGeneralFlags platform) evalWays dflags4 = dflags3c `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges `gopt_unset` Opt_DiagnosticsShowCaret- initializePlugins env dflags4+ Compat.hsc_dflags <$> Compat.initializePlugins (Compat.hscSetFlags dflags4 env)
src/Ide/Plugin/Eval/GHC.hs view
@@ -13,23 +13,16 @@ showDynFlags, ) where -import Data.List (isPrefixOf)-import Data.Maybe (mapMaybe)-import Data.String (fromString)+import Data.List (isPrefixOf)+import Data.Maybe (mapMaybe)+import Data.String (fromString) import Development.IDE.GHC.Compat-import qualified EnumSet-import GHC.LanguageExtensions.Type (Extension (..))-import GhcMonad (modifySession)-import GhcPlugins (fsLit, hsc_IC, pprHsString)-import HscTypes (InteractiveContext (ic_dflags))-import Ide.Plugin.Eval.Util (asS, gStrictTry)-import qualified Lexer-import Outputable (Outputable (ppr), SDoc,- showSDocUnsafe, text, vcat, (<+>))-import qualified Parser-import SrcLoc (mkRealSrcLoc)-import StringBuffer (stringToStringBuffer)+import Development.IDE.GHC.Compat.Util+import qualified Development.IDE.GHC.Compat.Util as EnumSet +import GHC.LanguageExtensions.Type (Extension (..))+import Ide.Plugin.Eval.Util (asS, gStrictTry)+ {- $setup >>> import GHC >>> import GHC.Paths@@ -72,9 +65,9 @@ pkgNames_ = mapMaybe ( \case- ExposePackage _ (PackageArg n) _ -> Just n- ExposePackage _ (UnitIdArg (DefiniteUnitId n)) _ -> Just $ asS n- _ -> Nothing+ ExposePackage _ (PackageArg n) _ -> Just n+ ExposePackage _ (UnitIdArg uid) _ -> Just $ asS uid+ _ -> Nothing ) {- | Expose a list of packages.
+ src/Ide/Plugin/Eval/Rules.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}++module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.IORef+import qualified Data.Map.Strict as Map+import Data.String (fromString)+import Development.IDE (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),+ GetParsedModuleWithComments (GetParsedModuleWithComments),+ IdeState,+ NeedsCompilation (NeedsCompilation),+ NormalizedFilePath,+ RuleBody (RuleNoDiagnostics),+ Rules, defineEarlyCutoff,+ encodeLinkableType,+ fromNormalizedFilePath,+ msrModSummary,+ realSrcSpanToRange,+ useWithStale_)+import Development.IDE.Core.PositionMapping (toCurrentRange)+import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags,+ needsCompilationRule)+import Development.IDE.Core.Shake (IsIdeGlobal,+ RuleBody (RuleWithCustomNewnessCheck),+ addIdeGlobal,+ getIdeGlobalAction,+ getIdeGlobalState)+import Development.IDE.GHC.Compat+import qualified Development.IDE.GHC.Compat as SrcLoc+import qualified Development.IDE.GHC.Compat.Util as FastString+import Development.IDE.Graph (alwaysRerun)+import Ide.Plugin.Eval.Types+++rules :: Rules ()+rules = do+ evalParsedModuleRule+ redefinedNeedsCompilation+ addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)++newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))+instance IsIdeGlobal EvaluatingVar++queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()+queueForEvaluation ide nfp = do+ EvaluatingVar var <- getIdeGlobalState ide+ modifyIORef var (Set.insert nfp)++#if MIN_VERSION_ghc(9,0,0)+pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan+pattern RealSrcSpanAlready x = x+apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]+apiAnnComments' = apiAnnRogueComments+#else+apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]+apiAnnComments' = concat . Map.elems . snd++pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan+pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing+#endif++evalParsedModuleRule :: Rules ()+evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do+ (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp+ let comments = foldMap (\case+ L (RealSrcSpanAlready real) bdy+ | FastString.unpackFS (srcSpanFile real) ==+ fromNormalizedFilePath nfp+ , let ran0 = realSrcSpanToRange real+ , Just curRan <- toCurrentRange posMap ran0+ ->++ -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',+ -- we can concentrate on these two+ case bdy of+ AnnLineComment cmt ->+ mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }+ AnnBlockComment cmt ->+ mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }+ _ -> mempty+ _ -> mempty+ )+ $ apiAnnComments' pm_annotations+ -- we only care about whether the comments are null+ -- this is valid because the only dependent is NeedsCompilation+ fingerPrint = fromString $ if nullComments comments then "" else "1"+ return (Just fingerPrint, Just comments)++-- 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+-- and the interactive session won't try to compile them on the fly,+-- leading to much better performance of the evaluate code lens+redefinedNeedsCompilation :: Rules ()+redefinedNeedsCompilation = defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do+ alwaysRerun++ EvaluatingVar var <- getIdeGlobalAction+ isEvaluating <- liftIO $ (f `elem`) <$> readIORef var+++ 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
@@ -3,8 +3,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Eval.Types ( locate,@@ -26,19 +28,21 @@ unLoc, Txt, EvalParams(..),- )+ GetEvalComments(..)+ ,nullComments) where -import Control.DeepSeq (NFData (rnf), deepseq)-import Data.Aeson (FromJSON, ToJSON)-import Data.List (partition)-import Data.List.NonEmpty (NonEmpty)-import Data.Map.Strict (Map)-import Data.String (IsString (..))-import Development.IDE (Range)-import GHC.Generics (Generic)-import Language.LSP.Types (TextDocumentIdentifier)-import qualified Text.Megaparsec as P+import Control.DeepSeq (deepseq)+import Data.Aeson (FromJSON, ToJSON)+import Data.List (partition)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.String (IsString (..))+import Development.IDE (Range, RuleResult)+import Development.IDE.Graph.Classes+import GHC.Generics (Generic)+import Language.LSP.Types (TextDocumentIdentifier)+import qualified Text.Megaparsec as P -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a}@@ -92,12 +96,23 @@ | Property {testline :: Txt, testOutput :: [Txt], testRange :: Range} deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) +data GetEvalComments = GetEvalComments+ deriving (Eq, Show, Typeable, Generic)+instance Hashable GetEvalComments+instance NFData GetEvalComments++type instance RuleResult GetEvalComments = Comments data Comments = Comments { lineComments :: Map Range RawLineComment , blockComments :: Map Range RawBlockComment } deriving (Show, Eq, Ord, Generic) +nullComments :: Comments -> Bool+nullComments Comments{..} = null lineComments && null blockComments++instance NFData Comments+ newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} deriving (Show, Eq, Ord) deriving newtype@@ -107,6 +122,7 @@ , P.VisualStream , Semigroup , Monoid+ , NFData ) newtype RawLineComment = RawLineComment {getRawLineComment :: String}@@ -118,6 +134,7 @@ , P.VisualStream , Semigroup , Monoid+ , NFData ) instance Semigroup Comments where
src/Ide/Plugin/Eval/Util.hs view
@@ -15,30 +15,30 @@ logWith, ) where -import Control.Monad.Extra (maybeM)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)-import Data.Aeson (Value (Null))-import Data.Bifunctor (first)-import Data.String (IsString (fromString))-import qualified Data.Text as T-import Development.IDE (IdeState, Priority (..), ideLogger,- logPriority)-import Development.IDE.GHC.Compat (gcatch)-import Exception (ExceptionMonad, SomeException (..),- evaluate)-import GHC.Exts (toList)-import GHC.Stack (HasCallStack, callStack,- srcLocFile, srcLocStartCol,- srcLocStartLine)+import Control.Exception (SomeException, evaluate)+import Control.Monad.Extra (maybeM)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT,+ throwE)+import Data.Aeson (Value (Null))+import Data.Bifunctor (first)+import Data.String (IsString (fromString))+import qualified Data.Text as T+import Development.IDE (IdeState, Priority (..),+ ideLogger, logPriority)+import Development.IDE.GHC.Compat (Outputable, ppr,+ showSDocUnsafe)+import Development.IDE.GHC.Compat.Util (MonadCatch, catch)+import GHC.Exts (toList)+import GHC.Stack (HasCallStack, callStack,+ srcLocFile, srcLocStartCol,+ srcLocStartLine) import Language.LSP.Server import Language.LSP.Types-import Outputable (Outputable (ppr), ppr,- showSDocUnsafe)-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) asS :: Outputable a => a -> String asS = showSDocUnsafe . ppr@@ -93,9 +93,9 @@ _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right Null -gStrictTry :: ExceptionMonad m => m b -> m (Either String b)+gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op =- gcatch+ catch (op >>= fmap Right . gevaluate) showErr
test/Main.hs view
@@ -7,18 +7,19 @@ ( main ) where -import Control.Lens (_Just, preview, toListOf, view)+import Control.Lens (_Just, folded, preview, toListOf,+ view, (^..)) import Data.Aeson (fromJSON) import Data.Aeson.Types (Result (Success)) import Data.List (isInfixOf) import Data.List.Extra (nubOrdOn)+import qualified Data.Text as T import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) import Language.LSP.Types.Lens (arguments, command, range, title) import System.FilePath ((</>)) import Test.Hls-import qualified Data.Text as T main :: IO () main = defaultTestRunner tests@@ -177,6 +178,22 @@ "Ord Foo" `isInfixOf` output @? "Output does not include instance Ord Foo" not ("Baz Foo" `isInfixOf` output) @? "Output includes instance Baz Foo" ]+ , testCase "Interfaces are reused after Eval" $ do+ runSessionWithServer evalPlugin testDataDir $ do+ doc <- openDoc "TLocalImport.hs" "haskell"+ waitForTypecheck doc+ lenses <- getCodeLenses doc+ let ~cmds@[cmd] = lenses^..folded.command._Just+ liftIO $ cmds^..folded.title @?= ["Evaluate..."]++ executeCmd cmd++ -- trigger a rebuild and check that dependency interfaces are not rebuilt+ changeDoc doc []+ waitForTypecheck doc+ Right keys <- getLastBuildKeys+ let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys+ liftIO $ ifaceKeys @?= [] ] goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree