Merge branch 'master' into gha-skip-ci

Author: jneira

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

@@ -1,7 +1,7 @@
+{-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE ConstraintKinds #-}
 
 module Development.IDE.Graph.Internal.Action
 ( ShakeValue
@@ -19,23 +19,23 @@ module Development.IDE.Graph.Internal.Action
 
 import           Control.Concurrent.Async
 import           Control.Exception
-import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Reader
 import           Data.IORef
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Database
+import           Development.IDE.Graph.Internal.Rules    (RuleResult)
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
-import Development.IDE.Graph.Internal.Rules (RuleResult)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
+-- | Always rerun this rule when dirty, regardless of the dependencies.
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ writeIORef ref Nothing
+    liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
 
 -- No-op for now
 reschedule :: Double -> Action ()
@@ -48,23 +48,23 @@ parallel xs = do
     a <- Action ask
     deps <- liftIO $ readIORef $ actionDeps a
     case deps of
-        Nothing ->
+        UnknownDeps ->
             -- if we are already in the rerun mode, nothing we do is going to impact our state
             liftIO $ mapConcurrently (ignoreState a) xs
-        Just deps -> do
+        deps -> do
             (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
-            liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps
+            liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
             pure res
     where
         usingState a x = do
-            ref <- newIORef $ Just []
+            ref <- newIORef mempty
             res <- runReaderT (fromAction x) a{actionDeps=ref}
             deps <- readIORef ref
             pure (deps, res)
 
 ignoreState :: SAction -> Action b -> IO b
 ignoreState a x = do
-    ref <- newIORef Nothing
+    ref <- newIORef mempty
     runReaderT (fromAction x) a{actionDeps=ref}
 
 actionFork :: Action a -> (Async a -> Action b) -> Action b
@@ -73,7 +73,7 @@ actionFork act k = do
     deps <- liftIO $ readIORef $ actionDeps a
     let db = actionDatabase a
     case deps of
-        Nothing -> do
+        UnknownDeps -> do
             -- if we are already in the rerun mode, nothing we do is going to impact our state
             [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]
             return res
@@ -116,12 +116,10 @@ apply ks = do
     db <- Action $ asks actionDatabase
     (is, vs) <- liftIO $ build db ks
     ref <- Action $ asks actionDeps
-    deps <- liftIO $ readIORef ref
-    whenJust deps $ \deps ->
-        liftIO $ writeIORef ref $ Just $ is ++ deps
+    liftIO $ modifyIORef ref (ResultDeps is <>)
     pure vs
 
 runActions :: Database -> [Action a] -> IO [a]
 runActions db xs = do
-    deps <- newIORef Nothing
+    deps <- newIORef mempty
     runReaderT (fromAction $ parallel xs) $ SAction db deps

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

@@ -138,7 +138,7 @@ builder db@Database{..} keys = do
 --       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
 refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result)
-refresh db key id result@(Just me@Result{resultDeps=Just deps}) = do
+refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do
     res <- builder db $ map Left deps
     case res of
       Left res ->
@@ -160,7 +160,7 @@ refresh db key id result =
 compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result
 compute db@Database{..} key id mode result = do
     let act = runRule databaseRules key (fmap resultData result) mode
-    deps <- newIORef $ Just []
+    deps <- newIORef UnknownDeps
     (execution, RunResult{..}) <-
         duration $ runReaderT (fromAction act) $ SAction db deps
     built <- readIORef databaseStep
@@ -169,14 +169,14 @@ compute db@Database{..} key id mode result = do
         built' = if runChanged /= ChangedNothing then built else changed
         -- only update the deps when the rule ran with changes
         actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
-        previousDeps= resultDeps =<< result
+        previousDeps= maybe UnknownDeps resultDeps result
     let res = Result runValue built' changed built actualDeps execution runStore
     case actualDeps of
-        Just deps | not(null deps) &&
+        ResultDeps deps | not(null deps) &&
                     runChanged /= ChangedNothing
                     -> do
             void $ forkIO $
-                updateReverseDeps id db (fromMaybe [] previousDeps) (Set.fromList deps)
+                updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)
         _ -> pure ()
     withLock databaseLock $
         Ids.insert databaseValues id (key, Clean res)

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

@@ -57,7 +57,7 @@ data ProfileEntry = ProfileEntry
 -- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
 resultsOnly :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result)
 resultsOnly mp = Map.map (fmap (\r ->
-      r{resultDeps = fmap (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
+      r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
     )) keep
     where
         keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp
@@ -109,7 +109,7 @@ toReport db = do
     status <- prepareForDependencyOrder db
     let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status
                 in dependencyOrder shw
-                $ map (second (fromMaybe [-1] . resultDeps . snd))
+                $ map (second (getResultDepsDefault [-1] . resultDeps . snd))
                 $ Map.toList status
         ids = IntMap.fromList $ zip order [0..]
 
@@ -122,14 +122,14 @@ toReport db = do
             ,prfBuilt = fromStep resultBuilt
             ,prfVisited = fromStep resultVisited
             ,prfChanged = fromStep resultChanged
-            ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ fromMaybe [-1] $ resultDeps
+            ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps
             ,prfExecution = resultExecution
             }
             where fromStep i = fromJust $ Map.lookup i steps
     pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids)
 
 alwaysRerunResult :: Step -> Result
-alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (Just []) 0 mempty
+alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty
 
 readDataFileHTML :: FilePath -> IO LBS.ByteString
 readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file)

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

@@ -54,7 +54,7 @@ newtype Action a = Action {fromAction :: ReaderT SAction IO a}
 
 data SAction = SAction {
     actionDatabase :: !Database,
-    actionDeps     :: !(IORef (Maybe [Id])) -- Nothing means always rerun
+    actionDeps     :: !(IORef ResultDeps)
     }
 
 
@@ -106,11 +106,33 @@ data Result = Result {
     resultBuilt     :: !Step, -- ^ the step when it was last recomputed
     resultChanged   :: !Step, -- ^ the step when it last changed
     resultVisited   :: !Step, -- ^ the step when it was last looked up
-    resultDeps      :: !(Maybe [Id]), -- ^ Nothing = alwaysRerun
+    resultDeps      :: !ResultDeps,
     resultExecution :: !Seconds, -- ^ How long it took, last time it ran
     resultData      :: BS.ByteString
     }
 
+data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id]
+
+getResultDepsDefault :: [Id] -> ResultDeps -> [Id]
+getResultDepsDefault _ (ResultDeps ids)      = ids
+getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
+getResultDepsDefault def UnknownDeps         = def
+
+mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps
+mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids
+mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
+mapResultDeps _ UnknownDeps           = UnknownDeps
+
+instance Semigroup ResultDeps where
+    UnknownDeps <> x = x
+    x <> UnknownDeps = x
+    AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)
+    x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)
+    ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')
+
+instance Monoid ResultDeps where
+    mempty = UnknownDeps
+
 ---------------------------------------------------------------------
 -- Running builds