diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal
index f0b66343f9..6ad1b238ec 100644
--- a/hls-graph/hls-graph.cabal
+++ b/hls-graph/hls-graph.cabal
@@ -35,12 +35,20 @@ library
     Development.IDE.Graph.Internal.Action
     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.Types
 
   hs-source-dirs:     src
   build-depends:
+    , async
     , base >=4.12 && <5
     , bytestring
+    , extra
+    , primitive
     , shake >= 0.19.4
+    , transformers
     , unordered-containers
 
   ghc-options:
diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs
index 4ab5094e0d..09a333f3e5 100644
--- a/hls-graph/src/Development/IDE/Graph.hs
+++ b/hls-graph/src/Development/IDE/Graph.hs
@@ -19,7 +19,8 @@ module Development.IDE.Graph(
     reschedule,
     ) where
 
-import           Development.IDE.Graph.Internal.Action
-import           Development.IDE.Graph.Internal.Options
-import           Development.IDE.Graph.Internal.Rules
-import qualified Development.Shake                      as Shake
+import qualified Development.Shake as Shake
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Options
+import Development.IDE.Graph.Internal.Rules
+import Development.IDE.Graph.Internal.Types
diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
index ebce4f4f56..8eae867029 100644
--- a/hls-graph/src/Development/IDE/Graph/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -1,18 +1,49 @@
 
 module Development.IDE.Graph.Database(
-    Shake.ShakeDatabase,
+    ShakeDatabase,
     shakeOpenDatabase,
     shakeRunDatabase,
-    Shake.shakeProfileDatabase,
+    shakeProfileDatabase,
     ) where
 
-import           Development.IDE.Graph.Internal.Action
-import           Development.IDE.Graph.Internal.Options
-import           Development.IDE.Graph.Internal.Rules
-import qualified Development.Shake.Database             as Shake
+import Development.IDE.Graph.Internal.Action
+import Development.IDE.Graph.Internal.Options
+import Development.IDE.Graph.Internal.Rules
+import Development.IDE.Graph.Internal.Types
+import Data.Maybe
+import Data.Dynamic
+import Development.IDE.Graph.Internal.Database
+import GHC.Conc
+import Control.Concurrent.Extra
 
-shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO Shake.ShakeDatabase, IO ())
-shakeOpenDatabase a b = Shake.shakeOpenDatabase (fromShakeOptions a) (fromRules b)
 
-shakeRunDatabase :: Shake.ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
-shakeRunDatabase a b = Shake.shakeRunDatabase a (map fromAction b)
+data ShakeDatabase = ShakeDatabase !Int !Int [Action ()] Database
+
+-- Placeholder to be the 'extra' if the user doesn't set it
+data NonExportedType = NonExportedType
+
+shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())
+shakeOpenDatabase opts rules = pure (shakeNewDatabase opts rules, pure ())
+
+shakeNewDatabase :: ShakeOptions -> Rules () -> IO ShakeDatabase
+shakeNewDatabase opts rules = do
+    let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts
+    (theRules, actions) <- runRules extra rules
+    db <- newDatabase extra theRules
+    let threads = shakeThreads opts
+    threads <- if threads /= 0 then pure threads else getNumProcessors
+    pure $ ShakeDatabase threads (length actions) actions db
+
+shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
+shakeRunDatabase (ShakeDatabase threads lenAs1 as1 db) as2 = withNumCapabilities threads $ do
+    incDatabase db
+    as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2
+    return (as, [])
+
+-- Only valid if we never pull on the results, which we don't
+unvoid :: Functor m => m () -> m a
+unvoid = fmap undefined
+
+-- Noop
+shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()
+shakeProfileDatabase _ file = writeFile file ""
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
index 836611d8f0..13cd155a1c 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
@@ -1,38 +1,100 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Development.IDE.Graph.Internal.Action where
 
-import           Control.Exception
-import           Control.Monad.Fail
-import           Control.Monad.IO.Class
-import qualified Development.Shake         as Shake
-import           Development.Shake.Classes
-import qualified Development.Shake.Rule    as Shake
+import qualified Development.Shake as Shake
+import Development.Shake.Classes
+import Control.Exception
+import Control.Concurrent.Async
+import System.Exit
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Reader
+import Data.IORef
+import Development.IDE.Graph.Internal.Database
+import Development.IDE.Graph.Internal.Types
+import Control.Monad.Extra
+import Control.Monad.Trans.Class
+import Control.Concurrent.Async
 
-newtype Action a = Action {fromAction :: Shake.Action a}
-    deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
 
 alwaysRerun :: Action ()
-alwaysRerun = Action Shake.alwaysRerun
+alwaysRerun = do
+    ref <- Action $ asks actionDeps
+    liftIO $ writeIORef ref Nothing
 
+-- No-op for now
 reschedule :: Double -> Action ()
-reschedule = Action . Shake.reschedule
+reschedule _ = pure ()
 
 parallel :: [Action a] -> Action [a]
-parallel = Action . Shake.parallel . map fromAction
+parallel [] = pure []
+parallel [x] = fmap (:[]) x
+parallel xs = do
+    a <- Action ask
+    deps <- liftIO $ readIORef $ actionDeps a
+    case deps of
+        Nothing ->
+            -- if we are already in the rerun mode, nothing we do is going to impact our state
+            liftIO $ mapConcurrently (ignoreState a) xs
+        Just deps -> do
+            (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
+            liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps
+            pure res
+    where
+        ignoreState a x = do
+            ref <- newIORef Nothing
+            runReaderT (fromAction x) a{actionDeps=ref}
+
+        usingState a x = do
+            ref <- newIORef $ Just []
+            res <- runReaderT (fromAction x) a{actionDeps=ref}
+            deps <- readIORef ref
+            pure (deps, res)
+
+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 = Action $ Shake.actionCatch (fromAction a) (fromAction . b)
+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 = Action $ Shake.actionBracket a b (fromAction . 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 = Action $ Shake.actionFinally (fromAction a) b
+actionFinally a b = do
+    v <- Action ask
+    Action $ lift $ finally (runReaderT (fromAction a) v) b
 
 apply1 :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => key -> Action value
-apply1 = Action . Shake.apply1
+apply1 k = head <$> apply [k]
 
 apply :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value) => [key] -> Action [value]
-apply = Action . Shake.apply
+apply ks = do
+    db <- Action $ asks actionDatabase
+    (is, vs) <- liftIO $ build db ks
+    ref <- Action $ asks actionDeps
+    deps <- liftIO $ readIORef ref
+    whenJust deps $ \deps ->
+        liftIO $ writeIORef ref $ Just $ is ++ deps
+    pure vs
+
+runActions :: Database -> [Action a] -> IO [a]
+runActions db xs = do
+    deps <- newIORef Nothing
+    runReaderT (fromAction $ parallel xs) $ SAction db deps
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
new file mode 100644
index 0000000000..c53b9e46ca
--- /dev/null
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -0,0 +1,144 @@
+-- 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 LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Development.IDE.Graph.Internal.Database where
+
+import Development.IDE.Graph.Internal.Intern
+import Development.IDE.Graph.Internal.Types
+import Data.Dynamic
+import qualified Development.IDE.Graph.Internal.Intern as Intern
+import qualified Development.IDE.Graph.Internal.Ids as Ids
+import Control.Concurrent.Extra
+import Data.IORef.Extra
+import Control.Monad
+import Development.Shake.Classes
+import qualified Development.Shake as Shake
+import Data.Maybe
+import Control.Concurrent.Async
+import System.IO.Unsafe
+import Development.IDE.Graph.Internal.Rules
+import qualified Development.Shake.Rule as Shake
+import Control.Exception
+import Control.Monad.Trans.Reader
+import Data.Tuple.Extra
+import Data.Either
+
+newDatabase :: Dynamic -> TheRules -> IO Database
+newDatabase databaseExtra databaseRules = do
+    databaseStep <- newIORef $ Step 0
+    databaseLock <- newLock
+    databaseIds <- newIORef Intern.empty
+    databaseValues <- Ids.empty
+    pure Database{..}
+
+incDatabase :: Database -> IO ()
+incDatabase db = do
+    modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1
+    Ids.forMutate (databaseValues db) $ second $ \case
+        Clean x -> Dirty (Just x)
+        Dirty x -> Dirty x
+        Running _ x -> Dirty x
+
+
+build
+    :: forall key value . (Shake.RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
+    => Database -> [key] -> IO ([Id], [value])
+build db keys = do
+    (ids, vs) <- fmap unzip $ builder db $ map (Right . Key) keys
+    pure (ids, map (asV . resultValue) vs)
+    where
+        asV :: Value -> value
+        asV (Value x) = unwrapDynamic x
+
+builder
+    :: Database -> [Either Id Key] -> IO [(Id, Result)]
+builder db@Database{..} keys = do
+    -- Async things that I own and am responsible for killing
+    ownedAsync <- newIORef []
+    flip onException (cleanupAsync ownedAsync) $ do
+
+        -- Things that I need to force before my results are ready
+        toForce <- newIORef []
+
+        results <- withLock databaseLock $ do
+            forM keys $ \idKey -> do
+                id <- case idKey of
+                    Left id -> pure id
+                    Right key -> 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
+
+                status <- Ids.lookup databaseValues id
+                val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of
+                    (_, Clean r) -> pure r
+                    (_, Running act _) -> do
+                        -- we promise to force everything in todo before reading the results
+                        -- so the following unsafePerformIO isn't actually unsafe
+                        let (force, val) = splitIO act
+                        modifyIORef toForce (force:)
+                        pure val
+                    (key, Dirty s) -> do
+                        -- Important we don't lose any Async things we create
+                        act <- uninterruptibleMask $ \restore -> do
+                            -- the child actions should always be spawned unmasked
+                            -- or they can't be killed
+                            async <- async $ restore $ check db key id s
+                            modifyIORef ownedAsync (async:)
+                            pure $ wait async
+                        Ids.insert databaseValues id (key, Running act s)
+                        let (force, val) = splitIO act
+                        modifyIORef toForce (force:)
+                        pure val
+
+                pure (id, val)
+
+        sequence_ =<< readIORef toForce
+        pure results
+
+cleanupAsync :: IORef [Async a] -> IO ()
+cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref
+
+
+-- Check if we need to run the database.
+check :: Database -> Key -> Id -> Maybe Result -> IO Result
+check db key id result@(Just me@Result{resultDeps=Just deps}) = do
+    res <- builder db $ map Left deps
+    let dirty = all (\(_,dep) -> resultBuilt me < resultChanged dep) res
+    let mode = if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame
+    spawn db key id mode result
+check db key id result = spawn db key id Shake.RunDependenciesChanged result
+
+
+-- Spawn a new computation to run the action.
+spawn :: Database -> Key -> Id -> Shake.RunMode -> Maybe Result -> IO Result
+spawn db@Database{..} key id mode result = do
+    let act = runRule databaseRules key (fmap resultData result) mode
+    deps <- newIORef $ Just []
+    Shake.RunResult{..} <- runReaderT (fromAction act) $ SAction db deps
+    built <- readIORef databaseStep
+    deps <- readIORef deps
+    let changed = if runChanged == Shake.ChangedRecomputeDiff then built else maybe built resultChanged result
+    let res = Result runValue built changed deps runStore
+    withLock databaseLock $
+        Ids.insert databaseValues id (key, Clean res)
+    pure res
+
+data Box a = Box {fromBox :: a}
+
+splitIO :: IO a -> (IO (), a)
+splitIO act = do
+    let act2 = Box <$> act
+    let res = unsafePerformIO act2
+    (void $ evaluate res, fromBox res)
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs b/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs
new file mode 100644
index 0000000000..30ae92dbaa
--- /dev/null
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE RecordWildCards, BangPatterns, GADTs, 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 Data.IORef.Extra
+import Data.Primitive.Array hiding (fromList)
+import Control.Exception
+import Development.IDE.Graph.Internal.Intern(Id(..))
+import Control.Monad.Extra
+import Data.List.Extra(zipFrom)
+import Data.Maybe
+import Data.Functor
+import qualified Data.HashMap.Strict as Map
+import Prelude hiding (lookup, null)
+import GHC.IO(IO(..))
+import GHC.Exts(RealWorld)
+
+
+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 $ Id $ 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 -> (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 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  #) -> (Id $ 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) (Id 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) (Id i) = do
+    S{..} <- readIORef ref
+    let ii = fromIntegral i
+    if ii < used then
+        readArray values ii
+     else
+        pure Nothing
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs b/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs
new file mode 100644
index 0000000000..66c075d67f
--- /dev/null
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Development.IDE.Graph.Internal.Intern(
+    Intern, Id(..),
+    empty, insert, add, lookup, toList, fromList
+    ) where
+
+import Development.Shake.Classes
+import Foreign.Storable
+import Data.Word
+import Prelude hiding (lookup)
+import qualified Data.HashMap.Strict as Map
+import Data.List(foldl')
+
+
+-- Invariant: The first field is the highest value in the Map
+data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id)
+
+newtype Id = Id Word32
+    deriving (Eq,Hashable,Ord,Binary,Show,NFData,Storable)
+
+empty :: Intern a
+empty = Intern 0 Map.empty
+
+
+insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a
+insert k v@(Id i) (Intern n mp) = Intern (max n i) $ 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 (Id v2) mp, Id 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 | (_, Id i) <- xs]) (Map.fromList xs)
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs
index 36f62bcb1b..f518cc0bd8 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Options.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Options.hs
@@ -2,11 +2,9 @@
 
 module Development.IDE.Graph.Internal.Options where
 
-import           Data.Dynamic
-import qualified Data.HashMap.Strict                   as Map
-import           Development.IDE.Graph.Internal.Action
-import           Development.IDE.Graph.Internal.Rules
-import qualified Development.Shake                     as Shake
+import Data.Dynamic
+import Control.Monad.Trans.Reader
+import Development.IDE.Graph.Internal.Types
 
 data ShakeOptions = ShakeOptions {
     shakeThreads            :: Int,
@@ -19,22 +17,15 @@ data ShakeOptions = ShakeOptions {
 shakeOptions :: ShakeOptions
 shakeOptions = ShakeOptions 0 ".shake" Nothing False False
 
-fromShakeOptions :: ShakeOptions -> Shake.ShakeOptions
-fromShakeOptions ShakeOptions{..} = Shake.shakeOptions{
-    Shake.shakeThreads = shakeThreads,
-    Shake.shakeFiles = shakeFiles,
-    Shake.shakeExtra = maybe Map.empty f shakeExtra,
-    Shake.shakeAllowRedefineRules = shakeAllowRedefineRules,
-    Shake.shakeTimings = shakeTimings
-    }
-    where f x = Map.singleton (dynTypeRep x) x
-
-
 getShakeExtra :: Typeable a => Action (Maybe a)
-getShakeExtra = Action Shake.getShakeExtra
+getShakeExtra = do
+    extra <- Action $ asks $ databaseExtra . actionDatabase
+    pure $ fromDynamic extra
 
 getShakeExtraRules :: Typeable a => Rules (Maybe a)
-getShakeExtraRules = Rules Shake.getShakeExtraRules
+getShakeExtraRules = do
+    extra <- Rules $ asks rulesExtra
+    pure $ fromDynamic extra
 
 newShakeExtra :: Typeable a => a -> Maybe Dynamic
 newShakeExtra = Just . toDyn
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
index d1cf1703e7..83fbc14d25 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
@@ -1,3 +1,6 @@
+-- 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               #-}
 
@@ -15,10 +18,34 @@ newtype Rules a = Rules {fromRules :: Shake.Rules a}
     deriving (Monoid, Semigroup, Monad, Applicative, Functor, MonadIO, MonadFail)
 
 action :: Action a -> Rules ()
-action = Rules . Shake.action . fromAction
+action x = do
+    ref <- Rules $ asks rulesActions
+    liftIO $ modifyIORef' ref (void x:)
 
 addRule
-    :: (Shake.RuleResult key ~ value, Shake.ShakeValue key, Typeable value, NFData value, Show value)
+    :: forall key value .
+       (Shake.RuleResult key ~ value, Typeable key, Hashable key, Eq key, Typeable value)
     => (key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.RunResult value))
     -> Rules ()
-addRule f = Rules $ Shake.addBuiltinRule Shake.noLint Shake.noIdentity $ \k bs r -> fromAction $ f k bs r
+addRule f = do
+    ref <- Rules $ asks rulesMap
+    liftIO $ modifyIORef' ref $ Map.insert (typeRep (Proxy :: Proxy key)) (toDyn f2)
+    where
+        f2 :: Key -> Maybe BS.ByteString -> Shake.RunMode -> Action (Shake.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 -> Shake.RunMode -> Action (Shake.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/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
new file mode 100644
index 0000000000..d185439e0a
--- /dev/null
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -0,0 +1,107 @@
+
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Development.IDE.Graph.Internal.Types where
+
+import Control.Monad.Trans.Reader
+import Data.IORef
+import qualified Data.HashMap.Strict as Map
+import Data.Typeable
+import Data.Dynamic
+import Control.Monad.Fail
+import Control.Monad.IO.Class
+import Development.IDE.Graph.Internal.Ids
+import Control.Concurrent.Extra
+import Development.IDE.Graph.Internal.Intern
+import Control.Applicative
+import Development.Shake.Classes
+import qualified Data.ByteString as BS
+import Data.Maybe
+
+
+unwrapDynamic :: forall a . Typeable a => Dynamic -> a
+unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x
+    where msg = "unwrapDynamic failed: Expected " ++ show (typeRep (Proxy :: Proxy a)) ++
+                ", but got " ++ show (dynTypeRep x)
+
+---------------------------------------------------------------------
+-- RULES
+
+type TheRules = Map.HashMap TypeRep Dynamic
+
+newtype Rules a = Rules (ReaderT SRules IO a)
+    deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
+
+data SRules = SRules {
+    rulesExtra :: !Dynamic,
+    rulesActions :: !(IORef [Action ()]),
+    rulesMap :: !(IORef TheRules)
+    }
+
+
+---------------------------------------------------------------------
+-- ACTIONS
+
+newtype Action a = Action {fromAction :: ReaderT SAction IO a}
+    deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
+
+data SAction = SAction {
+    actionDatabase :: !Database,
+    actionDeps :: !(IORef (Maybe [Id])) -- Nothing means always rerun
+    }
+
+
+---------------------------------------------------------------------
+-- DATABASE
+
+newtype Step = Step Int
+    deriving (Eq,Ord)
+
+data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a
+
+instance Eq Key where
+    Key a == Key b = Just a == cast b
+
+instance Hashable Key where
+    hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x)
+
+instance Show Key where
+    show (Key x) = show x
+
+newtype Value = Value Dynamic
+
+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))
+    }
+
+data Status
+    = Clean Result
+    | Dirty (Maybe Result)
+    | Running (IO Result) (Maybe Result)
+
+data Result = Result {
+    resultValue :: !Value,
+    resultBuilt :: !Step,
+    resultChanged :: !Step,
+    resultDeps :: !(Maybe [Id]), -- Nothing = alwaysRerun
+    resultData :: BS.ByteString
+    }
+
+
+---------------------------------------------------------------------
+-- INSTANCES
+
+instance Semigroup a => Semigroup (Rules a) where
+    a <> b = liftA2 (<>) a b
+
+instance Monoid a => Monoid (Rules a) where
+    mempty = pure mempty