|
| 1 | +-- We deliberately want to ensure the function we add to the rule database |
| 2 | +-- has the constraints we need on it when we get it out. |
| 3 | +{-# OPTIONS_GHC -Wno-redundant-constraints #-} |
| 4 | +{-# LANGUAGE LambdaCase #-} |
| 5 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 6 | +{-# LANGUAGE RecordWildCards #-} |
| 7 | +{-# LANGUAGE TypeFamilies #-} |
| 8 | +{-# LANGUAGE TupleSections #-} |
| 9 | +{-# LANGUAGE NamedFieldPuns #-} |
| 10 | + |
| 11 | +module Development.IDE.Graph.Internal.Database where |
| 12 | + |
| 13 | +import Development.IDE.Graph.Internal.Intern |
| 14 | +import Development.IDE.Graph.Internal.Types |
| 15 | +import Data.Dynamic |
| 16 | +import qualified Development.IDE.Graph.Internal.Intern as Intern |
| 17 | +import qualified Development.IDE.Graph.Internal.Ids as Ids |
| 18 | +import Control.Concurrent.Extra |
| 19 | +import Data.IORef.Extra |
| 20 | +import Control.Monad |
| 21 | +import Development.Shake.Classes |
| 22 | +import qualified Development.Shake as Shake |
| 23 | +import Data.Maybe |
| 24 | +import Control.Concurrent.Async |
| 25 | +import System.IO.Unsafe |
| 26 | +import Development.IDE.Graph.Internal.Rules |
| 27 | +import qualified Development.Shake.Rule as Shake |
| 28 | +import Control.Exception |
| 29 | +import Control.Monad.Trans.Reader |
| 30 | +import Data.Tuple.Extra |
| 31 | +import Data.Either |
| 32 | + |
| 33 | +newDatabase :: Dynamic -> TheRules -> IO Database |
| 34 | +newDatabase databaseExtra databaseRules = do |
| 35 | + databaseStep <- newIORef $ Step 0 |
| 36 | + databaseLock <- newLock |
| 37 | + databaseIds <- newIORef Intern.empty |
| 38 | + databaseValues <- Ids.empty |
| 39 | + pure Database{..} |
| 40 | + |
| 41 | +incDatabase :: Database -> IO () |
| 42 | +incDatabase db = do |
| 43 | + modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 |
| 44 | + Ids.forMutate (databaseValues db) $ second $ \case |
| 45 | + Clean x -> Dirty (Just x) |
| 46 | + Dirty x -> Dirty x |
| 47 | + Running _ x -> Dirty x |
| 48 | + |
| 49 | + |
| 50 | +build |
| 51 | + :: forall key value . (Shake.RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) |
| 52 | + => Database -> [key] -> IO ([Id], [value]) |
| 53 | +build db keys = do |
| 54 | + (ids, vs) <- fmap unzip $ builder db $ map (Right . Key) keys |
| 55 | + pure (ids, map (asV . resultValue) vs) |
| 56 | + where |
| 57 | + asV :: Value -> value |
| 58 | + asV (Value x) = unwrapDynamic x |
| 59 | + |
| 60 | +builder |
| 61 | + :: Database -> [Either Id Key] -> IO [(Id, Result)] |
| 62 | +builder db@Database{..} keys = do |
| 63 | + -- Async things that I own and am responsible for killing |
| 64 | + ownedAsync <- newIORef [] |
| 65 | + flip onException (cleanupAsync ownedAsync) $ do |
| 66 | + |
| 67 | + -- Things that I need to force before my results are ready |
| 68 | + toForce <- newIORef [] |
| 69 | + |
| 70 | + results <- withLock databaseLock $ do |
| 71 | + forM keys $ \idKey -> do |
| 72 | + id <- case idKey of |
| 73 | + Left id -> pure id |
| 74 | + Right key -> do |
| 75 | + ids <- readIORef databaseIds |
| 76 | + case Intern.lookup key ids of |
| 77 | + Just v -> pure v |
| 78 | + Nothing -> do |
| 79 | + (ids, id) <- pure $ Intern.add key ids |
| 80 | + writeIORef' databaseIds ids |
| 81 | + return id |
| 82 | + |
| 83 | + status <- Ids.lookup databaseValues id |
| 84 | + val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of |
| 85 | + (_, Clean r) -> pure r |
| 86 | + (_, Running act _) -> do |
| 87 | + -- we promise to force everything in todo before reading the results |
| 88 | + -- so the following unsafePerformIO isn't actually unsafe |
| 89 | + let (force, val) = splitIO act |
| 90 | + modifyIORef toForce (force:) |
| 91 | + pure val |
| 92 | + (key, Dirty s) -> do |
| 93 | + -- Important we don't lose any Async things we create |
| 94 | + act <- uninterruptibleMask $ \restore -> do |
| 95 | + -- the child actions should always be spawned unmasked |
| 96 | + -- or they can't be killed |
| 97 | + async <- async $ restore $ check db key id s |
| 98 | + modifyIORef ownedAsync (async:) |
| 99 | + pure $ wait async |
| 100 | + Ids.insert databaseValues id (key, Running act s) |
| 101 | + let (force, val) = splitIO act |
| 102 | + modifyIORef toForce (force:) |
| 103 | + pure val |
| 104 | + |
| 105 | + pure (id, val) |
| 106 | + |
| 107 | + sequence_ =<< readIORef toForce |
| 108 | + pure results |
| 109 | + |
| 110 | +cleanupAsync :: IORef [Async a] -> IO () |
| 111 | +cleanupAsync ref = mapConcurrently_ uninterruptibleCancel =<< readIORef ref |
| 112 | + |
| 113 | + |
| 114 | +-- Check if we need to run the database. |
| 115 | +check :: Database -> Key -> Id -> Maybe Result -> IO Result |
| 116 | +check db key id result@(Just me@Result{resultDeps=Just deps}) = do |
| 117 | + res <- builder db $ map Left deps |
| 118 | + let dirty = all (\(_,dep) -> resultBuilt me < resultChanged dep) res |
| 119 | + let mode = if dirty then Shake.RunDependenciesChanged else Shake.RunDependenciesSame |
| 120 | + spawn db key id mode result |
| 121 | +check db key id result = spawn db key id Shake.RunDependenciesChanged result |
| 122 | + |
| 123 | + |
| 124 | +-- Spawn a new computation to run the action. |
| 125 | +spawn :: Database -> Key -> Id -> Shake.RunMode -> Maybe Result -> IO Result |
| 126 | +spawn db@Database{..} key id mode result = do |
| 127 | + let act = runRule databaseRules key (fmap resultData result) mode |
| 128 | + deps <- newIORef $ Just [] |
| 129 | + Shake.RunResult{..} <- runReaderT (fromAction act) $ SAction db deps |
| 130 | + built <- readIORef databaseStep |
| 131 | + deps <- readIORef deps |
| 132 | + let changed = if runChanged == Shake.ChangedRecomputeDiff then built else maybe built resultChanged result |
| 133 | + let res = Result runValue built changed deps runStore |
| 134 | + withLock databaseLock $ |
| 135 | + Ids.insert databaseValues id (key, Clean res) |
| 136 | + pure res |
| 137 | + |
| 138 | +data Box a = Box {fromBox :: a} |
| 139 | + |
| 140 | +splitIO :: IO a -> (IO (), a) |
| 141 | +splitIO act = do |
| 142 | + let act2 = Box <$> act |
| 143 | + let res = unsafePerformIO act2 |
| 144 | + (void $ evaluate res, fromBox res) |
0 commit comments