diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e1cb3c899e..b7ceb89d22 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -49,6 +49,14 @@ 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" +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..23fa70d3df 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,14 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - needsCompilationRule + -- 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 getAnnotatedParsedSourceRule diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index cd90999b8d..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, @@ -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/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/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/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 88f00741fc..35ae059500 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -20,6 +20,8 @@ module Development.IDE.Test , standardizeQuotes , flushMessages , waitForAction + , getLastBuildKeys + , getInterfaceFilesDir ) where import Control.Applicative.Combinators @@ -169,13 +171,23 @@ 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 + +getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) +getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) 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/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-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 38aa19a160..5717831c7b 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) @@ -171,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) @@ -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 @@ -278,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/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)), diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index dec2542f7a..9d4014a7e5 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 @@ -40,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 @@ -47,7 +49,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 @@ -62,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) @@ -158,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 @@ -165,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}}, @@ -216,10 +225,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 +236,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) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 16232b61cc..e37acde140 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 @@ -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 @@ -83,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 @@ -98,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.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..41dea1bd48 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,97 @@ 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 (assert, 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, isJust) +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 (..), + NeedsCompilation (NeedsCompilation), + 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 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 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 +131,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 @@ -244,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 $ @@ -579,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/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs new file mode 100644 index 0000000000..dfca81fabc --- /dev/null +++ b/plugins/hls-eval-plugin/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/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 63c30e1b1e..26d410e18a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/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 @@ module Ide.Plugin.Eval.Types 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 @@ 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) +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 @@ newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String} , P.VisualStream , Semigroup , Monoid + , NFData ) newtype RawLineComment = RawLineComment {getRawLineComment :: String} @@ -118,6 +134,7 @@ newtype RawLineComment = RawLineComment {getRawLineComment :: String} , P.VisualStream , Semigroup , Monoid + , NFData ) instance Semigroup Comments where 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