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: 1.1.2.0 +version: 1.2.0.1 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -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 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,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 } 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,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') 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,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 = "" #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) diff --git a/src/Ide/Plugin/Eval/GHC.hs b/src/Ide/Plugin/Eval/GHC.hs --- a/src/Ide/Plugin/Eval/GHC.hs +++ b/src/Ide/Plugin/Eval/GHC.hs @@ -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. diff --git a/src/Ide/Plugin/Eval/Rules.hs b/src/Ide/Plugin/Eval/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Ide/Plugin/Eval/Rules.hs @@ -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)) 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 @@ -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 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 @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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