Add support for persistent stale values

src/Development/IDE/Core/Rules.hs

@@ -152,7 +152,7 @@ highlightAtPoint file pos = runMaybeT $ do
     AtPoint.documentHighlight hf rf pos'
 
 getHieFile
-  :: IdeState
+  :: ShakeExtras
   -> NormalizedFilePath -- ^ file we're editing
   -> Module -- ^ module dep we want info for
   -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module
@@ -197,7 +197,7 @@ getHomeHieFile f = do
           MaybeT $ pure $ join mhf
 
 
-getPackageHieFile :: IdeState
+getPackageHieFile :: ShakeExtras
                   -> Module             -- ^ Package Module to load .hie file for
                   -> NormalizedFilePath -- ^ Path of home module importing the package module
                   -> MaybeT IdeAction (HieFile, FilePath)
@@ -460,7 +460,7 @@ getDocMapRule =
       hsc <- hscEnv <$> use_ GhcSession file
       PRefMap rf <- use_ GetRefMap file
 
-      deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
+      (deps,_) <- useWithStale GetDependencies file
       let tdeps = transitiveModuleDeps deps
 
 -- When possible, rely on the haddocks embedded in our interface files

src/Development/IDE/Core/Service.hs

@@ -87,7 +87,7 @@ getIdeOptions = do
     GlobalIdeOptions x <- getIdeGlobalAction
     return x
 
-getIdeOptionsIO :: IdeState -> IO IdeOptions
+getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
 getIdeOptionsIO ide = do
-    GlobalIdeOptions x <- getIdeGlobalState ide
+    GlobalIdeOptions x <- getIdeGlobalExtras ide
     return x

src/Development/IDE/Core/Shake.hs

@@ -34,6 +34,7 @@ module Development.IDE.Core.Shake(
     getDiagnostics, unsafeClearDiagnostics,
     getHiddenDiagnostics,
     IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
+    getIdeGlobalExtras,
     garbageCollect,
     knownFiles,
     setPriority,
@@ -47,7 +48,8 @@ module Development.IDE.Core.Shake(
     OnDiskRule(..),
 
     workerThread, delay, DelayedAction, mkDelayedAction,
-    IdeAction(..), runIdeAction, askShake, mkUpdater
+    IdeAction(..), runIdeAction, askShake, mkUpdater,
+    addPersistentRule
     ) where
 
 import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
@@ -105,6 +107,8 @@ import NameCache
 import UniqSupply
 import PrelInfo
 
+import System.IO
+
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
     {eventer :: LSP.FromServerMessage -> IO ()
@@ -126,8 +130,11 @@ data ShakeExtras = ShakeExtras
     -- ^ How many rules are running for each file
     , queue :: ShakeQueue
     , ideNc :: IORef NameCache
+    , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent)
     }
 
+type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe Dynamic)
+
 getShakeExtras :: Action ShakeExtras
 getShakeExtras = do
     Just x <- getShakeExtra @ShakeExtras
@@ -138,6 +145,13 @@ getShakeExtrasRules = do
     Just x <- getShakeExtraRules @ShakeExtras
     return x
 
+addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe v)) -> Rules ()
+addPersistentRule k getVal = do
+  ShakeExtras{persistentKeys} <- getShakeExtrasRules
+  liftIO $ modifyVar_ persistentKeys $ \hm -> do
+    pure $ HMap.insert (Key k) (\f -> fmap toDyn <$> getVal f) hm
+  return ()
+
 class Typeable a => IsIdeGlobal a where
 
 addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
@@ -206,20 +220,35 @@ currentValue Failed = Nothing
 
 -- | Return the most recent, potentially stale, value and a PositionMapping
 -- for the version of that value.
-lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
-lastValueIO ShakeExtras{positionMapping} file v = do
-    allMappings <- liftIO $ readVar positionMapping
-    pure $ case v of
-        Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
-        Stale ver v -> Just (v, mappingForVersion allMappings file ver)
-        Failed -> Nothing
+lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
+lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
+  modifyVar state $ \hm -> do
+    allMappings <- readVar positionMapping
+    let readPersistent = do
+          pmap <- readVar persistentKeys
+          mv <- runMaybeT $ do
+            f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
+            liftIO $ hPutStrLn stderr $ "LOOKUP UP PERSISTENT FOR" ++ show k
+            dv <- MaybeT $ runIdeAction "lastValueIO" s $ f file
+            MaybeT $ pure $ fromDynamic dv
+          case mv of
+            Nothing -> pure (hm,Nothing)
+            Just v -> pure (HMap.insert (file,Key k) (Stale Nothing (toDyn v)) hm, Just (v,zeroMapping))
+    case HMap.lookup (file,Key k) hm of
+      Nothing -> readPersistent
+      Just v -> case v of
+        Succeeded ver (fromDynamic -> Just v) -> pure (hm, Just (v, mappingForVersion allMappings file ver))
+        Stale ver (fromDynamic -> Just v) -> pure (hm, Just (v, mappingForVersion allMappings file ver))
+        _ -> do
+          hPutStrLn stderr "FAILED, LOOKING UP PERSISTENT"
+          readPersistent
 
 -- | Return the most recent, potentially stale, value and a PositionMapping
 -- for the version of that value.
-lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
-lastValue file v = do
+lastValue :: IdeRule k v => k -> NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
+lastValue key file v = do
     s <- getShakeExtras
-    liftIO $ lastValueIO s file v
+    liftIO $ lastValueIO s key file
 
 valueVersion :: Value v -> Maybe TextDocumentVersion
 valueVersion = \case
@@ -537,6 +566,7 @@ shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress r
         hiddenDiagnostics <- newVar mempty
         publishedDiagnostics <- newVar mempty
         positionMapping <- newVar HMap.empty
+        persistentKeys <- newVar HMap.empty
         let queue = shakeQueue
         pure ShakeExtras{..}
     (shakeDb, shakeClose) <-
@@ -614,7 +644,7 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
 -- has already finished as is the case with useWithStaleFast
 delayedAction :: DelayedAction () -> IdeAction ()
 delayedAction a = do
-  sq <- shakeQueue <$> ask
+  sq <- queue <$> ask
   void $ liftIO $ queueAction [a] sq
 
 -- | A varient of delayedAction for the Action monad
@@ -733,19 +763,21 @@ use :: IdeRule k v
 use key file = head <$> uses key [file]
 
 useWithStale :: IdeRule k v
-    => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
-useWithStale key file = head <$> usesWithStale key [file]
+    => k -> NormalizedFilePath -> Action (v, PositionMapping)
+useWithStale key file = do
+  Just v <- head <$> usesWithStale key [file]
+  pure v
 
-newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT IdeState IO) a }
-    deriving (MonadReader IdeState, MonadIO, Functor, Applicative, Monad)
+newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
+    deriving (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
 
-runIdeAction :: String -> IdeState -> IdeAction a -> IO a
+runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
 runIdeAction _herald s i = do
     res <- runReaderT (runIdeActionT i) s
     return res
 
 askShake :: IdeAction ShakeExtras
-askShake = shakeExtras <$> ask
+askShake = ask
 
 mkUpdater :: MaybeT IdeAction NameCacheUpdater
 mkUpdater = do
@@ -761,19 +793,9 @@ useWithStaleFast' key file = do
     -- This lookup directly looks up the key in the shake database and
     -- returns the last value that was computed for this key without
     -- checking freshness.
+    s <- askShake
+    liftIO $ lastValueIO s key file
 
-    s@ShakeExtras{state} <- askShake
-    r <- liftIO $ getValues state key file
-    case r of
-      Nothing -> do
-        -- Perhaps for Hover this should return Nothing immediatey but for
-        -- completions it should block? Not for MP to decide, need AZ and
-        -- F to comment
-        return Nothing
-        --useWithStale key file
-      -- Otherwise, use the computed value even if it's out of date.
-      Just v -> do
-        liftIO $ lastValueIO s file v
   -- Then async trigger the key to be built anyway because we want to
   -- keep updating the value in the key.
   --shakeRunInternal ("C:" ++ (show key)) ide [use key file]
@@ -856,7 +878,7 @@ usesWithStale :: IdeRule k v
     => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
 usesWithStale key files = do
     values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
-    zipWithM lastValue files values
+    zipWithM (lastValue key) files values
 
 
 withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

src/Development/IDE/LSP/HoverDefinition.hs

@@ -69,4 +69,4 @@ logAndRunRequest label getResults ide pos path = do
   logInfo (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
     " in file: " <> T.pack path
-  runIdeAction (T.unpack label) ide (getResults filePath pos)
+  runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

src/Development/IDE/LSP/Outline.hs

@@ -40,7 +40,7 @@ moduleOutline
 moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
   = case uriToFilePath uri of
     Just (toNormalizedFilePath' -> fp) -> do
-      mb_decls <- fmap fst <$> runIdeAction "Outline" ideState (useWithStaleFast GetParsedModule fp)
+      mb_decls <- fmap fst <$> runIdeAction "Outline" (shakeExtras ideState) (useWithStaleFast GetParsedModule fp)
       pure $ Right $ case mb_decls of
         Nothing -> DSDocumentSymbols (List [])
         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

src/Development/IDE/Plugin/CodeAction.hs

@@ -98,7 +98,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
     fmap (Right . List) $ case uriToFilePath' uri of
       Just (toNormalizedFilePath' -> filePath) -> do
         -- Needs to be delayed action
-        _ <- runIdeAction "codeLens" ideState $ (runMaybeT $ useE TypeCheck filePath)
+        _ <- runIdeAction "codeLens" (shakeExtras ideState) $ (runMaybeT $ useE TypeCheck filePath)
         diag <- getDiagnostics ideState
         hDiag <- getHiddenDiagnostics ideState
         pure

src/Development/IDE/Plugin/Completions.hs

@@ -49,14 +49,11 @@ produceCompletions =
         deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
 #endif
-        tm <- fmap fst <$> useWithStale TypeCheck file
-        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
-        case (tm, packageState) of
-            (Just tm', Just packageState') -> do
-                cdata <- liftIO $ cacheDataProducer packageState'
-                                                    (tmrModule tm') parsedDeps
-                return ([], Just cdata)
-            _ -> return ([], Nothing)
+        tm <- fst <$> useWithStale TypeCheck file
+        packageState <- hscEnv . fst <$> useWithStale GhcSession file
+        cdata <- liftIO $ cacheDataProducer packageState
+                                            (tmrModule tm) parsedDeps
+        return ([], Just cdata)
 
 
 -- | Produce completions info for a file
@@ -87,8 +84,8 @@ getCompletionsLSP lsp ide
       fmap Right $ case (contents, uriToFilePath' uri) of
         (Just cnts, Just path) -> do
           let npath = toNormalizedFilePath' path
-          (ideOpts, compls) <- runIdeAction "Completion" ide $ do
-              opts <- liftIO $ getIdeOptionsIO ide
+          (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do
+              opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
               compls <- useWithStaleFast ProduceCompletions npath
               pm <- useWithStaleFast GetParsedModule npath
               pure (opts, liftA2 (,) compls pm)