Wip/shake queue

cabal.project

@@ -0,0 +1,3 @@
+packages: .
+
+allow-newer: ghc, base

exe/Arguments.hs

@@ -14,6 +14,7 @@ data Arguments = Arguments
     ,argsShakeProfiling :: Maybe FilePath
     ,argsTesting :: Bool
     ,argsThreads :: Int
+    ,argsVerbose :: Bool
     }
 
 getArguments :: IO Arguments
@@ -33,3 +34,4 @@ arguments = Arguments
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
+      <*> switch (long "verbose" <> help "Include internal events in logging output")

exe/Main.hs

@@ -58,7 +58,7 @@ import System.Time.Extra
 import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
 import Paths_ghcide
 import Development.GitRev
-import Development.Shake (Action, action)
+import Development.Shake (Action)
 import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as Map
@@ -124,12 +124,13 @@ main = do
             let options = (defaultIdeOptions $ loadSessionShake dir)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
-                    , optTesting        = argsTesting
+                    , optTesting        = IdeTesting argsTesting
                     , optThreads        = argsThreads
                     }
+                logLevel = if argsVerbose then minBound else Info
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick)
-                getLspId event (logger minBound) debouncer options vfs
+            initialise caps (mainRule >> pluginRules plugins)
+              getLspId event (logger logLevel) debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
         hSetEncoding stdout utf8
@@ -156,7 +157,7 @@ main = do
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
-        results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
+        results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)
         let (worked, failed) = partition fst $ zip (map isJust results) files
         when (failed /= []) $
             putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
@@ -177,12 +178,6 @@ expandFiles = concatMapM $ \x -> do
             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
         return files
 
-
-kick :: Action ()
-kick = do
-    files <- getFilesOfInterest
-    void $ uses TypeCheck $ HashSet.toList files
-
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()
 showEvent _ (EventFileDiagnostics _ []) = return ()
@@ -230,15 +225,15 @@ setNameCache nc hsc = hsc { hsc_NC = nc }
 loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
 loadSessionShake fp = do
   se <- getShakeExtras
-  IdeOptions{optTesting} <- getIdeOptions
-  res <- liftIO $ loadSession optTesting se fp
+  IdeOptions{optTesting = IdeTesting ideTesting} <- getIdeOptions
+  res <- liftIO $ loadSession ideTesting se fp
   return (fmap liftIO res)
 
 -- | This is the key function which implements multi-component support. All
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
-loadSession optTesting ShakeExtras{logger, eventer} dir = do
+loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = do
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
   -- Mapping from a Filepath to HscEnv
@@ -342,6 +337,9 @@ loadSession optTesting ShakeExtras{logger, eventer} dir = do
         modifyVar_ fileToFlags $ \var -> do
             pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
 
+        -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
+        restartShakeSession [kick]
+
         return (fst res)
 
   let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)

ghcide.cabal

@@ -69,7 +69,8 @@ library
         transformers,
         unordered-containers >= 0.2.10.0,
         utf8-string,
-        hslogger
+        hslogger,
+        psqueues
     if flag(ghc-lib)
       build-depends:
         ghc-lib >= 8.8,
@@ -119,6 +120,8 @@ library
         Development.IDE.Core.RuleTypes
         Development.IDE.Core.Service
         Development.IDE.Core.Shake
+        Development.IDE.Core.Shake.Key
+        Development.IDE.Core.Shake.Queue
         Development.IDE.GHC.Error
         Development.IDE.GHC.Util
         Development.IDE.Import.DependencyInformation

src/Development/IDE/Core/FileStore.hs

@@ -7,6 +7,7 @@ module Development.IDE.Core.FileStore(
     getFileContents,
     getVirtualFile,
     setBufferModified,
+    setFileModified,
     setSomethingModified,
     fileStoreRules,
     VFSHandle,
@@ -30,6 +31,8 @@ import System.IO.Error
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.Core.OfInterest (kick)
+import Development.IDE.Core.RuleTypes
 import qualified Data.Rope.UTF16 as Rope
 
 #ifdef mingw32_HOST_OS
@@ -44,6 +47,9 @@ import Foreign.Storable
 import qualified System.Posix.Error as Posix
 #endif
 
+import Development.IDE.Core.RuleTypes
+import qualified Development.IDE.Types.Logger as L
+
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.VFS
 
@@ -174,7 +180,17 @@ setBufferModified state absFile contents = do
     VFSHandle{..} <- getIdeGlobalState state
     whenJust setVirtualFileContents $ \set ->
         set (filePathToUri' absFile) contents
-    void $ shakeRun state []
+    void $ shakeRestart state [kick]
+
+-- | Note that some buffer for a specific file has been modified but not
+-- with what changes.
+setFileModified :: IdeState -> NormalizedFilePath -> IO ()
+setFileModified state nfp = do
+    VFSHandle{..} <- getIdeGlobalState state
+    when (isJust setVirtualFileContents) $
+        fail "setSomethingModified can't be called on this type of VFSHandle"
+    let da = mkDelayedAction "FileStoreTC" L.Info (void $ use GetSpanInfo nfp)
+    shakeRestart state [da]
 
 -- | Note that some buffer somewhere has been modified, but don't say what.
 --   Only valid if the virtual file system was initialised by LSP, as that
@@ -184,4 +200,4 @@ setSomethingModified state = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
-    void $ shakeRun state []
+    void $ shakeRestart state [kick]

src/Development/IDE/Core/OfInterest.hs

@@ -9,6 +9,7 @@
 module Development.IDE.Core.OfInterest(
     ofInterestRules,
     getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
+    kick
     ) where
 
 import Control.Concurrent.Extra
@@ -23,13 +24,14 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import qualified Data.Text as T
 import Data.Tuple.Extra
-import Data.Functor
 import Development.Shake
 
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
+import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
-
+import Development.IDE.Core.RuleTypes
+import Control.Monad
 
 newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
 instance IsIdeGlobal OfInterestVar
@@ -79,4 +81,12 @@ modifyFilesOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar var $ pure . dupe . f
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
-    void $ shakeRun state []
+    let das = map (\nfp -> mkDelayedAction "OfInterest" Debug (use GetSpanInfo nfp)) (HashSet.toList files)
+    shakeRunInternal state das
+
+-- | Typecheck all the files of interest.
+--   Could be improved
+kick :: DelayedAction ()
+kick = mkDelayedAction "kick" Debug $ do
+    files <- getFilesOfInterest
+    void $ uses TypeCheck $ HashSet.toList files

src/Development/IDE/Core/Rules.hs

@@ -47,19 +47,20 @@ import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
 import Development.IDE.GHC.Util
 import Development.IDE.GHC.WithDynFlags
 import Data.Either.Extra
+import qualified Development.IDE.Types.Logger as L
 import Data.Maybe
 import           Data.Foldable
 import qualified Data.IntMap.Strict as IntMap
 import Data.IntMap.Strict (IntMap)
 import Data.List
-import Data.Ord
 import qualified Data.Set                                 as Set
 import qualified Data.Text                                as T
 import           Development.IDE.GHC.Error
 import           Development.Shake                        hiding (Diagnostic)
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Spans.Type
 import qualified Data.ByteString.Char8 as BS
+import Development.IDE.Core.PositionMapping
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes
@@ -74,6 +75,11 @@ import Development.Shake.Classes hiding (get, put)
 import Control.Monad.Trans.Except (runExceptT)
 import Data.ByteString (ByteString)
 import Control.Concurrent.Async (concurrently)
+import Control.Concurrent.Extra
+import System.Time.Extra
+import Control.Monad.Reader
+import System.Directory ( getModificationTime )
+import Control.Exception
 
 import Control.Monad.State
 
@@ -85,11 +91,11 @@ toIdeResult = either (, Nothing) (([],) . Just)
 
 -- | useE is useful to implement functions that aren’t rules but need shortcircuiting
 -- e.g. getDefinition.
-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
-useE k = MaybeT . use k
+useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
+useE k = MaybeT . useWithStaleFast k
 
-useNoFileE :: IdeRule k v => k -> MaybeT Action v
-useNoFileE k = useE k emptyFilePath
+useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v
+useNoFileE ide k = fst <$> useE k emptyFilePath
 
 usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
 usesE k = MaybeT . fmap sequence . uses k
@@ -109,69 +115,82 @@ getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
 getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
 
 -- | Try to get hover text for the name under point.
-getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
+getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
 getAtPoint file pos = fmap join $ runMaybeT $ do
-  opts <- lift getIdeOptions
-  spans <- useE GetSpanInfo file
-  return $ AtPoint.atPoint opts spans pos
+  ide <- ask
+  opts <- liftIO $ getIdeOptionsIO ide
+  (spans, mapping) <- useE  GetSpanInfo file
+  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+  return $ AtPoint.atPoint opts spans pos'
 
 -- | Goto Definition.
-getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
-getDefinition file pos = fmap join $ runMaybeT $ do
-    opts <- lift getIdeOptions
-    spans <- useE GetSpanInfo file
-    lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
+getDefinition file pos = runMaybeT $ do
+    ide <- ask
+    opts <- liftIO $ getIdeOptionsIO ide
+    spans <- fst <$> useE GetSpanInfo file
+    AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos
 
 getHieFile
-  :: NormalizedFilePath -- ^ file we're editing
+  :: ShakeExtras
+  -> NormalizedFilePath -- ^ file we're editing
   -> Module -- ^ module dep we want info for
-  -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module
-getHieFile file mod = do
-  TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file
+  -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module
+getHieFile ide file mod = do
+  TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file
   case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
     Just NamedModuleDep{nmdFilePath=nfp} -> do
         let modPath = fromNormalizedFilePath nfp
-        (_diags, hieFile) <- getHomeHieFile nfp
-        return $ (, modPath) <$> hieFile
-    _ -> getPackageHieFile mod file
+        hieFile <- getHomeHieFile nfp
+        return $ (hieFile, modPath)
+    _ -> getPackageHieFile ide mod file
 
 
-getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
+getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile
 getHomeHieFile f = do
-  ms <- use_ GetModSummary f
+  ms <- fst <$> useE GetModSummary f
   let normal_hie_f = toNormalizedFilePath' hie_f
       hie_f = ml_hie_file $ ms_location ms
-  mbHieTimestamp <- use GetModificationTime normal_hie_f
-  srcTimestamp   <- use_ GetModificationTime f
+
+  mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f)
+  srcTimestamp   <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f))
+  liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f)
   let isUpToDate
-        | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
+        | Just d <- mbHieTimestamp = d > srcTimestamp
         | otherwise = False
 
-  unless isUpToDate $
-       void $ use_ TypeCheck f
+  if isUpToDate
+    then do
+      hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing
+      MaybeT $ return hf
+    else do
+      wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
+        pm <- use_ GetParsedModule f
+        typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
+      _ <- MaybeT $ liftIO $ timeout 1 $ wait
+      liftIO $ loadHieFile hie_f
 
-  hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
-  return ([], hf)
 
-getPackageHieFile :: Module             -- ^ Package Module to load .hie file for
+getPackageHieFile :: ShakeExtras
+                  -> Module             -- ^ Package Module to load .hie file for
                   -> NormalizedFilePath -- ^ Path of home module importing the package module
-                  -> Action (Maybe (HieFile, FilePath))
-getPackageHieFile mod file = do
-    pkgState  <- hscEnv <$> use_ GhcSession file
-    IdeOptions {..} <- getIdeOptions
+                  -> MaybeT IdeAction (HieFile, FilePath)
+getPackageHieFile ide mod file = do
+    pkgState  <- hscEnv . fst <$> useE GhcSession file
+    IdeOptions {..} <- liftIO $ getIdeOptionsIO ide
     let unitId = moduleUnitId mod
     case lookupPackageConfig unitId pkgState of
         Just pkgConfig -> do
             -- 'optLocateHieFile' returns Nothing if the file does not exist
             hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
             path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
             case (hieFile, path) of
-                (Just hiePath, Just modPath) ->
+                (Just hiePath, Just modPath) -> MaybeT $
                     -- deliberately loaded outside the Shake graph
                     -- to avoid dependencies on non-workspace files
                         liftIO $ Just . (, modPath) <$> loadHieFile hiePath
-                _ -> return Nothing
-        _ -> return Nothing
+                _ -> MaybeT $ return Nothing
+        _ -> MaybeT $ return Nothing
 
 -- | Parse the contents of a daml file.
 getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)