hls-graph 1.6.0.0 → 1.7.0.0

raw patch · 16 files changed

+549/−275 lines, 16 filesdep +hls-graphdep +hspecdep +tastydep ~asyncdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: hls-graph, hspec, tasty, tasty-hspec, tasty-hunit, tasty-rerun, text

Dependency ranges changed: async, base

API changes (from Hackage documentation)

Files

• hls-graph.cabal +31/−1
• src/Development/IDE/Graph.hs +1/−1
• src/Development/IDE/Graph/Classes.hs +8/−8
• src/Development/IDE/Graph/Database.hs +4/−9
• src/Development/IDE/Graph/Internal/Action.hs +147/−137
• src/Development/IDE/Graph/Internal/Database.hs +87/−51
• src/Development/IDE/Graph/Internal/Options.hs +1/−4
• src/Development/IDE/Graph/Internal/Rules.hs +57/−58
• src/Development/IDE/Graph/Internal/Types.hs +59/−5
• src/Development/IDE/Graph/Rule.hs +1/−1
• test/ActionSpec.hs +77/−0
• test/DatabaseSpec.hs +29/−0
• test/Example.hs +31/−0
• test/Main.hs +7/−0
• test/RulesSpec.hs +8/−0
• test/Spec.hs +1/−0

@@ -1,6 +1,6 @@ cabal-version: 2.4 name:          hls-graph-version:       1.6.0.0+version:       1.7.0.0 synopsis:      Haskell Language Server internal graph API description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server/tree/master/hls-graph#readme>@@ -104,3 +104,33 @@     DataKinds     KindSignatures     TypeOperators++test-suite tests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   test+  main-is:          Main.hs+  other-modules:+    ActionSpec+    DatabaseSpec+    Example+    RulesSpec+    Spec++  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts+  build-depends:+    , base+    , containers+    , directory+    , extra+    , filepath+    , hls-graph+    , hspec+    , stm+    , stm-containers+    , tasty+    , tasty-hspec+    , tasty-hunit+    , tasty-rerun+    , text+  build-tool-depends: hspec-discover:hspec-discover -any

@@ -5,7 +5,7 @@     Key(..),     actionFinally, actionBracket, actionCatch, actionFork,     -- * Configuration-    ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra),+    ShakeOptions(shakeAllowRedefineRules, shakeExtra),     getShakeExtra, getShakeExtraRules, newShakeExtra,     -- * Explicit parallelism     parallel,

@@ -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

@@ -4,7 +4,7 @@ module Development.IDE.Graph.Database(     ShakeDatabase,     ShakeValue,-    shakeOpenDatabase,+    shakeNewDatabase,     shakeRunDatabase,     shakeRunDatabaseForKeys,     shakeProfileDatabase,@@ -23,14 +23,10 @@ import           Development.IDE.Graph.Internal.Rules import           Development.IDE.Graph.Internal.Types -data ShakeDatabase = ShakeDatabase !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@@ -38,7 +34,7 @@     db <- newDatabase extra theRules     pure $ ShakeDatabase (length actions) actions db -shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])+shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO [a] shakeRunDatabase = shakeRunDatabaseForKeys Nothing  -- | Returns the set of dirty keys annotated with their age (in # of builds)@@ -62,11 +58,10 @@       -- ^ Set of keys changed since last run. 'Nothing' means everything has changed     -> ShakeDatabase     -> [Action a]-    -> IO ([a], [IO ()])+    -> IO [a] shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do     incDatabase db keysChanged-    as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2-    return (as, [])+    fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2  -- | Given a 'ShakeDatabase', write an HTML profile to the given file about the latest run. shakeProfileDatabase :: ShakeDatabase -> FilePath -> IO ()

@@ -1,137 +1,147 @@-{-# 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
+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++module Development.IDE.Graph.Internal.Action+( ShakeValue+, actionFork+, actionBracket+, actionCatch+, actionFinally+, alwaysRerun+, apply1+, apply+, applyWithoutDependency+, 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+    stack <- Action $ asks actionStack+    (is, vs) <- liftIO $ build db stack ks+    ref <- Action $ asks actionDeps+    liftIO $ modifyIORef ref (ResultDeps is <>)+    pure vs++-- | Evaluate a list of keys without recording any dependencies.+applyWithoutDependency :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]+applyWithoutDependency ks = do+    db <- Action $ asks actionDatabase+    stack <- Action $ asks actionStack+    (_, vs) <- liftIO $ build db stack ks+    pure vs++runActions :: Database -> [Action a] -> IO [a]+runActions db xs = do+    deps <- newIORef mempty+    runReaderT (fromAction $ parallel xs) $ SAction db deps emptyStack++-- | 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

@@ -8,6 +8,7 @@ {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TupleSections #-}  module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -32,14 +33,15 @@ import           Data.Maybe import           Data.Traversable                     (for) import           Data.Tuple.Extra+import           Debug.Trace (traceM) import           Development.IDE.Graph.Classes 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.Time.Extra                    (duration, sleep) import           System.IO.Unsafe-import           System.Time.Extra                    (duration)  newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do@@ -77,10 +79,11 @@ -- | 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 ([Key], [value])-build db keys = do+    => Database -> Stack -> [key] -> IO ([Key], [value])+-- build _ st k | traceShow ("build", st, k) False = undefined+build db stack keys = do     (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<<-            builder db (map Key keys)+            builder db stack (map Key keys)     pure (ids, map (asV . resultValue) vs)     where         asV :: Value -> value@@ -90,8 +93,9 @@ --  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 -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)]))-builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do+    :: Database -> Stack -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)]))+-- builder _ st kk | traceShow ("builder", st,kk) False = undefined+builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do     -- Things that I need to force before my results are ready     toForce <- liftIO $ newTVarIO []     current <- liftIO $ readTVarIO databaseStep@@ -103,11 +107,13 @@             status <- SMap.lookup id databaseValues             val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of                 Clean r -> pure r-                Running _ force val _ -> do+                Running _ force val _+                  | memberStack id stack -> throw $ StackException stack+                  | otherwise -> do                     modifyTVar' toForce (Wait force :)                     pure val                 Dirty s -> do-                    let act = run (refresh db id s)+                    let act = run (refresh db stack id s)                         (force, val) = splitIO (join act)                     SMap.focus (updateStatus $ Running current force val s) id databaseValues                     modifyTVar' toForce (Spawn force:)@@ -116,7 +122,7 @@             pure (id, val)      toForceList <- liftIO $ readTVarIO toForce-    let waitAll = run $ mapConcurrentlyAIO_ id toForceList+    let waitAll = run $ waitConcurrently_ toForceList     case toForceList of         [] -> return $ Left results         _ -> return $ Right $ do@@ -127,32 +133,33 @@ --     * 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 -> 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 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 mode result-    where-        isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)--refresh db key result =-    asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result-+refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)+-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined+refresh db stack key result = case (addStack key stack, result) of+    (Left e, _) -> throw e+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> do+        res <- builder db stack deps+        let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)+        case res of+            Left res ->+                if isDirty res+                    then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result+                    else pure $ compute db stack key RunDependenciesSame result+            Right iores -> asyncWithCleanUp $ liftIO $ do+                res <- iores+                let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame+                compute db stack key mode result+    (Right stack, _) ->+        asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result  -- | Compute a key.-compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result-compute db@Database{..} key mode result = do+compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result+-- compute _ st k _ _ | traceShow ("compute", st, k) False = undefined+compute db@Database{..} stack 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+        duration $ runReaderT (fromAction act) $ SAction db deps stack     built <- readTVarIO databaseStep     deps <- readIORef deps     let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result@@ -165,7 +172,11 @@         deps | not(null deps)             && runChanged /= ChangedNothing                     -> do-            void $ forkIO $+            -- IMPORTANT: record the reverse deps **before** marking the key Clean.+            -- If an async exception strikes before the deps have been recorded,+            -- we won't be able to accurately propagate dirtiness for this key+            -- on the next build.+            void $                 updateReverseDeps key db                     (getResultDepsDefault [] previousDeps)                     (HSet.fromList deps)@@ -219,7 +230,8 @@     -> [Key] -- ^ Previous direct dependencies of Id     -> HashSet Key -- ^ Current direct dependencies of Id     -> IO ()-updateReverseDeps myId db prev new = uninterruptibleMask_ $ do+-- mask to ensure that all the reverse dependencies are updated+updateReverseDeps myId db prev new = do     forM_ prev $ \d ->         unless (d `HSet.member` new) $             doOne (HSet.delete myId) d@@ -247,20 +259,27 @@             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'+--------------------------------------------------------------------------------+-- Asynchronous computations with cancellation++-- | A simple monad to implement cancellation on top of 'Async',+--   generalizing 'withAsync' to monadic scopes. newtype AIO a = AIO { unAIO :: ReaderT (IORef [Async ()]) IO a }   deriving newtype (Applicative, Functor, Monad, MonadIO) +-- | Run the monadic computation, cancelling all the spawned asyncs if an exception arises runAIO :: AIO a -> IO a runAIO (AIO act) = do     asyncs <- newIORef []     runReaderT act asyncs `onException` cleanupAsync asyncs +-- | Like 'async' but with built-in cancellation.+--   Returns an IO action to wait on the result. asyncWithCleanUp :: AIO a -> AIO (IO a) asyncWithCleanUp act = do     st <- AIO ask     io <- unliftAIO act+    -- mask to make sure we keep track of the spawned async     liftIO $ uninterruptibleMask $ \restore -> do         a <- async $ restore io         atomicModifyIORef'_ st (void a :)@@ -279,28 +298,45 @@     k $ RunInIO (\aio -> runReaderT (unAIO aio) st)  cleanupAsync :: IORef [Async a] -> IO ()-cleanupAsync ref = uninterruptibleMask_ $ do-    asyncs <- readIORef ref+-- mask to make sure we interrupt all the asyncs+cleanupAsync ref = uninterruptibleMask $ \unmask -> do+    asyncs <- atomicModifyIORef' ref ([],)+    -- interrupt all the asyncs without waiting     mapM_ (\a -> throwTo (asyncThreadId a) AsyncCancelled) asyncs-    mapM_ waitCatch asyncs+    -- Wait until all the asyncs are done+    -- But if it takes more than 10 seconds, log to stderr+    unless (null asyncs) $ do+        let warnIfTakingTooLong = unmask $ forever $ do+                sleep 10+                traceM "cleanupAsync: waiting for asyncs to finish"+        withAsync warnIfTakingTooLong $ \_ ->+            mapM_ waitCatch asyncs -data Wait a-    = Wait {justWait :: !a}-    | Spawn {justWait :: !a}-    deriving Functor+data Wait+    = Wait {justWait :: !(IO ())}+    | Spawn {justWait :: !(IO ())} -waitOrSpawn :: Wait (IO a) -> IO (Either (IO a) (Async a))+fmapWait :: (IO () -> IO ()) -> Wait -> Wait+fmapWait f (Wait io) = Wait (f io)+fmapWait f (Spawn io) = Spawn (f io)++waitOrSpawn :: Wait -> IO (Either (IO ()) (Async ())) waitOrSpawn (Wait io)  = pure $ Left io waitOrSpawn (Spawn io) = Right <$> async io -mapConcurrentlyAIO_ :: (a -> IO ()) -> [Wait a] -> AIO ()-mapConcurrentlyAIO_ _ [] = pure ()-mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one-mapConcurrentlyAIO_ f many = do+waitConcurrently_ :: [Wait] -> AIO ()+waitConcurrently_ [] = pure ()+waitConcurrently_ [one] = liftIO $ justWait one+waitConcurrently_ many = do     ref <- AIO ask-    waits <- liftIO $ uninterruptibleMask $ \restore -> do-        waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many-        let asyncs = rights waits+    -- spawn the async computations.+    -- mask to make sure we keep track of all the asyncs.+    (asyncs, syncs) <- liftIO $ uninterruptibleMask $ \unmask -> do+        waits <- liftIO $ traverse (waitOrSpawn . fmapWait unmask) many+        let (syncs, asyncs) = partitionEithers waits         liftIO $ atomicModifyIORef'_ ref (asyncs ++)-        return waits-    liftIO $ traverse_ (either id wait) waits+        return (asyncs, syncs)+    -- work on the sync computations+    liftIO $ sequence_ syncs+    -- wait for the async computations before returning+    liftIO $ traverse_ wait asyncs

@@ -5,16 +5,13 @@ import           Development.IDE.Graph.Internal.Types  data ShakeOptions = ShakeOptions {-    -- | Has no effect, kept only for api compatibility with Shake-    shakeThreads            :: Int,-    shakeFiles              :: FilePath,     shakeExtra              :: Maybe Dynamic,     shakeAllowRedefineRules :: Bool,     shakeTimings            :: Bool     }  shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions 0 ".shake" Nothing False False+shakeOptions = ShakeOptions Nothing False False  getShakeExtra :: Typeable a => Action (Maybe a) getShakeExtra = do

@@ -1,58 +1,57 @@--- 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
+-- 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@.+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

@@ -26,7 +26,7 @@ import qualified Data.ByteString               as BS import           Data.Dynamic import qualified Data.HashMap.Strict           as Map-import           Data.HashSet                  (HashSet)+import           Data.HashSet                  (HashSet, member) import           Data.IORef import           Data.Maybe import           Data.Typeable@@ -36,6 +36,8 @@ import           StmContainers.Map             (Map) import qualified StmContainers.Map             as SMap import           System.Time.Extra             (Seconds)+import qualified Data.HashSet as Set+import Data.List (intercalate)   unwrapDynamic :: forall a . Typeable a => Dynamic -> a@@ -66,7 +68,8 @@  data SAction = SAction {     actionDatabase :: !Database,-    actionDeps     :: !(IORef ResultDeps)+    actionDeps     :: !(IORef ResultDeps),+    actionStack    :: !Stack     }  getDatabase :: Action Database@@ -75,6 +78,8 @@ --------------------------------------------------------------------- -- DATABASE +data ShakeDatabase = ShakeDatabase !Int [Action ()] Database+ newtype Step = Step Int     deriving newtype (Eq,Ord,Hashable) @@ -115,12 +120,12 @@                   . databaseValues  data Status-    = Clean Result+    = Clean !Result     | Dirty (Maybe Result)     | Running {         runningStep   :: !Step,         runningWait   :: !(IO ()),-        runningResult :: Result,+        runningResult :: Result,     -- LAZY         runningPrev   :: !(Maybe Result)         } @@ -140,10 +145,11 @@     resultVisited   :: !Step, -- ^ the step when it was last looked up     resultDeps      :: !ResultDeps,     resultExecution :: !Seconds, -- ^ How long it took, last time it ran-    resultData      :: BS.ByteString+    resultData      :: !BS.ByteString     }  data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key]+  deriving (Eq, Show)  getResultDepsDefault :: [Key] -> ResultDeps -> [Key] getResultDepsDefault _ (ResultDeps ids)      = ids@@ -200,6 +206,54 @@ instance NFData value => NFData (RunResult value) where     rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 +---------------------------------------------------------------------+-- EXCEPTIONS++data GraphException = forall e. Exception e => GraphException {+    target :: String, -- ^ The key that was being built+    stack  :: [String], -- ^ The stack of keys that led to this exception+    inner  :: e -- ^ The underlying exception+}+  deriving (Typeable, Exception)++instance Show GraphException where+    show GraphException{..} = unlines $+        ["GraphException: " ++ target] +++        stack +++        ["Inner exception: " ++ show inner]++fromGraphException :: Typeable b => SomeException -> Maybe b+fromGraphException x = do+    GraphException _ _ e <- fromException x+    cast e++---------------------------------------------------------------------+-- CALL STACK++data Stack = Stack [Key] !(HashSet Key)++instance Show Stack where+    show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk)++newtype StackException = StackException Stack+  deriving (Typeable, Show)++instance Exception StackException where+    fromException = fromGraphException+    toException this@(StackException (Stack stack _)) = toException $+        GraphException (show$ last stack) (map show stack) this++addStack :: Key -> Stack -> Either StackException Stack+addStack k (Stack ks is)+    | k `member` is = Left $ StackException stack2+    | otherwise = Right stack2+    where stack2 = Stack (k:ks) (Set.insert k is)++memberStack :: Key -> Stack -> Bool+memberStack k (Stack _ ks) = k `member` ks++emptyStack :: Stack+emptyStack = Stack [] mempty --------------------------------------------------------------------- -- INSTANCES 

@@ -7,7 +7,7 @@     RunMode(..), RunChanged(..), RunResult(..),     -- * Calling builtin rules     -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule.-    apply, apply1,+    apply, apply1, applyWithoutDependency     ) where  import           Development.IDE.Graph.Internal.Action

@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ActionSpec where++import Control.Concurrent.STM+import Development.IDE.Graph (shakeOptions)+import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase)+import Development.IDE.Graph.Internal.Action (apply1)+import Development.IDE.Graph.Internal.Types+import Development.IDE.Graph.Rule+import Example+import qualified StmContainers.Map as STM+import Test.Hspec+import System.Time.Extra (timeout)++spec :: Spec+spec = do+  describe "apply1" $ do+    it "computes a rule with no dependencies" $ do+      db <- shakeNewDatabase shakeOptions $ do+        ruleUnit+      res <- shakeRunDatabase db $+        pure $ do+          apply1 (Rule @())+      res `shouldBe` [()]+    it "computes a rule with one dependency" $ do+      db <- shakeNewDatabase shakeOptions $ do+        ruleUnit+        ruleBool+      res <- shakeRunDatabase db $ pure $ apply1 Rule+      res `shouldBe` [True]+    it "tracks direct dependencies" $ do+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+        ruleUnit+        ruleBool+      let theKey = Rule @Bool+      res <- shakeRunDatabase db $+        pure $ do+          apply1 theKey+      res `shouldBe` [True]+      Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb+      resultDeps res `shouldBe` ResultDeps [Key (Rule @())]+    it "tracks reverse dependencies" $ do+      db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do+        ruleUnit+        ruleBool+      let theKey = Rule @Bool+      res <- shakeRunDatabase db $+        pure $ do+          apply1 theKey+      res `shouldBe` [True]+      Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues+      keyReverseDeps `shouldBe` [Key theKey]+    it "rethrows exceptions" $ do+      db <- shakeNewDatabase shakeOptions $ do+        addRule $ \(Rule :: Rule ()) old mode -> error "boom"+      let res = shakeRunDatabase db $ pure $ apply1 (Rule @())+      res `shouldThrow` anyErrorCall+  describe "applyWithoutDependency" $ do+    it "does not track dependencies" $ do+      db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+        ruleUnit+        addRule $ \Rule old mode -> do+            [()] <- applyWithoutDependency [Rule]+            return $ RunResult ChangedRecomputeDiff "" True++      let theKey = Rule @Bool+      res <- shakeRunDatabase db $+        pure $ do+          applyWithoutDependency [theKey]+      res `shouldBe` [[True]]+      Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb+      resultDeps res `shouldBe` UnknownDeps

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+module DatabaseSpec where++import Control.Concurrent.STM+import Development.IDE.Graph (shakeOptions)+import Development.IDE.Graph.Database (shakeNewDatabase, shakeRunDatabase)+import Development.IDE.Graph.Internal.Action (apply1)+import Development.IDE.Graph.Internal.Types+import Development.IDE.Graph.Rule+import Example+import qualified StmContainers.Map as STM+import Test.Hspec+import System.Time.Extra (timeout)++spec :: Spec+spec = do+    describe "Evaluation" $ do+        it "detects cycles" $ do+            db <- shakeNewDatabase shakeOptions $ do+                ruleBool+                addRule $ \Rule old mode -> do+                    True <- apply1 (Rule @Bool)+                    return $ RunResult ChangedRecomputeDiff "" ()+            let res = shakeRunDatabase db $ pure $ apply1 (Rule @())+            timeout 1 res `shouldThrow` \StackException{} -> True

@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Example where++import Development.IDE.Graph+import Development.IDE.Graph.Rule+import Development.IDE.Graph.Classes+import GHC.Generics+import Type.Reflection (typeRep)++data Rule a = Rule+    deriving (Eq, Generic, Hashable, NFData)++instance Typeable a => Show (Rule a) where+    show Rule = show $ typeRep @a++type instance RuleResult (Rule a) = a++ruleUnit :: Rules ()+ruleUnit = addRule $ \(Rule :: Rule ()) old mode -> do+    return $ RunResult ChangedRecomputeDiff "" ()++-- | Depends on Rule @()+ruleBool :: Rules ()+ruleBool = addRule $ \Rule old mode -> do+    () <- apply1 Rule+    return $ RunResult ChangedRecomputeDiff "" True

@@ -0,0 +1,7 @@+import qualified Spec+import Test.Tasty+import Test.Tasty.Hspec+import Test.Tasty.Ingredients.Rerun (defaultMainWithRerun)++main :: IO ()+main = testSpecs Spec.spec >>= defaultMainWithRerun . testGroup "tactics"

@@ -0,0 +1,8 @@+module RulesSpec where++import Test.Hspec++spec :: Spec+spec = do+    describe "" $ do+        pure ()

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}