diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs
index e1cb3c899e20f77df5a0478d17e773fec092fa8d..b7ceb89d226c3d8cc2ed9a28a57122c04f69372e 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 e08606ff583a2e078b2b9f5473d3de7356a679f7..23fa70d3df12b0e89a6e2acb435631c2b6cc985e 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 cd90999b8d9ad6721a22fee033ddf66fd646d596..60b7c34fe32ada2debff05d80557f6d81e371d8a 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 9c3f37c13a467c930ef04f52ab7deb6ae4178f29..965c05c27eee1c245844e8bda652a448f80cac93 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 ce13bc3d3fbf37831d712b1837904e7d4c0740d6..77c8ae5c6fb12081f4b567de97e0c68b65485b91 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 cebecff33ec08b1e34d4f16c3172b97bf7e61ff6..ad54f5d6be1bdb4e2bf55547ccd249430a10867f 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 88f00741fc2b5da5a5bb21f4e669ca81f2498759..35ae059500e82d02b356b270cfcc659f7bc366ad 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 0002f6932b6dec7aa0f0c412644e13eec992fde1..bc1232168181eb7cec95ed70f68f6156ec2681a9 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 bf415a1f6e1b941e363e8e366017dff43594e49f..5a4d083e7b2a2e4686b4ee0dacbcef17c4d91a9e 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 38aa19a16054902c7eb1b9d3bc43eb639e7b0564..5717831c7b3ba5a5cc711a0e0f009d305c0ab442 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 57b307a7a93b64dbb0d912ca6356424352995140..86afdb47ae822194972f13d8db0cf061ae68b63f 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 f6c41da1f5774f3d692cf751d881ae4ad99605fa..3adc0698d5697b8db86aa7b458040df194fbbcc0 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 dec2542f7ac9848c965796746c6a62ad4c943d0c..9d4014a7e5a74827a975565df274e21348934b07 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 16232b61cc1e4930b0f0420071aa5e1610f065ff..e37acde140c5d1df747324a8021f4d5e70dc89a5 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 0c2d45bc25ac8efcbdabc4aeeb3c7fa001ae4b9f..df2184c2fc4ab9c425d941f11c673473fef1bff0 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 10b82027a556894d3fe68562eebde4d81665a4bf..41dea1bd482f283a668d838e31a4d022a38b3839 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 0000000000000000000000000000000000000000..dfca81fabc61c35d0997f64740a0d1ef17e8e450
--- /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 63c30e1b1ea0ac1e888568cf205e0ed8141cfff8..26d410e18ab117f2c99724a16e6407477322e37c 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 f1faceeb16d6187ca5e5ea8c7c610fbd13af261e..2e66d599c1356f02471d9b5f2c81e5b07028b3f3 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