Soulomoon/mark dirty keys sync to hls graph1 kick dirties

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

@@ -179,6 +179,7 @@
 
 #if MIN_VERSION_ghc(9,3,0)
 import qualified Data.IntMap                                  as IM
+import Development.IDE.Graph.Internal.Action (runEval)
 #endif
 
 
@@ -611,12 +612,17 @@
     Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc
   except res
 
+seqTup :: (Functor f, Applicative f) => (f a, f b, f c) -> f (a, b, c)
+seqTup (a, b, c) = (,,) <$> a <*> b <*> c
+
 -- | Typechecks a module.
 typeCheckRule :: Recorder (WithPriority Log) -> Rules ()
 typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do
-    pm <- use_ GetParsedModule file
-    hsc  <- hscEnv <$> use_ GhcSessionDeps file
-    foi <- use_ IsFileOfInterest file
+    let pmA = useEval_ GetParsedModule file
+    let hscA = fmap hscEnv <$> useEval_ GhcSessionDeps file
+    let foiA = useEval_ IsFileOfInterest file
+    tup <- (,,) <$> pmA <*> hscA <*> foiA
+    (pm, hsc, foi) <- runEval $ seqTup tup
     -- We should only call the typecheck rule for files of interest.
     -- Keeping typechecked modules in memory for other files is
     -- very expensive.
@@ -823,7 +829,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -1095,7 +1101,7 @@
             -- thus bump its modification time, forcing this rule to be rerun every time.
             exists <- liftIO $ doesFileExist obj_file
             mobj_time <- liftIO $
               if exists
               then Just <$> getModTime obj_file
               else pure Nothing
             case mobj_time of

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

@@ -73,6 +73,7 @@
     garbageCollectDirtyKeysOlderThan,
     Log(..),
     VFSModified(..), getClientConfigAction,
+    useEval_
     ) where
 
 import           Control.Concurrent.Async
@@ -106,7 +107,7 @@
 import           Data.List.Extra                        (foldl', partition,
                                                          takeEnd)
 import qualified Data.Map.Strict                        as Map
 import           Data.Maybe
 import qualified Data.SortedList                        as SL
 import           Data.String                            (fromString)
 import qualified Data.Text                              as T
@@ -123,7 +124,7 @@
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          NameCacheUpdater (..),
                                                          initNameCache,
                                                          knownKeyNames)
@@ -172,6 +173,11 @@
 import           System.FilePath                        hiding (makeRelative)
 import           System.IO.Unsafe                       (unsafePerformIO)
 import           System.Time.Extra
+import Development.IDE.Graph.Internal.Action (apply', AEval, applyEval)
+import Development.IDE.Graph.Internal.Rules
+import GHC.Base (undefined)
+import Data.Maybe (fromMaybe)
+import Control.Monad (sequence)
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
 
 #if !MIN_VERSION_ghc(9,3,0)
@@ -1105,11 +1111,54 @@
         Nothing -> liftIO $ throwIO $ BadDependency (show key)
         Just v  -> return v
 
+useEval_ :: IdeRule k v => k -> NormalizedFilePath -> Action (AEval v)
+useEval_ key file = fmap runIdentity <$> usesEval_ key (Identity file)
+
+usesEval_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (AEval (f v))
+usesEval_ key files = do
+    res <- usesEval key files
+    case sequence $ fmap sequence res of
+        Nothing -> liftIO $ throwIO $ BadDependency (show key)
+        Just v  -> return v
+
+
+usesEval :: (Traversable f, IdeRule k v)
+    => k -> f NormalizedFilePath -> Action (AEval (f (Maybe v)))
+usesEval key files = (fmap . fmap) (\(A value) -> currentValue value) <$> applyEval (fmap (Q . (key,)) files)
+
 -- | Plural version of 'use'
 uses :: (Traversable f, IdeRule k v)
     => k -> f NormalizedFilePath -> Action (f (Maybe v))
 uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files)
 
+-- go :: '[Int]
+-- go = [1]
+
+class CurrentValues keys where
+    type HFmap (f :: * -> *) keys :: [*]
+    currentValues :: HList keys -> HList (HFmap Maybe keys)
+instance CurrentValues '[] where
+    type HFmap f '[] = '[]
+    currentValues HNil = HNil
+instance (CurrentValues xs) => CurrentValues (A x ': xs) where
+    type HFmap f (A x ': xs) = f x ': HFmap f xs
+    currentValues (HCons (A x) b) = HCons (currentValue x) (currentValues b)
+
+-- class UnMaybe keys where
+--     unMaybe :: HList (HFmap Maybe (RunResults keys)) -> HList (RunResults keys)
+    -- unMaybe
+    -- unMaybe (HCons Nothing xs) = unMaybe xs
+
+
+uses'_ :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys)) => HList keys -> Action (HList (RunResults keys))
+uses'_ = undefined
+-- uses_' :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys))
+--     => HList keys -> Action (HList (RunResults keys))
+-- uses_' ks = fmap currentValues $ apply' ks
+
+uses' :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys)) => HList keys -> Action (HList (HFmap Maybe (RunResults keys)))
+uses' ks = fmap currentValues $ apply' ks
+
 -- | Return the last computed result which might be stale.
 usesWithStale :: (Traversable f, IdeRule k v)
     => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))

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

@@ -9,9 +9,13 @@
 , alwaysRerun
 , apply1
 , apply
+, apply'
 , applyWithoutDependency
 , parallel
 , runActions
+, AEval(..)
+, applyEval
+, runEval
 , Development.IDE.Graph.Internal.Action.getDirtySet
 , getKeysAndVisitedAge
 ) where
@@ -28,9 +32,11 @@
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Database
 import           Development.IDE.Graph.Internal.Key
-import           Development.IDE.Graph.Internal.Rules    (RuleResult)
+import           Development.IDE.Graph.Internal.Rules
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
+import GHC.Conc (par)
+import Debug.Trace (traceM, trace)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
@@ -110,12 +116,52 @@
 apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
 apply1 k = runIdentity <$> apply (Identity k)
 
+-- apply' :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
+apply' :: (HListKeys keys, HListValues (RunResults keys)) => HList keys -> Action (HList (RunResults keys))
+apply' ks = do
+    db <- Action $ asks actionDatabase
+    stack <- Action $ asks actionStack
+    (is, vs) <- liftIO $ build1 db stack ks
+    ref <- Action $ asks actionDeps
+    let !ks = force $ fromListKeySet $ toList is
+    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+    pure vs
+
+data AEval a = AEval KeySet a
+
+instance Foldable AEval where
+    foldMap f (AEval _ x) = f x
+instance Traversable AEval where
+    traverse f (AEval k x) = AEval k <$> f x
+instance Functor AEval where
+    fmap f (AEval k x) = AEval k $ f x
+
+instance Applicative AEval where
+    pure x = AEval mempty x
+    AEval ks1 f <*> AEval ks2 x = x `par` f `par` AEval (ks1 <> ks2) $ f x
+
+applyEval :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (AEval (f value))
+applyEval ks = do
+    db <- Action $ asks actionDatabase
+    stack <- Action $ asks actionStack
+    (is, vs) <- liftIO $ build db stack ks
+    let ks = force $ fromListKeySet $ toList is
+    traceM $ "[TRACE]: applyEval: " ++ show ks
+    ref <- Action $ asks actionDeps
+    liftIO $ modifyIORef' ref (mergeWithFirst ks)
+    pure $ AEval ks vs
+
+runEval :: AEval value -> Action value
+runEval (AEval ks vs) = trace "runEval" $ do
+    traceM $ "[TRACE]: runEval: " ++ show ks
+    pure vs
+
 apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
 apply ks = do
     db <- Action $ asks actionDatabase
     stack <- Action $ asks actionStack
-    (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
+    (is, vs) <- liftIO $ build db stack ks
     let !ks = force $ fromListKeySet $ toList is
     liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
     pure vs

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

@@ -7,7 +7,7 @@
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeFamilies       #-}
 
-module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
+module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, build1) where
 
 import           Prelude                              hiding (unzip)
 
@@ -41,6 +41,7 @@ import qualified ListT
 import qualified StmContainers.Map                    as SMap
 import           System.IO.Unsafe
 import           System.Time.Extra                    (duration, sleep)
+import Data.Kind (Type)
 
 
 newDatabase :: Dynamic -> TheRules -> IO Database
@@ -76,6 +77,10 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) ->
                   | Clean x <- status = Dirty (Just x)
                   | otherwise = status
             in KeyDetails status' rdeps
+
+
+
+
 -- | Unwrap and build a list of keys in parallel
 build
     :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
@@ -93,6 +98,40 @@ build db stack keys = do
         asV :: Value -> value
         asV (Value x) = unwrapDynamic x
 
+
+-- build2 :: (HListKeys keys, HListValues values, values ~ RunResults keys) => Database -> Stack -> HList keys -> IO ([Key], HList values)
+-- build2 :: (Traversable f, Typeable a, Hashable a, Show a) => Database -> Stack -> f a -> AIO (f (Key, Result))
+
+build2
+    :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
+    => Database -> Stack -> f key -> AIO (f Key, f value)
+build2 db stack keys = do
+    built <- builder db stack (fmap newKey keys)
+    built2 <- case built of
+                Left clean  -> return clean
+                Right dirty -> liftIO dirty
+    let (ids, vs) = unzip built2
+    pure (ids, fmap (asV . resultValue) vs)
+    where
+        asV :: Value -> value
+        asV (Value x) = unwrapDynamic x
+
+build1 :: (HListKeys keys, HListValues values, values ~ RunResults keys) => Database -> Stack -> HList keys -> IO ([Key], HList values)
+build1 db stack hKeys = do
+    built <- runAIO $ do
+        built <- builder db stack (fmap newKey keys)
+        case built of
+          Left clean  -> return clean
+          Right dirty -> liftIO dirty
+    let (ids, vs) = unzip built
+    pure (ids, listHList $ fmap (asV . resultValue) vs)
+    where
+        asV (Value x) = unwrapDynamic x
+        keys = hListList hKeys
+
+
+-- builder1 :: Traversable f => Database -> Stack -> f Key -> AIO (IO (f (Key, Result)))
+
 -- | Build a list of keys and return their results.
 --  If none of the keys are dirty, we can return the results immediately.
 --  Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock.
@@ -143,31 +182,31 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
 -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread.
 --   This assumes that the implementation will be a lookup
 -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself
-refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result)
+refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result
 refreshDeps visited db stack key result = \case
     -- no more deps to refresh
-    [] -> pure $ compute db stack key RunDependenciesSame (Just result)
+    [] -> liftIO $ compute db stack key RunDependenciesSame (Just result)
     (dep:deps) -> do
         let newVisited = dep <> visited
         res <- builder db stack (toListKeySet (dep `differenceKeySet` visited))
         case res of
-            Left res ->  if isDirty result res
+            Left res -> if isDirty result res
                 -- restart the computation if any of the deps are dirty
-                then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result)
+                then liftIO $ compute db stack key RunDependenciesChanged (Just result)
                 -- else kick the rest of the deps
                 else refreshDeps newVisited db stack key result deps
-            Right iores -> asyncWithCleanUp $ liftIO $ do
-                res <- iores
+            Right iores -> do
+                res <- liftIO iores
                 if isDirty result res
-                    then compute db stack key RunDependenciesChanged (Just result)
-                    else join $ runAIO $ refreshDeps newVisited db stack key result deps
+                    then liftIO $ compute db stack key RunDependenciesChanged (Just result)
+                    else refreshDeps newVisited db stack key result deps
 
 -- | Refresh a key:
 refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
 -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
 refresh db stack key result = case (addStack key stack, result) of
     (Left e, _) -> throw e
-    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps)
+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps)
     (Right stack, _) ->
         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
 

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

@@ -19,9 +19,48 @@ import           Data.Typeable
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
+import Data.Kind (Type)
 
 -- | The type mapping between the @key@ or a rule and the resulting @value@.
 type family RuleResult key -- = value
+type family RunResults keys where
+    RunResults '[] = '[]
+    RunResults (x ': xs) = RunResult x ': RunResults xs
+
+-- type family MapListType f keys where
+--     MapListType _ '[] = '[]
+--     MapListType f (x ': xs) = f x ': MapListType f xs
+
+-- type family MapResults as bs where
+    -- MapResults '[] = '[]
+    -- MapResults (a ': as) = RunResult a ': MapResults as
+
+class HMap f as where
+    hMap :: f -> HList as -> HList (RunResults as)
+
+type IsKey a = (Typeable a, Hashable a, Show a)
+
+data HList :: [Type] -> Type where
+    HNil :: HList '[]
+    HCons :: a -> HList as -> HList (a ': as)
+
+class HListKeys as where
+    hListList :: HList as -> [Key]
+instance HListKeys '[] where
+    hListList HNil = []
+instance (IsKey a, HListKeys as) => HListKeys (a ': as) where
+    hListList (HCons k xs) = newKey k : hListList xs
+
+
+class HListValues as where
+    listHList :: [Dynamic] -> HList as
+instance HListValues '[] where
+    listHList [] = HNil
+    listHList _ = error "listHList: too many elements"
+instance (Typeable a, HListValues as) => HListValues (a ': as) where
+    listHList  [] = error "listHList: empty list"
+    listHList (x:xs) = HCons (unwrapDynamic x) (listHList xs)
+
 
 action :: Action a -> Rules ()
 action x = do

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

@@ -69,12 +69,22 @@ data SRules = SRules {
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
     deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
 
+
 data SAction = SAction {
     actionDatabase :: !Database,
     actionDeps     :: !(IORef ResultDeps),
     actionStack    :: !Stack
     }
 
+-- newtype FAction a = FAction {fromFAction :: ReaderT FSAction IO a}
+--     deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+
+-- data FSAction = FSAction {
+--     factionDatabase :: !Database,
+--     factionDeps     :: !ResultDeps,
+--     factionStack    :: !Stack
+--     }
+
 getDatabase :: Action Database
 getDatabase = Action $ asks actionDatabase
 
@@ -158,6 +168,10 @@ getResultDepsDefault _ (ResultDeps ids)      = fold ids
 getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
 getResultDepsDefault def UnknownDeps         = def
 
+mergeWithFirst :: KeySet -> ResultDeps -> ResultDeps
+mergeWithFirst ks (ResultDeps (x:xs)) = ResultDeps (ks <> x : xs)
+mergeWithFirst ks x = ResultDeps [ks] <> x
+
 mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
 mapResultDeps f (ResultDeps ids)      = ResultDeps $ fmap f ids
 mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids