hls-graph 1.5.1.1 → 1.6.0.0

raw patch · 15 files changed

+640/−598 lines, 15 filesdep +focusdep +list-tdep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: focus, list-t, stm, stm-containers

API changes (from Hackage documentation)

Files

• README.md +17/−0
• hls-graph.cabal +19/−5
• src/Control/Concurrent/STM/Stats.hs +185/−0
• src/Development/IDE/Graph.hs +0/−2
• src/Development/IDE/Graph/Classes.hs +8/−8
• src/Development/IDE/Graph/Database.hs +6/−6
• src/Development/IDE/Graph/Internal/Action.hs +137/−138
• src/Development/IDE/Graph/Internal/Database.hs +129/−124
• src/Development/IDE/Graph/Internal/Ids.hs +0/−160
• src/Development/IDE/Graph/Internal/Intern.hs +0/−41
• src/Development/IDE/Graph/Internal/Options.hs +0/−2
• src/Development/IDE/Graph/Internal/Paths.hs +7/−1
• src/Development/IDE/Graph/Internal/Profile.hs +21/−24
• src/Development/IDE/Graph/Internal/Rules.hs +58/−60
• src/Development/IDE/Graph/Internal/Types.hs +53/−27

@@ -0,0 +1,17 @@+# hls-graph - a limited reimplementation of Shake for in-memory build graphs++`ghcide` was originally built on top of [Shake](http://shakebuild.com), a Haskell build system. Nowadays Shake has been replaced by a special purpose implementation of a build graph called hls-graph, which drops all the persistency features in exchange for simplicity and performance.++Features:++* Dynamic dependencies+* User defined rules (there are no predefined File rules as in Shake)+* Build reports (a la Shake profiling)+* "Reactive" change tracking for minimal rebuilds (not available in Shake)++What's missing:++* Persistence+* A default set of rules for file system builds+* A testsuite+* General purpose application - many design decisions make assumptions specific to ghcide

@@ -1,16 +1,16 @@ cabal-version: 2.4 name:          hls-graph-version:       1.5.1.1+version:       1.6.0.0 synopsis:      Haskell Language Server internal graph API description:-  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>+  Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/hls-graph#readme>  homepage:      https://github.com/haskell/haskell-language-server#readme bug-reports:   https://github.com/haskell/haskell-language-server/issues license:       Apache-2.0 license-file:  LICENSE author:        The Haskell IDE Team-maintainer:    alan.zimm@gmail.com+maintainer:    The Haskell IDE Team copyright:     The Haskell IDE Team category:      Development build-type:    Simple@@ -18,6 +18,9 @@     html/profile.html     html/shake.js +extra-source-files:+    README.md+ flag pedantic   description: Enable -Werror   default:     False@@ -28,12 +31,18 @@   manual: True   description: Embed data files into the shake library +flag stm-stats+  default: False+  manual: True+  description: Collect STM transaction stats+ source-repository head   type:     git   location: https://github.com/haskell/haskell-language-server  library   exposed-modules:+    Control.Concurrent.STM.Stats     Development.IDE.Graph     Development.IDE.Graph.Classes     Development.IDE.Graph.Database@@ -42,8 +51,6 @@     Development.IDE.Graph.Internal.Options     Development.IDE.Graph.Internal.Rules     Development.IDE.Graph.Internal.Database-    Development.IDE.Graph.Internal.Ids-    Development.IDE.Graph.Internal.Intern     Development.IDE.Graph.Internal.Paths     Development.IDE.Graph.Internal.Profile     Development.IDE.Graph.Internal.Types@@ -63,11 +70,15 @@     , exceptions     , extra     , filepath+    , focus     , hashable     , js-dgtable     , js-flot     , js-jquery+    , list-t     , primitive+    , stm+    , stm-containers     , time     , transformers     , unordered-containers@@ -77,6 +88,9 @@         build-depends:             file-embed >= 0.0.11,             template-haskell+  if flag(stm-stats)+        cpp-options: -DSTM_STATS+    ghc-options:     -Wall -Wredundant-constraints -Wno-name-shadowing

@@ -0,0 +1,185 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+#ifdef STM_STATS+{-# LANGUAGE RecordWildCards     #-}+#endif+module Control.Concurrent.STM.Stats+    ( atomicallyNamed+    , atomically+    , getSTMStats+    , dumpSTMStats+    , module Control.Concurrent.STM+    ) where++import           Control.Concurrent.STM hiding (atomically)+import qualified Control.Concurrent.STM as STM+import           Data.Map               (Map)+#ifdef STM_STATS+import           Control.Exception      (BlockedIndefinitelyOnSTM, Exception,+                                         catch, throwIO)+import           Control.Monad+import           Data.IORef+import qualified Data.Map.Strict        as M+import           Data.Time              (getCurrentTime)+import           Data.Typeable          (Typeable)+import           GHC.Conc               (unsafeIOToSTM)+import           System.IO+import           System.IO.Unsafe+import           Text.Printf+#endif++atomicallyNamed :: String -> STM a -> IO a+atomically :: STM a -> IO a+dumpSTMStats :: IO ()+getSTMStats :: IO (Map String (Int,Int))++#ifndef STM_STATS++getSTMStats = pure mempty+atomicallyNamed _ = atomically+dumpSTMStats = pure ()+atomically = STM.atomically++#else+-- adapted from the STM.Stats package++atomicallyNamed = trackNamedSTM+atomically = trackSTM++-- | Global state, seems to be unavoidable here.+globalRetryCountMap :: IORef (Map String (Int,Int))+globalRetryCountMap = unsafePerformIO (newIORef M.empty)+{-# NOINLINE globalRetryCountMap #-}+++-- | For the most general transaction tracking function, 'trackSTMConf', all+-- settings can be configured using a 'TrackSTMConf' value.+data TrackSTMConf = TrackSTMConf+    { tryThreshold      :: Maybe Int+        -- ^ If the number of retries of one transaction run reaches this+        -- count, a warning is issued at runtime. If set to @Nothing@, disables the warnings completely.+    , globalTheshold    :: Maybe Int+        -- ^ If the total number of retries of one named transaction reaches+        -- this count, a warning is issued. If set to @Nothing@, disables the+        -- warnings completely.+    , extendException   :: Bool+        -- ^ If this is set, a 'BlockedIndefinitelyOnSTM' exception is replaced+        -- by a 'BlockedIndefinitelyOnNamedSTM' exception, carrying the name of+        -- the exception.+    , warnFunction      :: String -> IO ()+        -- ^ Function to call when a warning is to be emitted.+    , warnInSTMFunction :: String -> IO ()+        -- ^ Function to call when a warning is to be emitted during an STM+        -- transaction. This is possibly dangerous, see the documentation to+        -- 'unsafeIOToSTM', but can be useful to detect transactions that keep+        -- retrying forever.+    }++-- | The default settings are:+--+-- > defaultTrackSTMConf = TrackSTMConf+-- >    { tryThreshold =      Just 10+-- >    , globalTheshold =    Just 3000+-- >    , exception =         True+-- >    , warnFunction =      hPutStrLn stderr+-- >    , warnInSTMFunction = \_ -> return ()+-- >    }+defaultTrackSTMConf :: TrackSTMConf+defaultTrackSTMConf = TrackSTMConf+    { tryThreshold = Just 10+    , globalTheshold = Just 3000+    , extendException = True+    , warnFunction = hPutStrLn stderr+    , warnInSTMFunction = \_ -> return ()+    }++-- | A drop-in replacement for 'atomically'. The statistics will list this, and+-- all other unnamed transactions, as \"@_anonymous_@\" and+-- 'BlockedIndefinitelyOnSTM' exceptions will not be replaced.+-- See below for variants that give more control over the statistics and+-- generated warnings.+trackSTM :: STM a -> IO a+trackSTM = trackSTMConf defaultTrackSTMConf { extendException = False } "_anonymous_"++-- | Run 'atomically' and collect the retry statistics under the given name and using the default configuration, 'defaultTrackSTMConf'.+trackNamedSTM :: String -> STM a -> IO a+trackNamedSTM = trackSTMConf defaultTrackSTMConf++-- | Run 'atomically' and collect the retry statistics under the given name,+-- while issuing warnings when the configured thresholds are exceeded.+trackSTMConf :: TrackSTMConf -> String -> STM a -> IO a+trackSTMConf (TrackSTMConf {..}) name txm = do+    counter <- newIORef 0+    let wrappedTx =+            do  unsafeIOToSTM $ do+                    i <- atomicModifyIORef' counter incCounter+                    when (warnPred i) $+                        warnInSTMFunction $ msgPrefix ++ " reached try count of " ++ show i+                txm+    res <- if extendException+          then STM.atomically wrappedTx+              `catch` (\(_::BlockedIndefinitelyOnSTM) ->+                       throwIO (BlockedIndefinitelyOnNamedSTM name))+          else STM.atomically wrappedTx+    i <- readIORef counter+    doMB tryThreshold $ \threshold ->+       when (i > threshold) $+            warnFunction $ msgPrefix ++ " finished after " ++ show (i-1) ++ " retries"+    incGlobalRetryCount (i - 1)+    return res+  where+    doMB Nothing _  = return ()+    doMB (Just x) m = m x+    incCounter i = let j = i + 1 in (j, j)+    warnPred j = case tryThreshold of+        Nothing -> False+        Just n  -> j >= 2*n && (j >= 4 * n || j `mod` (2 * n) == 0)+    msgPrefix = "STM transaction " ++ name+    incGlobalRetryCount i = do+        (k,k') <- atomicModifyIORef' globalRetryCountMap $ \m ->+                let (oldVal, m') = M.insertLookupWithKey+                                    (\_ (a1,b1) (a2,b2) -> ((,) $! a1+a2) $! b1+b2)+                                    name+                                    (1,i)+                                    m+                in (m', let j = maybe 0 snd oldVal in (j,j+i))+        doMB globalTheshold $ \globalRetryThreshold ->+            when (k `div` globalRetryThreshold /= k' `div` globalRetryThreshold) $+                warnFunction $ msgPrefix ++ " reached global retry count of " ++ show k'++-- | If 'extendException' is set (which is the case with 'trackNamedSTM'), an+-- occurrence of 'BlockedIndefinitelyOnSTM' is replaced by+-- 'BlockedIndefinitelyOnNamedSTM', carrying the name of the transaction and+-- thus giving more helpful error messages.+newtype BlockedIndefinitelyOnNamedSTM = BlockedIndefinitelyOnNamedSTM String+    deriving (Typeable)++instance Show BlockedIndefinitelyOnNamedSTM where+    showsPrec _ (BlockedIndefinitelyOnNamedSTM name) =+        showString $ "thread blocked indefinitely in STM transaction" ++ name++instance Exception BlockedIndefinitelyOnNamedSTM++++-- | Fetches the current transaction statistics data.+--+-- The map maps transaction names to counts of transaction commits and+-- transaction retries.+getSTMStats = readIORef globalRetryCountMap++-- | Dumps the current transaction statistics data to 'System.IO.stderr'.+dumpSTMStats = do+    stats <- getSTMStats+    time <- show <$> getCurrentTime+    hPutStrLn stderr $ "STM transaction statistics (" ++ time ++ "):"+    sequence_ $+        hPrintf stderr "%-22s %10s %10s %10s\n" "Transaction" "Commits" "Retries" "Ratio" :+        [ hPrintf stderr "%-22s %10d %10d %10.2f\n" name commits retries ratio+        | (name,(commits,retries)) <- M.toList stats+        , commits > 0 -- safeguard+        , let ratio = fromIntegral retries / fromIntegral commits :: Double+        ]+++#endif

@@ -1,5 +1,3 @@-{-# LANGUAGE PatternSynonyms #-}- module Development.IDE.Graph(     shakeOptions,     Rules,

@@ -1,8 +1,8 @@--module Development.IDE.Graph.Classes(-    Show(..), Typeable, Eq(..), Hashable(..), NFData(..)-    ) where--import Control.DeepSeq-import Data.Hashable-import Data.Typeable+
+module Development.IDE.Graph.Classes(
+    Show(..), Typeable, Eq(..), Hashable(..), NFData(..)
+    ) where
+
+import           Control.DeepSeq
+import           Data.Hashable
+import           Data.Typeable

@@ -12,13 +12,12 @@     shakeGetDirtySet,     shakeGetCleanKeys     ,shakeGetBuildEdges) where+import           Control.Concurrent.STM.Stats            (readTVarIO) import           Data.Dynamic-import           Data.IORef                              (readIORef) import           Data.Maybe import           Development.IDE.Graph.Classes           () import           Development.IDE.Graph.Internal.Action import           Development.IDE.Graph.Internal.Database-import qualified Development.IDE.Graph.Internal.Ids      as Ids import           Development.IDE.Graph.Internal.Options import           Development.IDE.Graph.Internal.Profile  (writeProfile) import           Development.IDE.Graph.Internal.Rules@@ -45,18 +44,19 @@ -- | Returns the set of dirty keys annotated with their age (in # of builds) shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] shakeGetDirtySet (ShakeDatabase _ _ db) =-    fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db+    Development.IDE.Graph.Internal.Database.getDirtySet db  -- | Returns the build number shakeGetBuildStep :: ShakeDatabase -> IO Int shakeGetBuildStep (ShakeDatabase _ _ db) = do-    Step s <- readIORef $ databaseStep db+    Step s <- readTVarIO $ databaseStep db     return s  -- Only valid if we never pull on the results, which we don't unvoid :: Functor m => m () -> m a unvoid = fmap undefined +-- | Assumes that the database is not running a build shakeRunDatabaseForKeys     :: Maybe [Key]       -- ^ Set of keys changed since last run. 'Nothing' means everything has changed@@ -75,12 +75,12 @@ -- | Returns the clean keys in the database shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )] shakeGetCleanKeys (ShakeDatabase _ _ db) = do-    keys <- Ids.elems $ databaseValues db+    keys <- getDatabaseValues db     return [ (k,res) | (k, Clean res) <- keys]  -- | Returns the total count of edges in the build graph shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do-    keys <- Ids.elems $ databaseValues db+    keys <- getDatabaseValues db     let ress = mapMaybe (getResult . snd) keys     return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress

@@ -1,138 +1,137 @@-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}--module Development.IDE.Graph.Internal.Action-( ShakeValue-, actionFork-, actionBracket-, actionCatch-, actionFinally-, alwaysRerun-, apply1-, apply-, parallel-, reschedule-, runActions-, Development.IDE.Graph.Internal.Action.getDirtySet-, getKeysAndVisitedAge-) where--import           Control.Concurrent.Async-import           Control.Exception-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--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 $ modifyIORef ref (AlwaysRerunDeps [] <>)---- No-op for now-reschedule :: Double -> Action ()-reschedule _ = pure ()--parallel :: [Action a] -> Action [a]-parallel [] = pure []-parallel [x] = fmap (:[]) x-parallel xs = do-    a <- Action ask-    deps <- liftIO $ readIORef $ actionDeps a-    case deps of-        UnknownDeps ->-            -- if we are already in the rerun mode, nothing we do is going to impact our state-            liftIO $ mapConcurrently (ignoreState a) xs-        deps -> do-            (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs-            liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps-            pure res-    where-        usingState a x = do-            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 mempty-    runReaderT (fromAction x) a{actionDeps=ref}--actionFork :: Action a -> (Async a -> Action b) -> Action b-actionFork act k = do-    a <- Action ask-    deps <- liftIO $ readIORef $ actionDeps a-    let db = actionDatabase a-    case deps of-        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-        _ ->-            error "please help me"--isAsyncException :: SomeException -> Bool-isAsyncException e-    | Just (_ :: AsyncCancelled) <- fromException e = True-    | Just (_ :: AsyncException) <- fromException e = True-    | Just (_ :: ExitCode) <- fromException e = True-    | otherwise = False---actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a-actionCatch a b = do-    v <- Action ask-    Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)-    where-        -- Catch only catches exceptions that were caused by this code, not those that-        -- are a result of program termination-        f e | isAsyncException e = Nothing-            | otherwise = fromException e--actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c-actionBracket a b c = do-    v <- Action ask-    Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)--actionFinally :: Action a -> IO b -> Action a-actionFinally a b = do-    v <- Action ask-    Action $ lift $ finally (runReaderT (fromAction a) v) b--apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value-apply1 k = head <$> apply [k]--apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]-apply ks = do-    db <- Action $ asks actionDatabase-    (is, vs) <- liftIO $ build db ks-    ref <- Action $ asks actionDeps-    liftIO $ modifyIORef ref (ResultDeps is <>)-    pure vs--runActions :: Database -> [Action a] -> IO [a]-runActions db xs = do-    deps <- newIORef mempty-    runReaderT (fromAction $ parallel xs) $ SAction db deps---- | Returns the set of dirty keys annotated with their age (in # of builds)-getDirtySet  :: Action [(Key, Int)]-getDirtySet = do-    db <- getDatabase-    liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db--getKeysAndVisitedAge :: Action [(Key, Int)]-getKeysAndVisitedAge = do-    db <- getDatabase-    liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+module Development.IDE.Graph.Internal.Action
+( ShakeValue
+, actionFork
+, actionBracket
+, actionCatch
+, actionFinally
+, alwaysRerun
+, apply1
+, apply
+, parallel
+, reschedule
+, runActions
+, Development.IDE.Graph.Internal.Action.getDirtySet
+, getKeysAndVisitedAge
+) where
+
+import           Control.Concurrent.Async
+import           Control.Exception
+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
+
+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 $ modifyIORef ref (AlwaysRerunDeps [] <>)
+
+-- No-op for now
+reschedule :: Double -> Action ()
+reschedule _ = pure ()
+
+parallel :: [Action a] -> Action [a]
+parallel [] = pure []
+parallel [x] = fmap (:[]) x
+parallel xs = do
+    a <- Action ask
+    deps <- liftIO $ readIORef $ actionDeps a
+    case deps of
+        UnknownDeps ->
+            -- if we are already in the rerun mode, nothing we do is going to impact our state
+            liftIO $ mapConcurrently (ignoreState a) xs
+        deps -> do
+            (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
+            liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
+            pure res
+    where
+        usingState a x = do
+            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 mempty
+    runReaderT (fromAction x) a{actionDeps=ref}
+
+actionFork :: Action a -> (Async a -> Action b) -> Action b
+actionFork act k = do
+    a <- Action ask
+    deps <- liftIO $ readIORef $ actionDeps a
+    let db = actionDatabase a
+    case deps of
+        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
+        _ ->
+            error "please help me"
+
+isAsyncException :: SomeException -> Bool
+isAsyncException e
+    | Just (_ :: AsyncCancelled) <- fromException e = True
+    | Just (_ :: AsyncException) <- fromException e = True
+    | Just (_ :: ExitCode) <- fromException e = True
+    | otherwise = False
+
+
+actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
+actionCatch a b = do
+    v <- Action ask
+    Action $ lift $ catchJust f (runReaderT (fromAction a) v) (\x -> runReaderT (fromAction (b x)) v)
+    where
+        -- Catch only catches exceptions that were caused by this code, not those that
+        -- are a result of program termination
+        f e | isAsyncException e = Nothing
+            | otherwise = fromException e
+
+actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
+actionBracket a b c = do
+    v <- Action ask
+    Action $ lift $ bracket a b (\x -> runReaderT (fromAction (c x)) v)
+
+actionFinally :: Action a -> IO b -> Action a
+actionFinally a b = do
+    v <- Action ask
+    Action $ lift $ finally (runReaderT (fromAction a) v) b
+
+apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
+apply1 k = head <$> apply [k]
+
+apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
+apply ks = do
+    db <- Action $ asks actionDatabase
+    (is, vs) <- liftIO $ build db ks
+    ref <- Action $ asks actionDeps
+    liftIO $ modifyIORef ref (ResultDeps is <>)
+    pure vs
+
+runActions :: Database -> [Action a] -> IO [a]
+runActions db xs = do
+    deps <- newIORef mempty
+    runReaderT (fromAction $ parallel xs) $ SAction db deps
+
+-- | Returns the set of dirty keys annotated with their age (in # of builds)
+getDirtySet  :: Action [(Key, Int)]
+getDirtySet = do
+    db <- getDatabase
+    liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db
+
+getKeysAndVisitedAge :: Action [(Key, Int)]
+getKeysAndVisitedAge = do
+    db <- getDatabase
+    liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db

@@ -4,80 +4,83 @@ {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-}  module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where  import           Control.Concurrent.Async import           Control.Concurrent.Extra+import           Control.Concurrent.STM.Stats         (STM, atomically,+                                                       atomicallyNamed,+                                                       modifyTVar', newTVarIO,+                                                       readTVarIO) import           Control.Exception import           Control.Monad-import           Control.Monad.IO.Class                (MonadIO (liftIO))-import           Control.Monad.Trans.Class             (lift)+import           Control.Monad.IO.Class               (MonadIO (liftIO))+import           Control.Monad.Trans.Class            (lift) import           Control.Monad.Trans.Reader-import qualified Control.Monad.Trans.State.Strict      as State+import qualified Control.Monad.Trans.State.Strict     as State import           Data.Dynamic import           Data.Either-import           Data.Foldable                         (traverse_)+import           Data.Foldable                        (for_, traverse_)+import           Data.HashSet                         (HashSet)+import qualified Data.HashSet                         as HSet import           Data.IORef.Extra-import           Data.IntSet                           (IntSet)-import qualified Data.IntSet                           as Set import           Data.Maybe+import           Data.Traversable                     (for) import           Data.Tuple.Extra import           Development.IDE.Graph.Classes-import qualified Development.IDE.Graph.Internal.Ids    as Ids-import           Development.IDE.Graph.Internal.Intern-import qualified Development.IDE.Graph.Internal.Intern as Intern import           Development.IDE.Graph.Internal.Rules import           Development.IDE.Graph.Internal.Types+import qualified Focus+import qualified ListT+import qualified StmContainers.Map                    as SMap import           System.IO.Unsafe-import           System.Time.Extra                     (duration)+import           System.Time.Extra                    (duration)  newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do-    databaseStep <- newIORef $ Step 0-    databaseLock <- newLock-    databaseIds <- newIORef Intern.empty-    databaseValues <- Ids.empty-    databaseReverseDeps <- Ids.empty-    databaseReverseDepsLock <- newLock+    databaseStep <- newTVarIO $ Step 0+    databaseValues <- atomically SMap.new     pure Database{..} --- | Increment the step and mark dirty+-- | Increment the step and mark dirty.+--   Assumes that the database is not running a build incDatabase :: Database -> Maybe [Key] -> IO ()--- all keys are dirty-incDatabase db Nothing = do-    modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1-    withLock (databaseLock db) $-        Ids.forMutate (databaseValues db) $ \_ -> second $ \case-            Clean x       -> Dirty (Just x)-            Dirty x       -> Dirty x-            Running _ _ x -> Dirty x -- only some keys are dirty incDatabase db (Just kk) = do-    modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1-    intern <- readIORef (databaseIds db)-    let dirtyIds = mapMaybe (`Intern.lookup` intern) kk-    transitiveDirtyIds <- transitiveDirtySet db dirtyIds-    withLock (databaseLock db) $-        Ids.forMutate (databaseValues db) $ \i -> \case-            (k, Running _ _ x) -> (k, Dirty x)-            (k, Clean x) | i `Set.member` transitiveDirtyIds ->-                (k, Dirty (Just x))-            other -> other+    atomicallyNamed "incDatabase" $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1+    transitiveDirtyKeys <- transitiveDirtySet db kk+    for_ transitiveDirtyKeys $ \k ->+        -- Updating all the keys atomically is not necessary+        -- since we assume that no build is mutating the db.+        -- Therefore run one transaction per key to minimise contention.+        atomicallyNamed "incDatabase" $ SMap.focus updateDirty k (databaseValues db) +-- all keys are dirty+incDatabase db Nothing = do+    atomically $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1+    let list = SMap.listT (databaseValues db)+    atomicallyNamed "incDatabase - all " $ flip ListT.traverse_ list $ \(k,_) ->+        SMap.focus updateDirty k (databaseValues db) +updateDirty :: Monad m => Focus.Focus KeyDetails m ()+updateDirty = Focus.adjust $ \(KeyDetails status rdeps) ->+            let status'+                  | Running _ _ _ x <- status = Dirty x+                  | Clean x <- status = Dirty (Just x)+                  | otherwise = status+            in KeyDetails status' rdeps -- | Unwrap and build a list of keys in parallel build     :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)-    => Database -> [key] -> IO ([Id], [value])+    => Database -> [key] -> IO ([Key], [value]) build db keys = do-    (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< builder db (map (Right . Key) keys)+    (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<<+            builder db (map Key keys)     pure (ids, map (asV . resultValue) vs)     where         asV :: Value -> value@@ -87,80 +90,70 @@ --  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. builder-    :: Database -> [Either Id Key] -> AIO (Either [(Id, Result)] (IO [(Id, Result)]))-builder db@Database{..} keys = do-        -- Things that I need to force before my results are ready-        toForce <- liftIO $ newIORef []--        results <- withLockAIO databaseLock $ do-            flip traverse keys $ \idKey -> do-                -- Resolve the id-                id <- case idKey of-                    Left id -> pure id-                    Right key -> liftIO $ do-                        ids <- readIORef databaseIds-                        case Intern.lookup key ids of-                            Just v -> pure v-                            Nothing -> do-                                (ids, id) <- pure $ Intern.add key ids-                                writeIORef' databaseIds ids-                                return id--                -- Spawn the id if needed-                status <- liftIO $ Ids.lookup databaseValues id-                val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of-                    (_, Clean r) -> pure r-                    (_, Running force val _) -> do-                        liftIO $ modifyIORef toForce (Wait force :)-                        pure val-                    (key, Dirty s) -> do-                        act <- unliftAIO (refresh db key id s)-                        let (force, val) = splitIO (join act)-                        liftIO $ Ids.insert databaseValues id (key, Running force val s)-                        liftIO $ modifyIORef toForce (Spawn force:)-                        pure val+    :: Database -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)]))+builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do+    -- Things that I need to force before my results are ready+    toForce <- liftIO $ newTVarIO []+    current <- liftIO $ readTVarIO databaseStep+    results <- liftIO $ for keys $ \id ->+        -- Updating the status of all the dependencies atomically is not necessary.+        -- Therefore, run one transaction per dep. to avoid contention+        atomicallyNamed "builder" $ do+            -- Spawn the id if needed+            status <- SMap.lookup id databaseValues+            val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of+                Clean r -> pure r+                Running _ force val _ -> do+                    modifyTVar' toForce (Wait force :)+                    pure val+                Dirty s -> do+                    let act = run (refresh db id s)+                        (force, val) = splitIO (join act)+                    SMap.focus (updateStatus $ Running current force val s) id databaseValues+                    modifyTVar' toForce (Spawn force:)+                    pure val -                pure (id, val)+            pure (id, val) -        toForceList <- liftIO $ readIORef toForce-        waitAll <- unliftAIO $ mapConcurrentlyAIO_ id toForceList-        case toForceList of-            [] -> return $ Left results-            _ -> return $ Right $ do-                    waitAll-                    pure results+    toForceList <- liftIO $ readTVarIO toForce+    let waitAll = run $ mapConcurrentlyAIO_ id toForceList+    case toForceList of+        [] -> return $ Left results+        _ -> return $ Right $ do+                waitAll+                pure results  -- | Refresh a key: --     * 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-refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result)-refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do-    res <- builder db $ map Left deps+refresh :: Database -> Key -> Maybe Result -> AIO (IO Result)+refresh db key result@(Just me@Result{resultDeps = ResultDeps deps}) = do+    res <- builder db deps     case res of       Left res ->         if isDirty res-            then asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result-            else pure $ compute db key id RunDependenciesSame result+            then asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result+            else pure $ compute db key RunDependenciesSame result       Right iores -> asyncWithCleanUp $ liftIO $ do         res <- iores         let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame-        compute db key id mode result+        compute db key mode result     where         isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) -refresh db key id result =-    asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result+refresh db key result =+    asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result   -- | Compute a key.-compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result-compute db@Database{..} key id mode result = do+compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result+compute db@Database{..} key mode result = do     let act = runRule databaseRules key (fmap resultData result) mode     deps <- newIORef UnknownDeps     (execution, RunResult{..}) <-         duration $ runReaderT (fromAction act) $ SAction db deps-    built <- readIORef databaseStep+    built <- readTVarIO databaseStep     deps <- readIORef deps     let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result         built' = if runChanged /= ChangedNothing then built else changed@@ -173,28 +166,34 @@             && runChanged /= ChangedNothing                     -> do             void $ forkIO $-                updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps)+                updateReverseDeps key db+                    (getResultDepsDefault [] previousDeps)+                    (HSet.fromList deps)         _ -> pure ()-    withLock databaseLock $-        Ids.insert databaseValues id (key, Clean res)+    atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues     pure res +updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()+updateStatus res = Focus.alter+    (Just . maybe (KeyDetails res mempty)+    (\it -> it{keyStatus = res}))+ -- | Returns the set of dirty keys annotated with their age (in # of builds)-getDirtySet :: Database -> IO [(Id,(Key, Int))]+getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do-    Step curr <- readIORef (databaseStep db)-    dbContents <- Ids.toList (databaseValues db)+    Step curr <- readTVarIO (databaseStep db)+    dbContents <- getDatabaseValues db     let calcAge Result{resultBuilt = Step x} = curr - x         calcAgeStatus (Dirty x)=calcAge <$> x         calcAgeStatus _         = Nothing-    return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents+    return $ mapMaybe (secondM calcAgeStatus) dbContents  -- | Returns ann approximation of the database keys, --   annotated with how long ago (in # builds) they were visited getKeysAndVisitAge :: Database -> IO [(Key, Int)] getKeysAndVisitAge db = do-    values <- Ids.elems (databaseValues db)-    Step curr <- readIORef (databaseStep db)+    values <- getDatabaseValues db+    Step curr <- readTVarIO (databaseStep db)     let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values         getAge Result{resultVisited = Step s} = curr - s     return keysWithVisitAge@@ -215,34 +214,38 @@  -- | Update the reverse dependencies of an Id updateReverseDeps-    :: Id         -- ^ Id+    :: Key        -- ^ Id     -> Database-    -> [Id] -- ^ Previous direct dependencies of Id-    -> IntSet     -- ^ Current direct dependencies of Id+    -> [Key] -- ^ Previous direct dependencies of Id+    -> HashSet Key -- ^ Current direct dependencies of Id     -> IO ()-updateReverseDeps myId db prev new = withLock (databaseReverseDepsLock db) $ uninterruptibleMask_ $ do+updateReverseDeps myId db prev new = uninterruptibleMask_ $ do     forM_ prev $ \d ->-        unless (d `Set.member` new) $-            doOne (Set.delete myId) d-    forM_ (Set.elems new) $-        doOne (Set.insert myId)+        unless (d `HSet.member` new) $+            doOne (HSet.delete myId) d+    forM_ (HSet.toList new) $+        doOne (HSet.insert myId)     where-        doOne f id = do-            rdeps <- getReverseDependencies db id-            Ids.insert (databaseReverseDeps db) id (f $ fromMaybe mempty rdeps)+        alterRDeps f =+            Focus.adjust (onKeyReverseDeps f)+        -- updating all the reverse deps atomically is not needed.+        -- Therefore, run individual transactions for each update+        -- in order to avoid contention+        doOne f id = atomicallyNamed "updateReverseDeps" $+            SMap.focus (alterRDeps f) id (databaseValues db) -getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet))-getReverseDependencies db = Ids.lookup (databaseReverseDeps db)+getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key))+getReverseDependencies db = (fmap.fmap) keyReverseDeps  . flip SMap.lookup (databaseValues db) -transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet-transitiveDirtySet database = flip State.execStateT Set.empty . traverse_ loop+transitiveDirtySet :: Foldable t => Database -> t Key -> IO (HashSet Key)+transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop   where     loop x = do         seen <- State.get-        if x `Set.member` seen then pure () else do-            State.put (Set.insert x seen)-            next <- lift $ getReverseDependencies database x-            traverse_ loop (maybe mempty Set.toList next)+        if x `HSet.member` seen then pure () else do+            State.put (HSet.insert x seen)+            next <- lift $ atomically $ getReverseDependencies database x+            traverse_ loop (maybe mempty HSet.toList next)  -- | IO extended to track created asyncs to clean them up when the thread is killed, --   generalizing 'withAsync'@@ -263,15 +266,17 @@         atomicModifyIORef'_ st (void a :)         return $ wait a -withLockAIO :: Lock -> AIO a -> AIO a-withLockAIO lock act = do-    io <- unliftAIO act-    liftIO $ withLock lock io- unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do     st <- AIO ask     return $ runReaderT (unAIO act) st++newtype RunInIO = RunInIO (forall a. AIO a -> IO a)++withRunInIO :: (RunInIO -> AIO b) -> AIO b+withRunInIO k = do+    st <- AIO ask+    k $ RunInIO (\aio -> runReaderT (unAIO aio) st)  cleanupAsync :: IORef [Async a] -> IO () cleanupAsync ref = uninterruptibleMask_ $ do

@@ -1,160 +0,0 @@-{-# LANGUAGE BangPatterns    #-}-{-# LANGUAGE GADTs           #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples   #-}---- Note that argument order is more like IORef than Map, because its mutable-module Development.IDE.Graph.Internal.Ids(-    Ids, Id,-    empty, insert, lookup, fromList,-    null, size, sizeUpperBound,-    forWithKeyM_, forCopy, forMutate,-    toList, elems, toMap-    ) where--import           Control.Exception-import           Control.Monad.Extra-import           Data.Functor-import qualified Data.HashMap.Strict                   as Map-import           Data.IORef.Extra-import           Data.List.Extra                       (zipFrom)-import           Data.Maybe-import           Data.Primitive.Array                  hiding (fromList)-import           Development.IDE.Graph.Internal.Intern (Id)-import           GHC.Exts                              (RealWorld)-import           GHC.IO                                (IO (..))-import           Prelude                               hiding (lookup, null)---newtype Ids a = Ids (IORef (S a))--data S a = S-    {capacity :: {-# UNPACK #-} !Int -- ^ Number of entries in values, initially 0-    ,used     :: {-# UNPACK #-} !Int -- ^ Capacity that has been used, assuming no gaps from index 0, initially 0-    ,values   :: {-# UNPACK #-} !(MutableArray RealWorld (Maybe a))-    }---empty :: IO (Ids a)-empty = do-    let capacity = 0-    let used = 0-    values <- newArray capacity Nothing-    Ids <$> newIORef S{..}--fromList :: [a] -> IO (Ids a)-fromList xs = do-    let capacity = length xs-    let used = capacity-    values <- newArray capacity Nothing-    forM_ (zipFrom 0 xs) $ \(i, x) ->-        writeArray values i $ Just x-    Ids <$> newIORef S{..}--sizeUpperBound :: Ids a -> IO Int-sizeUpperBound (Ids ref) = do-    S{..} <- readIORef ref-    pure used---size :: Ids a -> IO Int-size (Ids ref) = do-    S{..} <- readIORef ref-    let go !acc i-            | i < 0 = pure acc-            | otherwise = do-                v <- readArray values i-                if isJust v then go (acc+1) (i-1) else go acc (i-1)-    go 0 (used-1)---toMap :: Ids a -> IO (Map.HashMap Id a)-toMap ids = do-    mp <- Map.fromList <$> toListUnsafe ids-    pure $! mp--forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO ()-forWithKeyM_ (Ids ref) f = do-    S{..} <- readIORef ref-    let go !i | i >= used = pure ()-              | otherwise = do-                v <- readArray values i-                whenJust v $ f $ fromIntegral i-                go $ i+1-    go 0--forCopy :: Ids a -> (a -> b) -> IO (Ids b)-forCopy (Ids ref) f = do-    S{..} <- readIORef ref-    values2 <- newArray capacity Nothing-    let go !i | i >= used = pure ()-              | otherwise = do-                v <- readArray values i-                whenJust v $ \v -> writeArray values2 i $ Just $ f v-                go $ i+1-    go 0-    Ids <$> newIORef (S capacity used values2)---forMutate :: Ids a -> (Id -> a -> a) -> IO ()-forMutate (Ids ref) f = do-    S{..} <- readIORef ref-    let go !i | i >= used = pure ()-              | otherwise = do-                v <- readArray values i-                whenJust v $ \v -> writeArray values i $! Just $! f i v-                go $ i+1-    go 0---toListUnsafe :: Ids a -> IO [(Id, a)]-toListUnsafe (Ids ref) = do-    S{..} <- readIORef ref--    -- execute in O(1) stack-    -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html-    let index _ i | i >= used = []-        index r i | IO io <- readArray values i = case io r of-            (# r, Nothing #) -> index r (i+1)-            (# r, Just v  #) -> (fromIntegral i, v) : index r (i+1)--    IO $ \r -> (# r, index r 0 #)---toList :: Ids a -> IO [(Id, a)]-toList ids = do-    xs <- toListUnsafe ids-    let demand (_:xs) = demand xs-        demand []     = ()-    evaluate $ demand xs-    pure xs--elems :: Ids a -> IO [a]-elems ids = map snd <$> toList ids--null :: Ids a -> IO Bool-null ids = (== 0) <$> sizeUpperBound ids---insert :: Ids a -> Id -> a -> IO ()-insert (Ids ref) (i) v = do-    S{..} <- readIORef ref-    let ii = fromIntegral i-    if ii < capacity then do-        writeArray values ii $ Just v-        when (ii >= used) $ writeIORef' ref S{used=ii+1,..}-     else do-        c2<- pure $ max (capacity * 2) (ii + 10000)-        v2 <- newArray c2 Nothing-        copyMutableArray v2 0 values 0 capacity-        writeArray v2 ii $ Just v-        writeIORef' ref $ S c2 (ii+1) v2--lookup :: Ids a -> Id -> IO (Maybe a)-lookup (Ids ref) (i) = do-    S{..} <- readIORef ref-    let ii = fromIntegral i-    if ii < used then-        readArray values ii-     else-        pure Nothing

@@ -1,41 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Development.IDE.Graph.Internal.Intern(-    Intern, Id,-    empty, insert, add, lookup, toList, fromList-    ) where--import qualified Data.HashMap.Strict       as Map-import           Data.List                 (foldl')-import           Development.IDE.Graph.Classes-import           Prelude                   hiding (lookup)----- Invariant: The first field is the highest value in the Map-data Intern a = Intern {-# UNPACK #-} !Int !(Map.HashMap a Id)--type Id = Int--empty :: Intern a-empty = Intern 0 Map.empty---insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a-insert k v (Intern n mp) = Intern (max n v) $ Map.insert k v mp---add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)-add k (Intern v mp) = (Intern v2 $ Map.insert k v2 mp, v2)-    where v2 = v + 1---lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id-lookup k (Intern _ mp) = Map.lookup k mp---toList :: Intern a -> [(a, Id)]-toList (Intern _ mp) = Map.toList mp---fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a-fromList xs = Intern (foldl' max 0 [i | (_, i) <- xs]) (Map.fromList xs)

@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Development.IDE.Graph.Internal.Options where  import           Control.Monad.Trans.Reader

@@ -20,8 +20,14 @@  htmlDataFiles :: [(FilePath, BS.ByteString)] htmlDataFiles =-  [ ("profile.html",  $(embedFile "html/profile.html"))+  [+#ifdef __GHCIDE__+    ("profile.html",  $(embedFile "hls-graph/html/profile.html"))+  , ("shake.js",      $(embedFile "hls-graph/html/shake.js"))+#else+    ("profile.html",  $(embedFile "html/profile.html"))   , ("shake.js",      $(embedFile "html/shake.js"))+#endif   ]  readDataFileHTML :: FilePath -> IO LBS.ByteString

@@ -7,15 +7,14 @@  module Development.IDE.Graph.Internal.Profile (writeProfile) where +import           Control.Concurrent.STM.Stats            (readTVarIO) import           Data.Bifunctor import qualified Data.ByteString.Lazy.Char8              as LBS import           Data.Char import           Data.Dynamic                            (toDyn)+import           Data.HashMap.Strict                     (HashMap) import qualified Data.HashMap.Strict                     as Map-import           Data.IORef-import           Data.IntMap                             (IntMap)-import qualified Data.IntMap                             as IntMap-import qualified Data.IntSet                             as Set+import qualified Data.HashSet                            as Set import           Data.List                               (dropWhileEnd, foldl',                                                           intercalate,                                                           partition, sort,@@ -28,7 +27,6 @@                                                           iso8601DateFormat) import           Development.IDE.Graph.Classes import           Development.IDE.Graph.Internal.Database (getDirtySet)-import qualified Development.IDE.Graph.Internal.Ids      as Ids import           Development.IDE.Graph.Internal.Paths import           Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable             as DGTable@@ -50,7 +48,7 @@     (report, mapping) <- toReport db     dirtyKeysMapped <- do         dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db-        let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList $ dirtyIds+        let dirtyKeysMapped = mapMaybe (`Map.lookup` mapping) . Set.toList $ dirtyIds         return $ Just $ sort dirtyKeysMapped     rpt <- generateHTML dirtyKeysMapped report     LBS.writeFile out rpt@@ -60,12 +58,12 @@  -- | Eliminate all errors from the database, pretending they don't exist -- 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 ->+resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result+resultsOnly mp = Map.map (\r ->       r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}-    )) keep+    ) keep     where-        keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp+        keep = Map.fromList $ mapMaybe (traverse getResult) mp  -- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such --   that no item points to an item before itself.@@ -102,36 +100,35 @@             Nothing   -> g (free, mp) (k, ds)             Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp) -prepareForDependencyOrder :: Database -> IO (Map.HashMap Ids.Id (Key, Result))+prepareForDependencyOrder :: Database -> IO (HashMap Key Result) prepareForDependencyOrder db = do-    current <- readIORef $ databaseStep db-    Map.insert (-1) (Key "alwaysRerun", alwaysRerunResult current) .  resultsOnly-        <$> Ids.toList (databaseValues db)+    current <- readTVarIO $ databaseStep db+    Map.insert (Key "alwaysRerun") (alwaysRerunResult current) .  resultsOnly+        <$> getDatabaseValues db  -- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry-toReport :: Database -> IO ([ProfileEntry], IntMap Int)+toReport :: Database -> IO ([ProfileEntry], HashMap Key Int) toReport db = do     status <- prepareForDependencyOrder db-    let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status-                in dependencyOrder shw-                $ map (second (getResultDepsDefault [-1] . resultDeps . snd))+    let order = dependencyOrder show+                $ map (second (getResultDepsDefault [Key "alwaysRerun"] . resultDeps))                 $ Map.toList status-        ids = IntMap.fromList $ zip order [0..]+        ids = Map.fromList $ zip order [0..] -        steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | (_k, Result{..}) <- Map.elems status]+        steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- Map.elems status]                  in Map.fromList $ zip (sortBy (flip compare) xs) [0..] -        f (k, Result{..}) = ProfileEntry+        f k Result{..} = ProfileEntry             {prfName = show k             ,prfBuilt = fromStep resultBuilt             ,prfVisited = fromStep resultVisited             ,prfChanged = fromStep resultChanged-            ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps+            ,prfDepends = map pure $ mapMaybe (`Map.lookup` ids) $ getResultDepsDefault [Key "alwaysRerun"] resultDeps             ,prfExecution = resultExecution             }             where fromStep i = fromJust $ Map.lookup i steps-    pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids)+    pure ([maybe (error "toReport") (f i) $ Map.lookup i status | i <- order], ids)  alwaysRerunResult :: Step -> Result alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty@@ -144,7 +141,7 @@         f other = error other     runTemplate f report -generateJSONBuild :: Maybe [Ids.Id] -> String+generateJSONBuild :: Maybe [Int] -> String generateJSONBuild (Just dirtyKeys) = jsonList [jsonList (map show dirtyKeys)] generateJSONBuild Nothing          = jsonList [] 

@@ -1,60 +1,58 @@--- We deliberately want to ensure the function we add to the rule database--- has the constraints we need on it when we get it out.-{-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--module Development.IDE.Graph.Internal.Rules where--import Development.IDE.Graph.Classes-import Control.Exception.Extra-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.ByteString as BS-import Data.Dynamic-import Data.Typeable-import Data.IORef-import qualified Data.HashMap.Strict as Map-import Control.Monad.Trans.Reader-import Development.IDE.Graph.Internal.Types-import Data.Maybe---- | The type mapping between the @key@ or a rule and the resulting @value@.---   See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.-type family RuleResult key -- = value--action :: Action a -> Rules ()-action x = do-    ref <- Rules $ asks rulesActions-    liftIO $ modifyIORef' ref (void x:)--addRule-    :: forall key value .-       (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)-    => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))-    -> Rules ()-addRule f = do-    ref <- Rules $ asks rulesMap-    liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)-    where-        f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)-        f2 (Key a) b c = do-            v <- f (fromJust $ cast a :: key) b c-            v <- liftIO $ evaluate v-            pure $ (Value . toDyn) <$> v--runRule-    :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)-runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of-    Nothing -> liftIO $ errorIO "Could not find key"-    Just x -> unwrapDynamic x key bs mode--runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])-runRules rulesExtra (Rules rules) = do-    rulesActions <- newIORef []-    rulesMap <- newIORef Map.empty-    runReaderT rules SRules{..}-    (,) <$> readIORef rulesMap <*> readIORef rulesActions+-- We deliberately want to ensure the function we add to the rule database
+-- has the constraints we need on it when we get it out.
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+
+module Development.IDE.Graph.Internal.Rules where
+
+import           Control.Exception.Extra
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Reader
+import qualified Data.ByteString                      as BS
+import           Data.Dynamic
+import qualified Data.HashMap.Strict                  as Map
+import           Data.IORef
+import           Data.Maybe
+import           Data.Typeable
+import           Development.IDE.Graph.Classes
+import           Development.IDE.Graph.Internal.Types
+
+-- | The type mapping between the @key@ or a rule and the resulting @value@.
+--   See 'addBuiltinRule' and 'Development.Shake.Rule.apply'.
+type family RuleResult key -- = value
+
+action :: Action a -> Rules ()
+action x = do
+    ref <- Rules $ asks rulesActions
+    liftIO $ modifyIORef' ref (void x:)
+
+addRule
+    :: forall key value .
+       (RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
+    => (key -> Maybe BS.ByteString -> RunMode -> Action (RunResult value))
+    -> Rules ()
+addRule f = do
+    ref <- Rules $ asks rulesMap
+    liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)
+    where
+        f2 :: Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
+        f2 (Key a) b c = do
+            v <- f (fromJust $ cast a :: key) b c
+            v <- liftIO $ evaluate v
+            pure $ Value . toDyn <$> v
+
+runRule
+    :: TheRules -> Key -> Maybe BS.ByteString -> RunMode -> Action (RunResult Value)
+runRule rules key@(Key t) bs mode = case Map.lookup (typeOf t) rules of
+    Nothing -> liftIO $ errorIO "Could not find key"
+    Just x  -> unwrapDynamic x key bs mode
+
+runRules :: Dynamic -> Rules () -> IO (TheRules, [Action ()])
+runRules rulesExtra (Rules rules) = do
+    rulesActions <- newIORef []
+    rulesMap <- newIORef Map.empty
+    runReaderT rules SRules{..}
+    (,) <$> readIORef rulesMap <*> readIORef rulesActions

@@ -1,35 +1,41 @@--+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveAnyClass             #-} {-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-}  module Development.IDE.Graph.Internal.Types where  import           Control.Applicative-import           Control.Concurrent.Extra import           Control.Monad.Catch+#if __GLASGOW_HASKELL__ < 808 -- Needed in GHC 8.6.5+import           Control.Concurrent.STM.Stats  (TVar, atomically) import           Control.Monad.Fail+#else+import           GHC.Conc                      (TVar, atomically)+#endif import           Control.Monad.IO.Class import           Control.Monad.Trans.Reader-import           Data.Aeson                            (FromJSON, ToJSON)-import qualified Data.ByteString                       as BS+import           Data.Aeson                    (FromJSON, ToJSON)+import           Data.Bifunctor                (second)+import qualified Data.ByteString               as BS import           Data.Dynamic-import qualified Data.HashMap.Strict                   as Map+import qualified Data.HashMap.Strict           as Map+import           Data.HashSet                  (HashSet) import           Data.IORef-import           Data.IntSet                           (IntSet) import           Data.Maybe import           Data.Typeable import           Development.IDE.Graph.Classes-import           Development.IDE.Graph.Internal.Ids-import           Development.IDE.Graph.Internal.Intern-import           GHC.Generics                          (Generic)-import           System.Time.Extra                     (Seconds)+import           GHC.Generics                  (Generic)+import qualified ListT+import           StmContainers.Map             (Map)+import qualified StmContainers.Map             as SMap+import           System.Time.Extra             (Seconds)   unwrapDynamic :: forall a . Typeable a => Dynamic -> a@@ -85,27 +91,47 @@  newtype Value = Value Dynamic +data KeyDetails = KeyDetails {+    keyStatus      :: !Status,+    keyReverseDeps :: !(HashSet Key)+    }++onKeyReverseDeps :: (HashSet Key -> HashSet Key) -> KeyDetails -> KeyDetails+onKeyReverseDeps f it@KeyDetails{..} =+    it{keyReverseDeps = f keyReverseDeps}+ data Database = Database {-    databaseExtra           :: Dynamic,-    databaseRules           :: TheRules,-    databaseStep            :: !(IORef Step),-    -- Hold the lock while mutating Ids/Values-    databaseLock            :: !Lock,-    databaseIds             :: !(IORef (Intern Key)),-    databaseValues          :: !(Ids (Key, Status)),-    databaseReverseDeps     :: !(Ids IntSet),-    databaseReverseDepsLock :: !Lock+    databaseExtra  :: Dynamic,+    databaseRules  :: TheRules,+    databaseStep   :: !(TVar Step),+    databaseValues :: !(Map Key KeyDetails)     } +getDatabaseValues :: Database -> IO [(Key, Status)]+getDatabaseValues = atomically+                  . (fmap.fmap) (second keyStatus)+                  . ListT.toList+                  . SMap.listT+                  . databaseValues+ data Status     = Clean Result     | Dirty (Maybe Result)-    | Running (IO ()) Result (Maybe Result)+    | Running {+        runningStep   :: !Step,+        runningWait   :: !(IO ()),+        runningResult :: Result,+        runningPrev   :: !(Maybe Result)+        } +viewDirty :: Step -> Status -> Status+viewDirty currentStep (Running s _ _ re) | currentStep /= s = Dirty re+viewDirty _ other = other+ getResult :: Status -> Maybe Result-getResult (Clean re)         = Just re-getResult (Dirty m_re)       = m_re-getResult (Running _ _ m_re) = m_re+getResult (Clean re)           = Just re+getResult (Dirty m_re)         = m_re+getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result  data Result = Result {     resultValue     :: !Value,@@ -117,14 +143,14 @@     resultData      :: BS.ByteString     } -data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id]+data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key] -getResultDepsDefault :: [Id] -> ResultDeps -> [Id]+getResultDepsDefault :: [Key] -> ResultDeps -> [Key] getResultDepsDefault _ (ResultDeps ids)      = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps         = def -mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps+mapResultDeps :: ([Key] -> [Key]) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids)      = ResultDeps $ f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps           = UnknownDeps