From 676a3a341daabc9393e58c8397bd97608dc0397c Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 12 Oct 2021 19:34:55 +0100 Subject: [PATCH 1/9] [hls-graph] clean up databaseDirtySet When I ported https://github.com/ndmitchell/shake/pull/802/files to hls-graph, I changed the encoding of the dirty set. Instead, Dirty became a constructor in the Status union. But the databaseDirtySet stayed around accidentally, leading to some confusion. --- .../IDE/Graph/Internal/Database.hs | 14 +++-- .../Development/IDE/Graph/Internal/Profile.hs | 54 ++++++++++--------- .../Development/IDE/Graph/Internal/Types.hs | 3 +- 3 files changed, 40 insertions(+), 31 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 38aa19a160..c8acc76de7 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build) where +module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet) where import Control.Concurrent.Async import Control.Concurrent.Extra @@ -46,7 +46,6 @@ newDatabase databaseExtra databaseRules = do databaseValues <- Ids.empty databaseReverseDeps <- Ids.empty databaseReverseDepsLock <- newLock - databaseDirtySet <- newIORef Nothing pure Database{..} -- | Increment the step and mark dirty @@ -54,7 +53,6 @@ incDatabase :: Database -> Maybe [Key] -> IO () -- all keys are dirty incDatabase db Nothing = do modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 - writeIORef (databaseDirtySet db) Nothing withLock (databaseLock db) $ Ids.forMutate (databaseValues db) $ \_ -> second $ \case Clean x -> Dirty (Just x) @@ -66,7 +64,6 @@ incDatabase db (Just kk) = do intern <- readIORef (databaseIds db) let dirtyIds = mapMaybe (`Intern.lookup` intern) kk transitiveDirtyIds <- transitiveDirtySet db dirtyIds - modifyIORef (databaseDirtySet db) (\dd -> Just $ fromMaybe mempty dd <> transitiveDirtyIds) withLock (databaseLock db) $ Ids.forMutate (databaseValues db) $ \i -> \case (k, Running _ _ x) -> (k, Dirty x) @@ -182,6 +179,15 @@ compute db@Database{..} key id mode result = do Ids.insert databaseValues id (key, Clean res) pure res +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Database -> IO [(Id,(Key, Int))] +getDirtySet db = do + Step curr <- readIORef (databaseStep db) + dbContents <- Ids.toList (databaseValues db) + let calcAge Result{resultBuilt = Step x} = curr - x + calcAgeStatus (Dirty x)=calcAge <$> x + calcAgeStatus _ = Nothing + return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents -------------------------------------------------------------------------------- -- Lazy IO trick diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 57b307a7a9..86afdb47ae 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -7,47 +7,51 @@ module Development.IDE.Graph.Internal.Profile (writeProfile) where import Data.Bifunctor -import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char -import Data.Dynamic (toDyn) -import qualified Data.HashMap.Strict as Map +import Data.Dynamic (toDyn) +import qualified Data.HashMap.Strict as Map import Data.IORef -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as Set -import Data.List (dropWhileEnd, foldl', - intercalate, partition, - sort, sortBy) -import Data.List.Extra (nubOrd) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as Set +import Data.List (dropWhileEnd, foldl', + intercalate, + partition, sort, + sortBy) +import Data.List.Extra (nubOrd) import Data.Maybe -import Data.Time (defaultTimeLocale, - formatTime, - getCurrentTime, - iso8601DateFormat) +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime, + iso8601DateFormat) import Development.IDE.Graph.Classes -import qualified Development.IDE.Graph.Internal.Ids as Ids +import Development.IDE.Graph.Internal.Database (getDirtySet) +import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types -import qualified Language.Javascript.DGTable as DGTable -import qualified Language.Javascript.Flot as Flot -import qualified Language.Javascript.JQuery as JQuery -import Numeric.Extra (showDP) +import qualified Language.Javascript.DGTable as DGTable +import qualified Language.Javascript.Flot as Flot +import qualified Language.Javascript.JQuery as JQuery +import Numeric.Extra (showDP) import System.FilePath -import System.IO.Unsafe (unsafePerformIO) -import System.Time.Extra (Seconds) +import System.IO.Unsafe (unsafePerformIO) +import System.Time.Extra (Seconds) #ifdef FILE_EMBED import Data.FileEmbed -import Language.Haskell.TH.Syntax (runIO) +import Language.Haskell.TH.Syntax (runIO) #endif -- | Generates an report given some build system profiling data. writeProfile :: FilePath -> Database -> IO () writeProfile out db = do - dirtyKeys <- readIORef (databaseDirtySet db) (report, mapping) <- toReport db - let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList <$> dirtyKeys - rpt <- generateHTML (sort <$> dirtyKeysMapped) report + dirtyKeysMapped <- do + dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db + let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList $ dirtyIds + return $ Just $ sort dirtyKeysMapped + rpt <- generateHTML dirtyKeysMapped report LBS.writeFile out rpt data ProfileEntry = ProfileEntry diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index f6c41da1f5..3adc0698d5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -10,6 +10,7 @@ module Development.IDE.Graph.Internal.Types where import Control.Applicative import Control.Concurrent.Extra import Control.Monad.Catch +-- Needed in GHC 8.6.5 import Control.Monad.Fail import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -81,8 +82,6 @@ data Database = Database { databaseExtra :: Dynamic, databaseRules :: TheRules, databaseStep :: !(IORef Step), - -- | Nothing means that everything is dirty - databaseDirtySet :: IORef (Maybe IntSet), -- Hold the lock while mutating Ids/Values databaseLock :: !Lock, databaseIds :: !(IORef (Intern Key)), From 0807587ffd53d0694c5c2bf2599ded1caaf0f956 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 23 Oct 2021 13:53:17 +0100 Subject: [PATCH 2/9] extract GetEvalComments rule --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 + .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 2 + .../src/Ide/Plugin/Eval/CodeLens.hs | 222 +++++++----------- .../src/Ide/Plugin/Eval/Rules.hs | 61 +++++ .../src/Ide/Plugin/Eval/Types.hs | 33 ++- 5 files changed, 175 insertions(+), 145 deletions(-) create mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 16232b61cc..5ef4565219 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -48,6 +48,7 @@ library Ide.Plugin.Eval.GHC Ide.Plugin.Eval.Parse.Comments Ide.Plugin.Eval.Parse.Option + Ide.Plugin.Eval.Rules Ide.Plugin.Eval.Util build-depends: @@ -65,6 +66,7 @@ library , ghc-paths , ghcide >=1.2 && <1.5 , hashable + , hls-graph , hls-plugin-api ^>=1.2 , lens , lsp diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index 0c2d45bc25..df2184c2fc 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -11,6 +11,7 @@ module Ide.Plugin.Eval ( 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 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand] + , pluginRules = rules } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 10b82027a5..2c1c3a6469 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -25,121 +25,93 @@ module Ide.Plugin.Eval.CodeLens ( evalCommand, ) where -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 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 qualified Development.IDE.GHC.Compat.Util as FastString +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.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 (Action, GetDependencies (..), + GetModIface (..), + GetModSummary (..), + GhcSessionIO (..), + HiFileResult (hirHomeMod, hirModSummary), + HscEnvEq, IdeState, + ModSummaryResult (..), + evalGhcEnv, + hscEnvWithImportPaths, + prettyPrint, runAction, + textToStringBuffer, + toNormalizedFilePath', + uriToFilePath', useNoFile_, + useWithStale_, use_, uses_) +import Development.IDE.Core.Compile (loadModulesHome, + setupFinderCache) +import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps)) +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 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 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 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 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.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 System.FilePath (takeFileName) -import System.IO (hClose) -import UnliftIO.Temporary (withSystemTempFile) +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) -import GHC.Driver.Session (unitDatabases, unitState) -import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) +import GHC.Driver.Session (unitDatabases, unitState) +import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else import DynFlags #endif -#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 - {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. @@ -155,36 +127,16 @@ codeLens st plId CodeLensParams{_textDocument} = 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 - | 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 - 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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs new file mode 100644 index 0000000000..0fadaad71b --- /dev/null +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where + +import qualified Data.Map.Strict as Map +import Development.IDE (GetParsedModuleWithComments (GetParsedModuleWithComments), + Rules, + defineNoDiagnostics, + fromNormalizedFilePath, + realSrcSpanToRange, + useWithStale_) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat as SrcLoc +import qualified Development.IDE.GHC.Compat.Util as FastString +import Ide.Plugin.Eval.Types + + +rules :: Rules () +rules = do + evalParsedModuleRule + +#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 = defineNoDiagnostics $ \GetEvalComments nfp -> do + (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp + return $ Just $ + 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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 63c30e1b1e..6927c29ce9 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} @@ -26,19 +27,21 @@ module Ide.Plugin.Eval.Types unLoc, Txt, EvalParams(..), + GetEvalComments(..) ) 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 +95,20 @@ data Test | 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) +instance NFData Comments + newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} deriving (Show, Eq, Ord) deriving newtype @@ -107,6 +118,7 @@ newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} , P.VisualStream , Semigroup , Monoid + , NFData ) newtype RawLineComment = RawLineComment {getRawLineComment :: String} @@ -118,6 +130,7 @@ newtype RawLineComment = RawLineComment {getRawLineComment :: String} , P.VisualStream , Semigroup , Monoid + , NFData ) instance Semigroup Comments where From 2a08f050b1378cff2d9df6ae3ea9e5f619bf2cff Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 23 Oct 2021 14:27:14 +0100 Subject: [PATCH 3/9] override NeedsCompilation rule in eval plugin to generate linkables when Evaluating In addition, we tune the newness check of the redefined NeedsCompilation rule so that the generated linkables are not thrown away unnecessarily, as described in: https://github.com/ndmitchell/shake/issues/794 --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 5 ++ ghcide/src/Development/IDE/Core/Rules.hs | 31 ++++---- ghcide/src/Development/IDE/Core/Shake.hs | 22 ++++-- .../src/Development/IDE/Types/Diagnostics.hs | 6 +- haskell-language-server.cabal | 2 +- .../IDE/Graph/Internal/Database.hs | 8 +-- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 4 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 8 +++ .../src/Ide/Plugin/Eval/Rules.hs | 70 +++++++++++++++++-- .../src/Ide/Plugin/Eval/Types.hs | 6 +- 10 files changed, 128 insertions(+), 34 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e1cb3c899e..e9e99d40d8 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -49,6 +49,11 @@ data LinkableType = ObjectLinkable | BCOLinkable instance Hashable LinkableType instance NFData LinkableType +encodeLinkableType :: Maybe LinkableType -> ByteString +encodeLinkableType Nothing = "0" +encodeLinkableType (Just BCOLinkable) = "1" +encodeLinkableType (Just ObjectLinkable) = "2" + -- NOTATION -- Foo+ means Foo for the dependencies -- Foo* means Foo for me and Foo+ diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e08606ff58..f8cb18fcdc 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -50,6 +50,7 @@ module Development.IDE.Core.Rules( getHieAstsRule, getBindingsRule, needsCompilationRule, + computeLinkableTypeForDynFlags, generateCoreRule, getImportMapRule, regenerateHiFile, @@ -987,8 +988,9 @@ usePropertyAction kn plId p = do getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -needsCompilationRule :: Rules () -needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do +-- needsCompilationRule :: Rules () +needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule file = do graph <- useNoFile GetModuleGraph res <- case graph of -- Treat as False if some reverse dependency header fails to parse @@ -1012,14 +1014,11 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) - pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res) + pure (Just $ encodeLinkableType res, Just res) where uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - unboxed_tuples_or_sums (ms_hspp_opts -> d) = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType computeLinkableType this deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we @@ -1027,15 +1026,22 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile where - -- How should we compile this module? (assuming we do in fact need to compile it) - -- Depends on whether it uses unboxed tuples or sums - this_type + this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this) + +-- | How should we compile this module? +-- (assuming we do in fact need to compile it). +-- Depends on whether it uses unboxed tuples or sums +computeLinkableTypeForDynFlags :: DynFlags -> LinkableType +computeLinkableTypeForDynFlags d #if defined(GHC_PATCHED_UNBOXED_BYTECODE) = BCOLinkable #else - | unboxed_tuples_or_sums this = ObjectLinkable - | otherwise = BCOLinkable + | unboxed_tuples_or_sums = ObjectLinkable + | otherwise = BCOLinkable #endif + where + unboxed_tuples_or_sums = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } @@ -1074,7 +1080,8 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - needsCompilationRule + defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> + needsCompilationRule file generateCoreRule getImportMapRule getAnnotatedParsedSourceRule diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index cd90999b8d..3aae69b998 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -871,7 +871,10 @@ usesWithStale key files = do data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) - + | RuleWithCustomNewnessCheck + { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool + , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) + } -- | Define a new Rule with early cutoff defineEarlyCutoff @@ -879,9 +882,14 @@ defineEarlyCutoff => RuleBody k v -> Rules () defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' True key file old mode $ op key file + defineEarlyCutoff' True (==) key file old mode $ op key file defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file + defineEarlyCutoff' False (==) key file old mode $ second (mempty,) <$> op key file +defineEarlyCutoff RuleWithCustomNewnessCheck{..} = + addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> + otTracedAction key file mode traceA $ + defineEarlyCutoff' False newnessCheck key file old mode $ + second (mempty,) <$> build key file defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = defineNoDiagnostics $ \k file -> do @@ -896,13 +904,15 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> d defineEarlyCutoff' :: IdeRule k v => Bool -- ^ update diagnostics + -- | compare current and previous for freshness + -> (BS.ByteString -> BS.ByteString -> Bool) -> k -> NormalizedFilePath -> Maybe BS.ByteString -> RunMode -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) -defineEarlyCutoff' doDiagnostics key file old mode action = do +defineEarlyCutoff' doDiagnostics cmp key file old mode action = do extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do @@ -947,8 +957,8 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d] let eq = case (bs, fmap decodeShakeValue old) of - (ShakeResult a, Just (ShakeResult b)) -> a == b - (ShakeStale a, Just (ShakeStale b)) -> a == b + (ShakeResult a, Just (ShakeResult b)) -> cmp a b + (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result -- or we got ShakeNoCutoff we always return False. _ -> False diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index ce13bc3d3f..77c8ae5c6f 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -14,7 +14,7 @@ module Development.IDE.Types.Diagnostics ( ideErrorWithSource, showDiagnostics, showDiagnosticsColored, - ) where + IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq import Data.Maybe as Maybe @@ -29,6 +29,7 @@ import Language.LSP.Types as LSP (Diagnostic (. DiagnosticSource, List (..)) +import Data.ByteString (ByteString) import Development.IDE.Types.Location @@ -44,6 +45,9 @@ import Development.IDE.Types.Location -- not propagate diagnostic errors through multiple phases. type IdeResult v = ([FileDiagnostic], Maybe v) +-- | an IdeResult with a fingerprint +type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) + ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 0002f6932b..bc12321681 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -212,7 +212,7 @@ common haddockComments common eval if flag(eval) || flag(all-plugins) - build-depends: hls-eval-plugin ^>=1.1.0.0 + build-depends: hls-eval-plugin ^>=1.2.0.0 cpp-options: -Deval common importLens diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index c8acc76de7..5717831c7b 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -168,9 +168,9 @@ compute db@Database{..} key id mode result = do actualDeps = if runChanged /= ChangedNothing then deps else previousDeps previousDeps= maybe UnknownDeps resultDeps result let res = Result runValue built' changed built actualDeps execution runStore - case actualDeps of - ResultDeps deps | not(null deps) && - runChanged /= ChangedNothing + case getResultDepsDefault [] actualDeps of + deps | not(null deps) + && runChanged /= ChangedNothing -> do void $ forkIO $ updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps) @@ -284,7 +284,7 @@ mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one mapConcurrentlyAIO_ f many = do ref <- AIO ask waits <- liftIO $ uninterruptibleMask $ \restore -> do - waits <- liftIO $ traverse waitOrSpawn (map (fmap (restore . f)) many) + waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many let asyncs = rights waits liftIO $ atomicModifyIORef'_ ref (asyncs ++) return waits diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 5ef4565219..9e3cf57a19 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/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.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -85,7 +85,7 @@ library , unordered-containers 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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2c1c3a6469..eb5dd3294b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -51,6 +51,7 @@ import Development.IDE (Action, GetDependencies (..), HiFileResult (hirHomeMod, hirModSummary), HscEnvEq, IdeState, ModSummaryResult (..), + NeedsCompilation (NeedsCompilation), evalGhcEnv, hscEnvWithImportPaths, prettyPrint, runAction, @@ -109,7 +110,10 @@ import UnliftIO.Temporary (withSystemTempFile) import GHC.Driver.Session (unitDatabases, unitState) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else +import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Types.Shake (toKey) import DynFlags +import Ide.Plugin.Eval.Rules (queueForEvaluation) #endif @@ -196,6 +200,10 @@ runEvalCmd st EvalParams{..} = 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 $ diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 0fadaad71b..dfca81fabc 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -3,25 +3,54 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where +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 Development.IDE (GetParsedModuleWithComments (GetParsedModuleWithComments), - Rules, - defineNoDiagnostics, +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 @@ -37,10 +66,9 @@ pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif evalParsedModuleRule :: Rules () -evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do +evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp - return $ Just $ - foldMap (\case + let comments = foldMap (\case L (RealSrcSpanAlready real) bdy | FastString.unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp @@ -59,3 +87,31 @@ evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do _ -> 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/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 6927c29ce9..26d410e18a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Eval.Types ( locate, @@ -28,7 +29,7 @@ module Ide.Plugin.Eval.Types Txt, EvalParams(..), GetEvalComments(..) - ) + ,nullComments) where import Control.DeepSeq (deepseq) @@ -107,6 +108,9 @@ data Comments = Comments } deriving (Show, Eq, Ord, Generic) +nullComments :: Comments -> Bool +nullComments Comments{..} = null lineComments && null blockComments + instance NFData Comments newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} From 130088495a69143f6e53b61f2d29988825201105 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 11:18:53 +0100 Subject: [PATCH 4/9] getLastBuildKeys --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- ghcide/src/Development/IDE/Plugin/Test.hs | 11 ++++++++--- ghcide/test/src/Development/IDE/Test.hs | 14 +++++++++++--- .../src/Development/IDE/Graph/Database.hs | 12 +++++++++++- hls-test-utils/src/Test/Hls.hs | 18 +++++++++++++----- 5 files changed, 44 insertions(+), 13 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3aae69b998..60b7c34fe3 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -24,7 +24,7 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, shakeSessionInit, shakeExtras, + IdeState, shakeSessionInit, shakeExtras, shakeDb, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, IdeRule, IdeResult, diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 9c3f37c13a..965c05c27e 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -27,6 +27,7 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) +import Development.IDE.Graph.Database (shakeLastBuildKeys) import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) @@ -38,10 +39,11 @@ import System.Time.Extra data TestRequest = BlockSeconds Seconds -- ^ :: Null - | GetInterfaceFilesDir FilePath -- ^ :: String + | GetInterfaceFilesDir Uri -- ^ :: String | GetShakeSessionQueueCount -- ^ :: Number | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult + | GetLastBuildKeys -- ^ :: [String] deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -70,8 +72,8 @@ testRequestHandler _ (BlockSeconds secs) = do toJSON secs liftIO $ sleep secs return (Right Null) -testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do - let nfp = toNormalizedFilePath fp +testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do + let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp let hiPath = hiDir $ hsc_dflags $ hscEnv sess return $ Right (toJSON hiPath) @@ -88,6 +90,9 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success return $ bimap mkResponseError toJSON res +testRequestHandler s GetLastBuildKeys = liftIO $ do + keys <- shakeLastBuildKeys $ shakeDb s + return $ Right $ toJSON $ map show keys mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 88f00741fc..f0710b5d61 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -20,6 +20,7 @@ module Development.IDE.Test , standardizeQuotes , flushMessages , waitForAction + , getLastBuildKeys ) where import Control.Applicative.Combinators @@ -169,13 +170,20 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) -waitForAction key TextDocumentIdentifier{_uri} = do +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin cmd = do let cm = SCustomMethod "test" - waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + waitId <- sendRequest cm (A.toJSON cmd) ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ do e <- _result case A.fromJSON e of A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing A.Success a -> pure a + +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = + callTestPlugin (WaitForIdeRule key _uri) + +getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys = callTestPlugin GetLastBuildKeys diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index bf415a1f6e..5a4d083e7b 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -8,13 +8,16 @@ module Development.IDE.Graph.Database( shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, + shakeLastBuildKeys ) where import Data.Dynamic +import Data.IORef import Data.Maybe -import Development.IDE.Graph.Classes () +import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database +import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules @@ -56,3 +59,10 @@ shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO () shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s + +-- | Returns the set of keys built in the most recent step +shakeLastBuildKeys :: ShakeDatabase -> IO [Key] +shakeLastBuildKeys (ShakeDatabase _ _ db) = do + keys <- Ids.elems $ databaseValues db + step <- readIORef $ databaseStep db + return [ k | (k, Clean res) <- keys, resultBuilt res == step ] diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index dec2542f7a..8235c4b260 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -27,7 +27,8 @@ module Test.Hls waitForBuildQueue, waitForTypecheck, waitForAction, - sendConfigurationChanged) + sendConfigurationChanged, + getLastBuildKeys) where import Control.Applicative.Combinators @@ -47,7 +48,7 @@ import Development.IDE (IdeState, noLogging) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main import qualified Development.IDE.Main as Ghcide -import Development.IDE.Plugin.Test (TestRequest (WaitForIdeRule, WaitForShakeQueue), +import Development.IDE.Plugin.Test (TestRequest (GetLastBuildKeys, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import Development.IDE.Types.Options import GHC.IO.Handle @@ -216,10 +217,10 @@ waitForBuildQueue = do -- assume a ghcide binary lacking the WaitForShakeQueue method _ -> return 0 -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) -waitForAction key TextDocumentIdentifier{_uri} = do +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin cmd = do let cm = SCustomMethod "test" - waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + waitId <- sendRequest cm (A.toJSON cmd) ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ do e <- _result @@ -227,9 +228,16 @@ waitForAction key TextDocumentIdentifier{_uri} = do A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing A.Success a -> pure a +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = + callTestPlugin (WaitForIdeRule key _uri) + waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool) waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid +getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys = callTestPlugin GetLastBuildKeys + sendConfigurationChanged :: Value -> Session () sendConfigurationChanged config = sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) From 01e9bbefa31db9cc91bfd93180007d12c39f5f0d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 23 Oct 2021 14:41:16 +0100 Subject: [PATCH 5/9] Test that the linkables are being produced --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 5 +++-- plugins/hls-eval-plugin/test/Main.hs | 21 +++++++++++++++++-- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 9e3cf57a19..e37acde140 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -100,7 +100,7 @@ test-suite tests 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/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index eb5dd3294b..e2ee0e4c6b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -27,7 +27,7 @@ module Ide.Plugin.Eval.CodeLens ( import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second, (>>>)) -import Control.Exception (try) +import Control.Exception (assert, try) import qualified Control.Exception as E import Control.Lens (_1, _3, (%~), (<&>), (^.)) import Control.Monad (guard, join, void, when) @@ -38,7 +38,7 @@ import Data.Char (isSpace) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T @@ -539,6 +539,7 @@ ghcSessionDepsDefinition env file = do deps <- use_ GetDependencies file let tdeps = transitiveModuleDeps deps ifaces <- uses_ GetModIface tdeps + liftIO $ assert (all (isJust . hm_linkable . hirHomeMod) ifaces) $ pure () -- 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. diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index f1faceeb16..2e66d599c1 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -7,18 +7,19 @@ module Main ( 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 @@ tests = "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 From de4a3f5c7b96c5ff8ee2e088b6a94cfd58ffa7e2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 14:52:18 +0100 Subject: [PATCH 6/9] honor LSP_TEST_LOG_STDERR --- hls-test-utils/src/Test/Hls.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 8235c4b260..9d4014a7e5 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -41,6 +41,7 @@ import Data.Aeson (Value (Null), toJSON) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -63,6 +64,7 @@ import Language.LSP.Types hiding import Language.LSP.Types.Capabilities (ClientCapabilities) import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.Environment (lookupEnv) import System.FilePath import System.IO.Unsafe (unsafePerformIO) import System.Process.Extra (createPipe) @@ -159,6 +161,12 @@ runSessionWithServer' :: runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do (inR, inW) <- createPipe (outR, outW) <- createPipe + let logger = do + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + if logStdErr == "0" + then return noLogging + else argsLogger testing + server <- async $ Ghcide.defaultMain @@ -166,7 +174,7 @@ runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurren { argsHandleIn = pure inR, argsHandleOut = pure outW, argsDefaultHlsConfig = conf, - argsLogger = pure noLogging, + argsLogger = logger, argsIdeOptions = \config sessionLoader -> let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, From 6d4abbcaace4f5f0c1b1934566fab1522d5e801e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 19:12:15 +0100 Subject: [PATCH 7/9] add comments and use custom newness check in ghcide too --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 3 +++ ghcide/src/Development/IDE/Core/Rules.hs | 8 +++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e9e99d40d8..b7ceb89d22 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -49,6 +49,9 @@ data LinkableType = ObjectLinkable | BCOLinkable instance Hashable LinkableType instance NFData LinkableType +-- | Encode the linkable into an ordered bytestring. +-- This is used to drive an ordered "newness" predicate in the +-- 'NeedsCompilation' build rule. encodeLinkableType :: Maybe LinkableType -> ByteString encodeLinkableType Nothing = "0" encodeLinkableType (Just BCOLinkable) = "1" diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index f8cb18fcdc..23fa70d3df 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -1080,7 +1080,13 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> + -- This rule uses a custom newness check that relies on the encoding + -- produced by 'encodeLinkable'. This works as follows: + -- * -> + -- * ObjectLinkable -> BCOLinkable : the prev linkable can be reused, signal "no change" + -- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change" + -- * otherwise : the prev linkable cannot be reused, signal "value has changed" + defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> needsCompilationRule file generateCoreRule getImportMapRule From f941f9363058b82ff8e01f0058a959b91abf36fc Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 20:22:23 +0100 Subject: [PATCH 8/9] fix build --- ghcide/test/exe/Main.hs | 15 +++++---------- ghcide/test/src/Development/IDE/Test.hs | 4 ++++ 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cebecff33e..ad54f5d6be 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,7 +50,7 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction) + waitForAction, getInterfaceFilesDir) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -95,7 +95,7 @@ import Data.Tuple.Extra import Development.IDE.Core.FileStore (getModTime) import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) import Ide.PluginUtils (pluginDescToIdePlugins) @@ -5249,14 +5249,9 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Check that we wrote the interfaces for B when we saved - let m = SCustomMethod "test" - lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath - res <- skipManyTill anyMessage $ responseForId m lid - liftIO $ case res of - ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do - hi_exists <- doesFileExist $ hidir "B.hi" - assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res + Right hidir <- getInterfaceFilesDir bdoc + hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" + liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists pdoc <- createDoc pPath "haskell" pSource changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index f0710b5d61..35ae059500 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -21,6 +21,7 @@ module Development.IDE.Test , flushMessages , waitForAction , getLastBuildKeys + , getInterfaceFilesDir ) where import Control.Applicative.Combinators @@ -187,3 +188,6 @@ waitForAction key TextDocumentIdentifier{_uri} = getLastBuildKeys :: Session (Either ResponseError [T.Text]) getLastBuildKeys = callTestPlugin GetLastBuildKeys + +getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) +getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) From b3f4e9a5cde31b69d2fe05d3acc1e7fbbc3d8db7 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 24 Oct 2021 23:17:56 +0100 Subject: [PATCH 9/9] fix 9.0 build --- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index e2ee0e4c6b..41dea1bd48 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -82,6 +82,8 @@ import GHC (ClsInst, setTargets, typeKind) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) +import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Types.Shake (toKey) import Ide.Plugin.Eval.Code (Statement, asStatements, evalSetup, myExecStmt, propSetup, resultRange, @@ -90,6 +92,7 @@ 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, @@ -110,10 +113,7 @@ import UnliftIO.Temporary (withSystemTempFile) import GHC.Driver.Session (unitDatabases, unitState) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else -import Development.IDE.Core.FileStore (setSomethingModified) -import Development.IDE.Types.Shake (toKey) import DynFlags -import Ide.Plugin.Eval.Rules (queueForEvaluation) #endif