diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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
diff --git a/hls-graph.cabal b/hls-graph.cabal
--- a/hls-graph.cabal
+++ b/hls-graph.cabal
@@ -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
diff --git a/src/Control/Concurrent/STM/Stats.hs b/src/Control/Concurrent/STM/Stats.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Concurrent/STM/Stats.hs
@@ -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
diff --git a/src/Development/IDE/Graph.hs b/src/Development/IDE/Graph.hs
--- a/src/Development/IDE/Graph.hs
+++ b/src/Development/IDE/Graph.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE PatternSynonyms #-}
-
 module Development.IDE.Graph(
     shakeOptions,
     Rules,
diff --git a/src/Development/IDE/Graph/Classes.hs b/src/Development/IDE/Graph/Classes.hs
--- a/src/Development/IDE/Graph/Classes.hs
+++ b/src/Development/IDE/Graph/Classes.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Database.hs b/src/Development/IDE/Graph/Database.hs
--- a/src/Development/IDE/Graph/Database.hs
+++ b/src/Development/IDE/Graph/Database.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Action.hs b/src/Development/IDE/Graph/Internal/Action.hs
--- a/src/Development/IDE/Graph/Internal/Action.hs
+++ b/src/Development/IDE/Graph/Internal/Action.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Database.hs b/src/Development/IDE/Graph/Internal/Database.hs
--- a/src/Development/IDE/Graph/Internal/Database.hs
+++ b/src/Development/IDE/Graph/Internal/Database.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Ids.hs b/src/Development/IDE/Graph/Internal/Ids.hs
deleted file mode 100644
--- a/src/Development/IDE/Graph/Internal/Ids.hs
+++ /dev/null
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Intern.hs b/src/Development/IDE/Graph/Internal/Intern.hs
deleted file mode 100644
--- a/src/Development/IDE/Graph/Internal/Intern.hs
+++ /dev/null
@@ -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)
diff --git a/src/Development/IDE/Graph/Internal/Options.hs b/src/Development/IDE/Graph/Internal/Options.hs
--- a/src/Development/IDE/Graph/Internal/Options.hs
+++ b/src/Development/IDE/Graph/Internal/Options.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
-
 module Development.IDE.Graph.Internal.Options where
 
 import           Control.Monad.Trans.Reader
diff --git a/src/Development/IDE/Graph/Internal/Paths.hs b/src/Development/IDE/Graph/Internal/Paths.hs
--- a/src/Development/IDE/Graph/Internal/Paths.hs
+++ b/src/Development/IDE/Graph/Internal/Paths.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Profile.hs b/src/Development/IDE/Graph/Internal/Profile.hs
--- a/src/Development/IDE/Graph/Internal/Profile.hs
+++ b/src/Development/IDE/Graph/Internal/Profile.hs
@@ -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 []
 
diff --git a/src/Development/IDE/Graph/Internal/Rules.hs b/src/Development/IDE/Graph/Internal/Rules.hs
--- a/src/Development/IDE/Graph/Internal/Rules.hs
+++ b/src/Development/IDE/Graph/Internal/Rules.hs
@@ -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
diff --git a/src/Development/IDE/Graph/Internal/Types.hs b/src/Development/IDE/Graph/Internal/Types.hs
--- a/src/Development/IDE/Graph/Internal/Types.hs
+++ b/src/Development/IDE/Graph/Internal/Types.hs
@@ -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