diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 6c9bbd12ee5..ef1168685b2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/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 diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index d541d58f5bb..c8acc76de7e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -135,7 +135,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 -> @@ -157,7 +157,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 @@ -166,14 +166,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) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 9153adf06ab..86afdb47ae8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -61,7 +61,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 @@ -113,7 +113,7 @@ toReport db = do status <- prepareForDependencyOrder db let order = let shw i = maybe "" (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..] @@ -126,14 +126,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 "") (Step 0) (Step 0) current (Just []) 0 mempty +alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps []) 0 mempty readDataFileHTML :: FilePath -> IO LBS.ByteString readDataFileHTML file = LBS.readFile =<< getDataFile ("html" file) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 0a1cb2c467a..3adc0698d56 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -55,7 +55,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) } @@ -105,11 +105,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