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:

ndmitchell/shake#794

Author: pepeiborra

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -49,6 +49,11 @@ data LinkableType = ObjectLinkable | BCOLinkable
 instance Hashable LinkableType
 instance NFData   LinkableType
 
+encodeLinkableType :: Maybe LinkableType -> ByteString
+encodeLinkableType Nothing               = "0"
+encodeLinkableType (Just BCOLinkable)    = "1"
+encodeLinkableType (Just ObjectLinkable) = "2"
+
 -- NOTATION
 --   Foo+ means Foo for the dependencies
 --   Foo* means Foo for me and Foo+

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,30 +1014,34 @@ 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
       | Just BCOLinkable    `elem` xs     = Just this_type      -- If any dependent needs bytecode, then we need to be compiled
       | any (maybe False uses_th_qq) deps = Just this_type      -- If any dependent needs TH, then we need to be compiled
       | otherwise                         = Nothing             -- If none of these conditions are satisfied, we don't need to compile
       where
-        -- How should we compile this module? (assuming we do in fact need to compile it)
-        -- Depends on whether it uses unboxed tuples or sums
-        this_type
+        this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this)
+
+-- | How should we compile this module?
+-- (assuming we do in fact need to compile it).
+-- Depends on whether it uses unboxed tuples or sums
+computeLinkableTypeForDynFlags :: DynFlags -> LinkableType
+computeLinkableTypeForDynFlags d
 #if defined(GHC_PATCHED_UNBOXED_BYTECODE)
           = BCOLinkable
 #else
-          | unboxed_tuples_or_sums this = ObjectLinkable
-          | otherwise                   = BCOLinkable
+          | unboxed_tuples_or_sums = ObjectLinkable
+          | otherwise              = BCOLinkable
 #endif
+  where
+        unboxed_tuples_or_sums =
+            xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
 
 -- | Tracks which linkables are current, so we don't need to unload them
 newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) }
@@ -1074,7 +1080,8 @@ mainRule = do
     getClientSettingsRule
     getHieAstsRule
     getBindingsRule
-    needsCompilationRule
+    defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file ->
+        needsCompilationRule file
     generateCoreRule
     getImportMapRule
     getAnnotatedParsedSourceRule

ghcide/src/Development/IDE/Core/Shake.hs

@@ -871,17 +871,25 @@ 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
     :: IdeRule k v
     => 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

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)
 

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

hls-graph/src/Development/IDE/Graph/Internal/Database.hs

@@ -168,9 +168,9 @@ compute db@Database{..} key id mode result = do
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
         previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
-    case actualDeps of
-        ResultDeps deps | not(null deps) &&
-                    runChanged /= ChangedNothing
+    case getResultDepsDefault [] actualDeps of
+        deps | not(null deps)
+            && runChanged /= ChangedNothing
                     -> do
             void $ forkIO $
                 updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
@@ -284,7 +284,7 @@ mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one
 mapConcurrentlyAIO_ f many = do
     ref <- AIO ask
     waits <- liftIO $ uninterruptibleMask $ \restore -> do
-        waits <- liftIO $ traverse waitOrSpawn (map (fmap (restore . f)) many)
+        waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many
         let asyncs = rights waits
         liftIO $ atomicModifyIORef'_ ref (asyncs ++)
         return waits

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>
@@ -85,7 +85,7 @@ library
     , unordered-containers
 
   ghc-options:
-    -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors
+    -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -fno-ignore-asserts
 
   if flag(pedantic)
     ghc-options: -Werror

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -51,6 +51,7 @@ import           Development.IDE                 (Action, GetDependencies (..),
                                                   HiFileResult (hirHomeMod, hirModSummary),
                                                   HscEnvEq, IdeState,
                                                   ModSummaryResult (..),
+                                                  NeedsCompilation (NeedsCompilation),
                                                   evalGhcEnv,
                                                   hscEnvWithImportPaths,
                                                   prettyPrint, runAction,
@@ -109,7 +110,10 @@ import           UnliftIO.Temporary              (withSystemTempFile)
 import           GHC.Driver.Session              (unitDatabases, unitState)
 import           GHC.Types.SrcLoc                (UnhelpfulSpanReason (UnhelpfulInteractive))
 #else
+import           Development.IDE.Core.FileStore  (setSomethingModified)
+import           Development.IDE.Types.Shake     (toKey)
 import           DynFlags
+import           Ide.Plugin.Eval.Rules           (queueForEvaluation)
 #endif
 
 
@@ -196,6 +200,10 @@ runEvalCmd st EvalParams{..} =
             let nfp = toNormalizedFilePath' fp
             mdlText <- moduleText _uri
 
+            -- enable codegen
+            liftIO $ queueForEvaluation st nfp
+            liftIO $ setSomethingModified st [toKey NeedsCompilation nfp] "Eval"
+
             session <- runGetSession st nfp
 
             ms <- fmap msrModSummary $

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs

@@ -3,25 +3,54 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where
+module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where
 
+import           Control.Monad.IO.Class               (MonadIO (liftIO))
+import           Data.HashSet                         (HashSet)
+import qualified Data.HashSet                         as Set
+import           Data.IORef
 import qualified Data.Map.Strict                      as Map
-import           Development.IDE                      (GetParsedModuleWithComments (GetParsedModuleWithComments),
-                                                       Rules,
-                                                       defineNoDiagnostics,
+import           Data.String                          (fromString)
+import           Development.IDE                      (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps),
+                                                       GetParsedModuleWithComments (GetParsedModuleWithComments),
+                                                       IdeState,
+                                                       NeedsCompilation (NeedsCompilation),
+                                                       NormalizedFilePath,
+                                                       RuleBody (RuleNoDiagnostics),
+                                                       Rules, defineEarlyCutoff,
+                                                       encodeLinkableType,
                                                        fromNormalizedFilePath,
+                                                       msrModSummary,
                                                        realSrcSpanToRange,
                                                        useWithStale_)
 import           Development.IDE.Core.PositionMapping (toCurrentRange)
+import           Development.IDE.Core.Rules           (computeLinkableTypeForDynFlags,
+                                                       needsCompilationRule)
+import           Development.IDE.Core.Shake           (IsIdeGlobal,
+                                                       RuleBody (RuleWithCustomNewnessCheck),
+                                                       addIdeGlobal,
+                                                       getIdeGlobalAction,
+                                                       getIdeGlobalState)
 import           Development.IDE.GHC.Compat
 import qualified Development.IDE.GHC.Compat           as SrcLoc
 import qualified Development.IDE.GHC.Compat.Util      as FastString
+import           Development.IDE.Graph                (alwaysRerun)
 import           Ide.Plugin.Eval.Types
 
 
 rules :: Rules ()
 rules = do
     evalParsedModuleRule
+    redefinedNeedsCompilation
+    addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)
+
+newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
+instance IsIdeGlobal EvaluatingVar
+
+queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
+queueForEvaluation ide nfp = do
+    EvaluatingVar var <- getIdeGlobalState ide
+    modifyIORef var (Set.insert nfp)
 
 #if MIN_VERSION_ghc(9,0,0)
 pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
@@ -37,10 +66,9 @@ pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
 #endif
 
 evalParsedModuleRule :: Rules ()
-evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do
+evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do
     (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp
-    return $ Just $
-                foldMap (\case
+    let comments = foldMap (\case
                 L (RealSrcSpanAlready real) bdy
                     | FastString.unpackFS (srcSpanFile real) ==
                         fromNormalizedFilePath nfp
@@ -59,3 +87,31 @@ evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do
                 _ -> mempty
             )
             $ apiAnnComments' pm_annotations
+        -- we only care about whether the comments are null
+        -- this is valid because the only dependent is NeedsCompilation
+        fingerPrint = fromString $ if nullComments comments then "" else "1"
+    return (Just fingerPrint, Just comments)
+
+-- Redefine the NeedsCompilation rule to set the linkable type to Just _
+-- whenever the module is being evaluated
+-- This will ensure that the modules are loaded with linkables
+-- and the interactive session won't try to compile them on the fly,
+-- leading to much better performance of the evaluate code lens
+redefinedNeedsCompilation :: Rules ()
+redefinedNeedsCompilation = defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do
+    alwaysRerun
+
+    EvaluatingVar var <- getIdeGlobalAction
+    isEvaluating <- liftIO $ (f `elem`) <$> readIORef var
+
+
+    if not isEvaluating then needsCompilationRule f else do
+        ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f
+        let df' = ms_hspp_opts ms
+            linkableType = computeLinkableTypeForDynFlags df'
+            fp = encodeLinkableType $ Just linkableType
+
+        -- remove the module from the Evaluating state
+        liftIO $ modifyIORef var (Set.delete f)
+
+        pure (Just fp, Just (Just linkableType))

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances       #-}
 {-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE RecordWildCards            #-}
 
 module Ide.Plugin.Eval.Types
     ( locate,
@@ -28,7 +29,7 @@ module Ide.Plugin.Eval.Types
       Txt,
       EvalParams(..),
       GetEvalComments(..)
-    )
+    ,nullComments)
 where
 
 import           Control.DeepSeq               (deepseq)
@@ -107,6 +108,9 @@ data Comments = Comments
     }
     deriving (Show, Eq, Ord, Generic)
 
+nullComments :: Comments -> Bool
+nullComments Comments{..} = null lineComments && null blockComments
+
 instance NFData Comments
 
 newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String}