From 229faac11a517efdd75f7d23afce9daa6345259e Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Mon, 25 Oct 2021 02:38:34 +0100
Subject: [PATCH] Generate linkables in the Eval plugin (#2295)
* [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.
* extract GetEvalComments rule
* 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
* getLastBuildKeys
* Test that the linkables are being produced
* honor LSP_TEST_LOG_STDERR
* add comments and use custom newness check in ghcide too
* fix build
* fix 9.0 build
---
ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 +
ghcide/src/Development/IDE/Core/Rules.hs | 37 ++-
ghcide/src/Development/IDE/Core/Shake.hs | 24 +-
ghcide/src/Development/IDE/Plugin/Test.hs | 11 +-
.../src/Development/IDE/Types/Diagnostics.hs | 6 +-
ghcide/test/exe/Main.hs | 15 +-
ghcide/test/src/Development/IDE/Test.hs | 18 +-
haskell-language-server.cabal | 2 +-
.../src/Development/IDE/Graph/Database.hs | 12 +-
.../IDE/Graph/Internal/Database.hs | 22 +-
.../Development/IDE/Graph/Internal/Profile.hs | 54 ++--
.../Development/IDE/Graph/Internal/Types.hs | 3 +-
hls-test-utils/src/Test/Hls.hs | 28 ++-
plugins/hls-eval-plugin/hls-eval-plugin.cabal | 8 +-
.../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 2 +
.../src/Ide/Plugin/Eval/CodeLens.hs | 231 ++++++++----------
.../src/Ide/Plugin/Eval/Rules.hs | 117 +++++++++
.../src/Ide/Plugin/Eval/Types.hs | 39 ++-
plugins/hls-eval-plugin/test/Main.hs | 21 +-
19 files changed, 428 insertions(+), 230 deletions(-)
create mode 100644 plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs
diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs
index e1cb3c89..b7ceb89d 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 e08606ff..23fa70d3 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:
+ -- * <previous> -> <new>
+ -- * 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 cd90999b..60b7c34f 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 9c3f37c1..965c05c2 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 ce13bc3d..77c8ae5c 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 cebecff3..ad54f5d6 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 88f00741..35ae0595 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 0002f693..bc123216 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 bf415a1f..5a4d083e 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 38aa19a1..5717831c 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 57b307a7..86afdb47 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 f6c41da1..3adc0698 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 dec2542f..9d4014a7 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 16232b61..e37acde1 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 <https://github.com/haskell/haskell-language-server#readme>
@@ -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 0c2d45bc..df2184c2 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 10b82027..41dea1bd 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 00000000..dfca81fa
--- /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 63c30e1b..26d410e1 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 f1faceeb..2e66d599 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
--
GitLab