hls-graph 2.6.0.0 → 2.14.0.0
raw patch · 15 files changed
Files
- hls-graph.cabal +18/−18
- src/Control/Concurrent/STM/Stats.hs +2/−5
- src/Development/IDE/Graph.hs +4/−5
- src/Development/IDE/Graph/Database.hs +1/−3
- src/Development/IDE/Graph/Internal/Action.hs +6/−10
- src/Development/IDE/Graph/Internal/Database.hs +63/−32
- src/Development/IDE/Graph/Internal/Key.hs +182/−0
- src/Development/IDE/Graph/Internal/Profile.hs +9/−4
- src/Development/IDE/Graph/Internal/Rules.hs +3/−3
- src/Development/IDE/Graph/Internal/Types.hs +48/−165
- src/Development/IDE/Graph/KeyMap.hs +1/−1
- src/Development/IDE/Graph/KeySet.hs +1/−1
- test/ActionSpec.hs +89/−36
- test/DatabaseSpec.hs +34/−15
- test/Example.hs +53/−10
hls-graph.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph-version: 2.6.0.0+version: 2.14.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>@@ -39,7 +39,16 @@ type: git location: https://github.com/haskell/haskell-language-server +common warnings+ ghc-options:+ -Wall+ -Wredundant-constraints+ -Wunused-packages+ -Wno-name-shadowing+ -Wno-unticked-promoted-constructors+ library+ import: warnings exposed-modules: Control.Concurrent.STM.Stats Development.IDE.Graph@@ -48,6 +57,7 @@ Development.IDE.Graph.Internal.Action Development.IDE.Graph.Internal.Database Development.IDE.Graph.Internal.Options+ Development.IDE.Graph.Internal.Key Development.IDE.Graph.Internal.Paths Development.IDE.Graph.Internal.Profile Development.IDE.Graph.Internal.Rules@@ -66,7 +76,6 @@ , bytestring , containers , deepseq- , directory , exceptions , extra , filepath@@ -89,26 +98,24 @@ build-depends: , file-embed >=0.0.11 , template-haskell+ else+ build-depends:+ directory if flag(stm-stats) cpp-options: -DSTM_STATS - ghc-options:- -Wall -Wredundant-constraints -Wno-name-shadowing- -Wno-unticked-promoted-constructors -Wunused-packages- if flag(pedantic) ghc-options: -Werror - default-language: Haskell2010+ default-language: GHC2021 default-extensions: DataKinds- KindSignatures- TypeOperators test-suite tests+ import: warnings type: exitcode-stdio-1.0- default-language: Haskell2010+ default-language: GHC2021 hs-source-dirs: test main-is: Main.hs other-modules:@@ -120,23 +127,16 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts- -Wunused-packages build-depends: , base- , containers- , directory , extra- , filepath , hls-graph , hspec , stm , stm-containers , tasty- , tasty-hspec- , tasty-hunit+ , tasty-hspec >= 1.2 , tasty-rerun- , text- , unordered-containers build-tool-depends: hspec-discover:hspec-discover
src/Control/Concurrent/STM/Stats.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} #ifdef STM_STATS-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} #endif module Control.Concurrent.STM.Stats ( atomicallyNamed@@ -21,7 +20,6 @@ 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@@ -152,7 +150,6 @@ -- '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) =
src/Development/IDE/Graph.hs view
@@ -3,7 +3,7 @@ shakeOptions, Rules, Action, action,- Key(.., Key),+ pattern Key, newKey, renderKey, actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration@@ -15,8 +15,6 @@ ShakeValue, RuleResult, -- * Special rules alwaysRerun,- -- * Batching- reschedule, -- * Actions for inspecting the keys in the database getDirtySet, getKeysAndVisitedAge,@@ -25,9 +23,10 @@ ) where import Development.IDE.Graph.Database-import Development.IDE.Graph.KeyMap-import Development.IDE.Graph.KeySet import Development.IDE.Graph.Internal.Action+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types+import Development.IDE.Graph.KeyMap+import Development.IDE.Graph.KeySet
src/Development/IDE/Graph/Database.hs view
@@ -1,6 +1,3 @@--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-} module Development.IDE.Graph.Database( ShakeDatabase, ShakeValue,@@ -19,6 +16,7 @@ import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules
src/Development/IDE/Graph/Internal/Action.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module Development.IDE.Graph.Internal.Action ( ShakeValue@@ -13,13 +11,13 @@ , apply , applyWithoutDependency , parallel-, reschedule , runActions , Development.IDE.Graph.Internal.Action.getDirtySet , getKeysAndVisitedAge ) where import Control.Concurrent.Async+import Control.DeepSeq (force) import Control.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Class@@ -29,6 +27,7 @@ import Data.IORef import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Rules (RuleResult) import Development.IDE.Graph.Internal.Types import System.Exit@@ -39,11 +38,7 @@ alwaysRerun :: Action () alwaysRerun = do ref <- Action $ asks actionDeps- liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)---- No-op for now-reschedule :: Double -> Action ()-reschedule _ = pure ()+ liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>) parallel :: [Action a] -> Action [a] parallel [] = pure []@@ -121,7 +116,8 @@ stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps- liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>)+ let !ks = force $ fromListKeySet $ toList is+ liftIO $ modifyIORef' ref (ResultDeps [ks] <>) pure vs -- | Evaluate a list of keys without recording any dependencies.
src/Development/IDE/Graph/Internal/Database.hs view
@@ -2,16 +2,13 @@ -- has the constraints we need on it when we get it out. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where+module Development.IDE.Graph.Internal.Database (compute, newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Prelude hiding (unzip) @@ -31,12 +28,12 @@ import Data.Either import Data.Foldable (for_, traverse_) import Data.IORef.Extra-import Data.List.NonEmpty (unzip) 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.Key import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types import qualified Focus@@ -45,7 +42,13 @@ import System.IO.Unsafe import System.Time.Extra (duration, sleep) +#if MIN_VERSION_base(4,19,0)+import Data.Functor (unzip)+#else+import Data.List.NonEmpty (unzip)+#endif + newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do databaseStep <- newTVarIO $ Step 0@@ -136,26 +139,44 @@ waitAll pure results ++-- | isDirty+-- only dirty when it's build time is older than the changed time of one of its dependencies+isDirty :: Foldable t => Result -> t (a, Result) -> Bool+isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)++-- | Refresh dependencies for a key and compute the key:+-- The refresh the deps linearly(last computed order of the deps for the key).+-- If any of the deps is dirty in the process, we jump to the actual computation of the key+-- and shortcut the refreshing of the rest of the deps.+-- * 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+refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result+refreshDeps visited db stack key result = \case+ -- no more deps to refresh+ [] -> liftIO $ compute db stack key RunDependenciesSame (Just result)+ (dep:deps) -> do+ let newVisited = dep <> visited+ res <- builder db stack (toListKeySet (dep `differenceKeySet` visited))+ case res of+ Left res -> if isDirty result res+ -- restart the computation if any of the deps are dirty+ then liftIO $ compute db stack key RunDependenciesChanged (Just result)+ -- else kick the rest of the deps+ else refreshDeps newVisited db stack key result deps+ Right iores -> do+ res <- liftIO iores+ if isDirty result res+ then liftIO $ compute db stack key RunDependenciesChanged (Just result)+ else refreshDeps newVisited db stack key result deps+ -- | 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 -> 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 (toListKeySet -> 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, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result @@ -167,16 +188,24 @@ deps <- newIORef UnknownDeps (execution, RunResult{..}) <- duration $ runReaderT (fromAction act) $ SAction db deps stack- built <- readTVarIO databaseStep+ curStep <- 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- -- only update the deps when the rule ran with changes+ let lastChanged = maybe curStep resultChanged result+ let lastBuild = maybe curStep resultBuilt result+ -- changed time is always older than or equal to build time+ let (changed, built) = case runChanged of+ -- some thing changed+ ChangedRecomputeDiff -> (curStep, curStep)+ -- recomputed is the same+ ChangedRecomputeSame -> (lastChanged, curStep)+ -- nothing changed+ ChangedNothing -> (lastChanged, lastBuild)+ let -- only update the deps when the rule ran with changes actualDeps = if runChanged /= ChangedNothing then deps else previousDeps previousDeps= maybe UnknownDeps resultDeps result- let res = Result runValue built' changed built actualDeps execution runStore+ let res = Result runValue built changed curStep actualDeps execution runStore case getResultDepsDefault mempty actualDeps of- deps | not(nullKeySet deps)+ deps | not (nullKeySet deps) && runChanged /= ChangedNothing -> do -- IMPORTANT: record the reverse deps **before** marking the key Clean.@@ -188,7 +217,9 @@ (getResultDepsDefault mempty previousDeps) deps _ -> pure ()- atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues+ atomicallyNamed "compute and run hook" $ do+ runHook+ SMap.focus (updateStatus $ Clean res) key databaseValues pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m ()
+ src/Development/IDE/Graph/Internal/Key.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module Development.IDE.Graph.Internal.Key+ ( Key -- Opaque - don't expose constructor, use newKey to create+ , KeyValue (..)+ , pattern Key+ , newKey+ , renderKey+ -- * KeyMap+ , KeyMap+ , mapKeyMap+ , insertKeyMap+ , lookupKeyMap+ , lookupDefaultKeyMap+ , fromListKeyMap+ , fromListWithKeyMap+ , toListKeyMap+ , elemsKeyMap+ , restrictKeysKeyMap+ -- * KeySet+ , KeySet+ , nullKeySet+ , insertKeySet+ , memberKeySet+ , toListKeySet+ , lengthKeySet+ , filterKeySet+ , singletonKeySet+ , fromListKeySet+ , deleteKeySet+ , differenceKeySet+ ) where++--import Control.Monad.IO.Class ()+import Control.Exception (evaluate)+import Data.Coerce+import Data.Dynamic+import qualified Data.HashMap.Strict as Map+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as IM+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import Development.IDE.Graph.Classes+import System.IO.Unsafe+++newtype Key = UnsafeMkKey Int++pattern Key :: () => (Typeable a, Hashable a, Show a) => a -> Key+pattern Key a <- (lookupKeyValue -> KeyValue a _)+{-# COMPLETE Key #-}++data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text++instance Eq KeyValue where+ KeyValue a _ == KeyValue b _ = Just a == cast b+instance Hashable KeyValue where+ hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x)+instance Show KeyValue where+ show (KeyValue _ t) = T.unpack t++data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int++keyMap :: IORef GlobalKeyValueMap+keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0)++{-# NOINLINE keyMap #-}++newKey :: (Typeable a, Hashable a, Show a) => a -> Key+newKey k = unsafePerformIO $ do+ let !newKey = KeyValue k (T.pack (show k))+ atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) ->+ let new_key = Map.lookup newKey hm+ in case new_key of+ Just v -> (km, v)+ Nothing ->+ let !new_index = UnsafeMkKey n+ in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index)+{-# NOINLINE newKey #-}++lookupKeyValue :: Key -> KeyValue+lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do+ -- NOTE:+ -- The reason for this evaluate is that the x, if not forced yet, is a thunk+ -- that forces the atomicModifyIORef' in the creation of the new key. If it+ -- isn't forced *before* reading the keyMap, the keyMap will only obtain the new+ -- key (x) *after* the IntMap is already copied out of the keyMap reference,+ -- i.e. when it is forced for the lookup in the IntMap.+ k <- evaluate x+ GlobalKeyValueMap _ im _ <- readIORef keyMap+ pure $! im IM.! k++{-# NOINLINE lookupKeyValue #-}++instance Eq Key where+ UnsafeMkKey a == UnsafeMkKey b = a == b+instance Hashable Key where+ hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x+instance Show Key where+ show (Key x) = show x++renderKey :: Key -> Text+renderKey (lookupKeyValue -> KeyValue _ t) = t++newtype KeySet = KeySet IntSet+ deriving newtype (Eq, Ord, Semigroup, Monoid, NFData)++instance Show KeySet where+ showsPrec p (KeySet is)= showParen (p > 10) $+ showString "fromList " . shows ks+ where ks = coerce (IS.toList is) :: [Key]++insertKeySet :: Key -> KeySet -> KeySet+insertKeySet = coerce IS.insert++memberKeySet :: Key -> KeySet -> Bool+memberKeySet = coerce IS.member++toListKeySet :: KeySet -> [Key]+toListKeySet = coerce IS.toList++nullKeySet :: KeySet -> Bool+nullKeySet = coerce IS.null++differenceKeySet :: KeySet -> KeySet -> KeySet+differenceKeySet = coerce IS.difference++deleteKeySet :: Key -> KeySet -> KeySet+deleteKeySet = coerce IS.delete++fromListKeySet :: [Key] -> KeySet+fromListKeySet = coerce IS.fromList++singletonKeySet :: Key -> KeySet+singletonKeySet = coerce IS.singleton++filterKeySet :: (Key -> Bool) -> KeySet -> KeySet+filterKeySet = coerce IS.filter++lengthKeySet :: KeySet -> Int+lengthKeySet = coerce IS.size++newtype KeyMap a = KeyMap (IntMap a)+ deriving newtype (Eq, Ord, Semigroup, Monoid)++instance Show a => Show (KeyMap a) where+ showsPrec p (KeyMap im)= showParen (p > 10) $+ showString "fromList " . shows ks+ where ks = coerce (IM.toList im) :: [(Key,a)]++mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b+mapKeyMap f (KeyMap m) = KeyMap (IM.map f m)++insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a+insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m)++lookupKeyMap :: Key -> KeyMap a -> Maybe a+lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m++lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a+lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m++fromListKeyMap :: [(Key,a)] -> KeyMap a+fromListKeyMap xs = KeyMap (IM.fromList (coerce xs))++fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a+fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs))++toListKeyMap :: KeyMap a -> [(Key,a)]+toListKeyMap (KeyMap m) = coerce (IM.toList m)++elemsKeyMap :: KeyMap a -> [a]+elemsKeyMap (KeyMap m) = IM.elems m++restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a+restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s)
src/Development/IDE/Graph/Internal/Profile.hs view
@@ -13,7 +13,7 @@ import Data.Char import Data.Dynamic (toDyn) import qualified Data.HashMap.Strict as Map-import Data.List (dropWhileEnd, foldl',+import Data.List (dropWhileEnd, intercalate, partition, sort, sortBy)@@ -21,8 +21,8 @@ import Data.Maybe import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show)-import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database (getDirtySet)+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable as DGTable@@ -33,6 +33,10 @@ import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra (Seconds) +#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+ #ifdef FILE_EMBED import Data.FileEmbed import Language.Haskell.TH.Syntax (runIO)@@ -64,7 +68,7 @@ -- | 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. -- Raise an error if you end up with a cycle.--- dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a]+-- -- Algorithm: -- Divide everyone up into those who have no dependencies [Id] -- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]@@ -72,6 +76,7 @@ -- For each with no dependencies, add to list, then take its dep hole and -- promote them either to Nothing (if ds == []) or into a new slot. -- k :-> Nothing means the key has already been freed+dependencyOrder :: (Key -> String) -> [(Key, [Key])] -> [Key] dependencyOrder shw status = f (map fst noDeps) $ mapKeyMap Just $@@ -88,7 +93,7 @@ where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- toListKeyMap mp] f (x:xs) mp = x : f (now++xs) later- where Just free = lookupDefaultKeyMap (Just []) x mp+ where free = fromMaybe [] $ lookupDefaultKeyMap (Just []) x mp (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free g (free, mp) (k, []) = (k:free, mp)
src/Development/IDE/Graph/Internal/Rules.hs view
@@ -1,9 +1,8 @@ -- 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 #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} module Development.IDE.Graph.Internal.Rules where @@ -18,6 +17,7 @@ import Data.Maybe import Data.Typeable import Development.IDE.Graph.Classes+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types -- | The type mapping between the @key@ or a rule and the resulting @value@.
src/Development/IDE/Graph/Internal/Types.hs view
@@ -1,48 +1,38 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE RecordWildCards #-} module Development.IDE.Graph.Internal.Types where -import Control.Applicative+import Control.Concurrent.STM (STM)+import Control.Monad ((>=>)) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader-import Data.Aeson (FromJSON, ToJSON)-import Data.Bifunctor (second)-import qualified Data.ByteString as BS-import Data.Coerce+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.IntMap.Strict as IM-import Data.IntMap (IntMap)-import qualified Data.IntSet as IS-import Data.IntSet (IntSet)-import qualified Data.Text as T-import Data.Text (Text)+import Data.Foldable (fold)+import qualified Data.HashMap.Strict as Map import Data.IORef-import Data.List (intercalate)+import Data.List (intercalate) import Data.Maybe import Data.Typeable import Development.IDE.Graph.Classes-import GHC.Conc (TVar, atomically)-import GHC.Generics (Generic)+import Development.IDE.Graph.Internal.Key+import GHC.Conc (TVar, atomically)+import GHC.Generics (Generic) import qualified ListT-import qualified StmContainers.Map as SMap-import StmContainers.Map (Map)-import System.Time.Extra (Seconds)-import System.IO.Unsafe-import UnliftIO (MonadUnliftIO)+import qualified StmContainers.Map as SMap+import StmContainers.Map (Map)+import System.Time.Extra (Seconds)+import UnliftIO (MonadUnliftIO) +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif unwrapDynamic :: forall a . Typeable a => Dynamic -> a unwrapDynamic x = fromMaybe (error msg) $ fromDynamic x@@ -68,15 +58,14 @@ rulesMap :: !(IORef TheRules) } - --------------------------------------------------------------------- -- ACTIONS -- | An action representing something that can be run as part of a 'Rule'.--- +-- -- 'Action's can be pure functions but also have access to 'IO' via 'MonadIO' and 'MonadUnliftIO. -- It should be assumed that actions throw exceptions, these can be caught with--- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is +-- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is -- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'. newtype Action a = Action {fromAction :: ReaderT SAction IO a} deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)@@ -90,140 +79,24 @@ getDatabase :: Action Database getDatabase = Action $ asks actionDatabase +-- | waitForDatabaseRunningKeysAction waits for all keys in the database to finish running.+waitForDatabaseRunningKeysAction :: Action ()+waitForDatabaseRunningKeysAction = getDatabase >>= liftIO . waitForDatabaseRunningKeys+ --------------------------------------------------------------------- -- DATABASE data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int- deriving newtype (Eq,Ord,Hashable)+ deriving newtype (Eq,Ord,Hashable,Show) --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text -newtype Key = UnsafeMkKey Int -pattern Key a <- (lookupKeyValue -> KeyValue a _) -data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int--keyMap :: IORef GlobalKeyValueMap-keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0)--{-# NOINLINE keyMap #-}--newKey :: (Eq a, Typeable a, Hashable a, Show a) => a -> Key-newKey k = unsafePerformIO $ do- let !newKey = KeyValue k (T.pack (show k))- atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) ->- let new_key = Map.lookup newKey hm- in case new_key of- Just v -> (km, v)- Nothing ->- let !new_index = UnsafeMkKey n- in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index)-{-# NOINLINE newKey #-}--lookupKeyValue :: Key -> KeyValue-lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do- GlobalKeyValueMap _ im _ <- readIORef keyMap- pure $! im IM.! x--{-# NOINLINE lookupKeyValue #-}--instance Eq Key where- UnsafeMkKey a == UnsafeMkKey b = a == b-instance Hashable Key where- hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x-instance Show Key where- show (Key x) = show x--instance Eq KeyValue where- KeyValue a _ == KeyValue b _ = Just a == cast b-instance Hashable KeyValue where- hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x)-instance Show KeyValue where- show (KeyValue x t) = T.unpack t--renderKey :: Key -> Text-renderKey (lookupKeyValue -> KeyValue _ t) = t--newtype KeySet = KeySet IntSet- deriving newtype (Eq, Ord, Semigroup, Monoid)--instance Show KeySet where- showsPrec p (KeySet is)= showParen (p > 10) $- showString "fromList " . shows ks- where ks = coerce (IS.toList is) :: [Key]--insertKeySet :: Key -> KeySet -> KeySet-insertKeySet = coerce IS.insert--memberKeySet :: Key -> KeySet -> Bool-memberKeySet = coerce IS.member--toListKeySet :: KeySet -> [Key]-toListKeySet = coerce IS.toList--nullKeySet :: KeySet -> Bool-nullKeySet = coerce IS.null--differenceKeySet :: KeySet -> KeySet -> KeySet-differenceKeySet = coerce IS.difference--deleteKeySet :: Key -> KeySet -> KeySet-deleteKeySet = coerce IS.delete--fromListKeySet :: [Key] -> KeySet-fromListKeySet = coerce IS.fromList--singletonKeySet :: Key -> KeySet-singletonKeySet = coerce IS.singleton--filterKeySet :: (Key -> Bool) -> KeySet -> KeySet-filterKeySet = coerce IS.filter--lengthKeySet :: KeySet -> Int-lengthKeySet = coerce IS.size--newtype KeyMap a = KeyMap (IntMap a)- deriving newtype (Eq, Ord, Semigroup, Monoid)--instance Show a => Show (KeyMap a) where- showsPrec p (KeyMap im)= showParen (p > 10) $- showString "fromList " . shows ks- where ks = coerce (IM.toList im) :: [(Key,a)]--mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b-mapKeyMap f (KeyMap m) = KeyMap (IM.map f m)--insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a-insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m)--lookupKeyMap :: Key -> KeyMap a -> Maybe a-lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m--lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a-lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m--fromListKeyMap :: [(Key,a)] -> KeyMap a-fromListKeyMap xs = KeyMap (IM.fromList (coerce xs))--fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a-fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs))--toListKeyMap :: KeyMap a -> [(Key,a)]-toListKeyMap (KeyMap m) = coerce (IM.toList m)--elemsKeyMap :: KeyMap a -> [a]-elemsKeyMap (KeyMap m) = IM.elems m--restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a-restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s)-- newtype Value = Value Dynamic data KeyDetails = KeyDetails {@@ -242,6 +115,9 @@ databaseValues :: !(Map Key KeyDetails) } +waitForDatabaseRunningKeys :: Database -> IO ()+waitForDatabaseRunningKeys = getDatabaseValues >=> mapM_ (waitRunning . snd)+ getDatabaseValues :: Database -> IO [(Key, Status)] getDatabaseValues = atomically . (fmap.fmap) (second keyStatus)@@ -268,6 +144,10 @@ getResult (Dirty m_re) = m_re getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result +waitRunning :: Status -> IO ()+waitRunning Running{..} = runningWait+waitRunning _ = return ()+ data Result = Result { resultValue :: !Value, resultBuilt :: !Step, -- ^ the step when it was last recomputed@@ -278,16 +158,20 @@ resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet+-- Notice, invariant to maintain:+-- the ![KeySet] in ResultDeps need to be stored in reverse order,+-- so that we can append to it efficiently, and we need the ordering+-- so we can do a linear dependency refreshing in refreshDeps.+data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet] deriving (Eq, Show) getResultDepsDefault :: KeySet -> ResultDeps -> KeySet-getResultDepsDefault _ (ResultDeps ids) = ids+getResultDepsDefault _ (ResultDeps ids) = fold ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps-mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids+mapResultDeps f (ResultDeps ids) = ResultDeps $ fmap f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps @@ -315,7 +199,6 @@ -- | How the output of a rule has changed. data RunChanged = ChangedNothing -- ^ Nothing has changed.- | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely). | ChangedRecomputeSame -- ^ I recomputed the value and it was the same. | ChangedRecomputeDiff -- ^ I recomputed the value and it was different. deriving (Eq,Show,Generic)@@ -331,11 +214,11 @@ -- ^ The value to store in the Shake database. ,runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'.+ ,runHook :: STM ()+ -- ^ The hook to run at the end of the build in the same transaction+ -- when the key is marked as clean. } deriving Functor -instance NFData value => NFData (RunResult value) where- rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3- --------------------------------------------------------------------- -- EXCEPTIONS @@ -344,7 +227,7 @@ stack :: [String], -- ^ The stack of keys that led to this exception inner :: e -- ^ The underlying exception }- deriving (Typeable, Exception)+ deriving (Exception) instance Show GraphException where show GraphException{..} = unlines $@@ -366,7 +249,7 @@ show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk) newtype StackException = StackException Stack- deriving (Typeable, Show)+ deriving (Show) instance Exception StackException where fromException = fromGraphException
src/Development/IDE/Graph/KeyMap.hs view
@@ -12,4 +12,4 @@ restrictKeysKeyMap, ) where -import Development.IDE.Graph.Internal.Types+import Development.IDE.Graph.Internal.Key
src/Development/IDE/Graph/KeySet.hs view
@@ -13,4 +13,4 @@ lengthKeySet, ) where -import Development.IDE.Graph.Internal.Types+import Development.IDE.Graph.Internal.Key
test/ActionSpec.hs view
@@ -1,32 +1,68 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module ActionSpec where +import Control.Concurrent (MVar, readMVar)+import qualified Control.Concurrent as C import Control.Concurrent.STM-import qualified Data.HashSet as HashSet-import Development.IDE.Graph (shakeOptions)-import Development.IDE.Graph.Database (shakeNewDatabase,- shakeRunDatabase)-import Development.IDE.Graph.Internal.Action (apply1)+import Control.Monad.IO.Class (MonadIO (..))+import Development.IDE.Graph (shakeOptions)+import Development.IDE.Graph.Database (shakeNewDatabase,+ shakeRunDatabase,+ shakeRunDatabaseForKeys)+import Development.IDE.Graph.Internal.Database (build, incDatabase)+import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Types import Development.IDE.Graph.Rule import Example-import qualified StmContainers.Map as STM-import System.Time.Extra (timeout)+import qualified StmContainers.Map as STM import Test.Hspec ++ spec :: Spec spec = do+ describe "apply1" $ it "Test build update, Buggy dirty mechanism in hls-graph #4237" $ do+ let ruleStep1 :: MVar Int -> Rules ()+ ruleStep1 m = addRule $ \CountRule _old mode -> do+ -- depends on ruleSubBranch, it always changed if dirty+ _ :: Int <- apply1 SubBranchRule+ let r = 1+ case mode of+ -- it update the built step+ RunDependenciesChanged -> do+ _ <- liftIO $ C.modifyMVar m $ \x -> return (x+1, x)+ return $ RunResult ChangedRecomputeSame "" r (return ())+ -- this won't update the built step+ RunDependenciesSame ->+ return $ RunResult ChangedNothing "" r (return ())+ count <- C.newMVar 0+ count1 <- C.newMVar 0+ db <- shakeNewDatabase shakeOptions $ do+ ruleSubBranch count+ ruleStep1 count1+ -- bootstrapping the database+ _ <- shakeRunDatabase db $ pure $ apply1 CountRule -- count = 1+ let child = newKey SubBranchRule+ let parent = newKey CountRule+ -- instruct to RunDependenciesChanged then CountRule should be recomputed+ -- result should be changed 0, build 1+ _res1 <- shakeRunDatabaseForKeys (Just [child]) db [apply1 CountRule] -- count = 2+ -- since child changed = parent build+ -- instruct to RunDependenciesSame then CountRule should not be recomputed+ -- result should be changed 0, build 1+ _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2+ -- invariant child changed = parent build should remains after RunDependenciesSame+ -- this used to be a bug, with additional computation, see https://github.com/haskell/haskell-language-server/pull/4238+ _res3 <- shakeRunDatabaseForKeys (Just [parent]) db [apply1 CountRule] -- count = 2+ c1 <- readMVar count1+ c1 `shouldBe` 2 describe "apply1" $ do it "computes a rule with no dependencies" $ do- db <- shakeNewDatabase shakeOptions $ do- ruleUnit+ db <- shakeNewDatabase shakeOptions ruleUnit res <- shakeRunDatabase db $- pure $ do- apply1 (Rule @())+ pure $ apply1 (Rule @()) res `shouldBe` [()] it "computes a rule with one dependency" $ do db <- shakeNewDatabase shakeOptions $ do@@ -40,39 +76,56 @@ ruleBool let theKey = Rule @Bool res <- shakeRunDatabase db $- pure $ do- apply1 theKey+ pure $ apply1 theKey res `shouldBe` [True] Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb- resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @()))+ resultDeps res `shouldBe` ResultDeps [singletonKeySet $ newKey (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+ pure $ apply1 theKey res `shouldBe` [True] Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues- keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey)+ keyReverseDeps `shouldBe` singletonKeySet (newKey theKey) it "rethrows exceptions" $ do- db <- shakeNewDatabase shakeOptions $ do- addRule $ \(Rule :: Rule ()) old mode -> error "boom"+ db <- shakeNewDatabase shakeOptions $ 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+ it "computes a rule with branching dependencies does not invoke phantom dependencies #3423" $ do+ cond <- C.newMVar True+ count <- C.newMVar 0+ (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do ruleUnit- addRule $ \Rule old mode -> do- [()] <- applyWithoutDependency [Rule]- return $ RunResult ChangedRecomputeDiff "" True+ ruleCond cond+ ruleSubBranch count+ ruleWithCond+ -- build the one with the condition True+ -- This should call the SubBranchRule once+ -- cond rule would return different results each time+ res0 <- build theDb emptyStack [BranchedRule]+ snd res0 `shouldBe` [1 :: Int]+ incDatabase theDb Nothing+ -- build the one with the condition False+ -- This should not call the SubBranchRule+ res1 <- build theDb emptyStack [BranchedRule]+ snd res1 `shouldBe` [2 :: Int]+ -- SubBranchRule should be recomputed once before this (when the condition was True)+ countRes <- build theDb emptyStack [SubBranchRule]+ snd countRes `shouldBe` [1 :: Int] - let theKey = Rule @Bool- res <- shakeRunDatabase db $- pure $ do- applyWithoutDependency [theKey]- res `shouldBe` [[True]]- Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb- resultDeps res `shouldBe` UnknownDeps+ describe "applyWithoutDependency" $ it "does not track dependencies" $ do+ db@(ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+ ruleUnit+ addRule $ \Rule _old _mode -> do+ [()] <- applyWithoutDependency [Rule]+ return $ RunResult ChangedRecomputeDiff "" True $ return ()++ let theKey = Rule @Bool+ res <- shakeRunDatabase db $+ pure $ applyWithoutDependency [theKey]+ res `shouldBe` [[True]]+ Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb+ resultDeps res `shouldBe` UnknownDeps
test/DatabaseSpec.hs view
@@ -1,30 +1,49 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+ 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 (newKey, shakeOptions)+import Development.IDE.Graph.Database (shakeNewDatabase,+ shakeRunDatabase)+import Development.IDE.Graph.Internal.Action (apply1)+import Development.IDE.Graph.Internal.Database (compute, incDatabase)+import Development.IDE.Graph.Internal.Rules (addRule) import Development.IDE.Graph.Internal.Types-import Development.IDE.Graph.Rule import Example-import qualified StmContainers.Map as STM-import System.Time.Extra (timeout)+import System.Time.Extra (timeout) import Test.Hspec + spec :: Spec spec = do describe "Evaluation" $ do it "detects cycles" $ do db <- shakeNewDatabase shakeOptions $ do ruleBool- addRule $ \Rule old mode -> do+ addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool)- return $ RunResult ChangedRecomputeDiff "" ()+ return $ RunResult ChangedRecomputeDiff "" () (return ()) let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True++ describe "compute" $ do+ it "build step and changed step updated correctly" $ do+ (ShakeDatabase _ _ theDb) <- shakeNewDatabase shakeOptions $ do+ ruleStep++ let k = newKey $ Rule @()+ -- ChangedRecomputeSame+ r1@Result{resultChanged=rc1, resultBuilt=rb1} <- compute theDb emptyStack k RunDependenciesChanged Nothing+ incDatabase theDb Nothing+ -- ChangedRecomputeSame+ r2@Result{resultChanged=rc2, resultBuilt=rb2} <- compute theDb emptyStack k RunDependenciesChanged (Just r1)+ incDatabase theDb Nothing+ -- changed Nothing+ Result{resultChanged=rc3, resultBuilt=rb3} <- compute theDb emptyStack k RunDependenciesSame (Just r2)+ rc1 `shouldBe` Step 0+ rc2 `shouldBe` Step 0+ rc3 `shouldBe` Step 0++ rb1 `shouldBe` Step 0+ rb2 `shouldBe` Step 1+ rb3 `shouldBe` Step 1
test/Example.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NoPolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} module Example where +import qualified Control.Concurrent as C+import Control.Monad.IO.Class (liftIO) import Development.IDE.Graph import Development.IDE.Graph.Classes import Development.IDE.Graph.Rule@@ -20,12 +20,55 @@ type instance RuleResult (Rule a) = a +ruleStep :: Rules ()+ruleStep = addRule $ \(Rule :: Rule ()) _old mode -> do+ case mode of+ RunDependenciesChanged -> return $ RunResult ChangedRecomputeSame "" () (return ())+ RunDependenciesSame -> return $ RunResult ChangedNothing "" () (return ())+ ruleUnit :: Rules ()-ruleUnit = addRule $ \(Rule :: Rule ()) old mode -> do- return $ RunResult ChangedRecomputeDiff "" ()+ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do+ return $ RunResult ChangedRecomputeDiff "" () (return ()) -- | Depends on Rule @() ruleBool :: Rules ()-ruleBool = addRule $ \Rule old mode -> do+ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule- return $ RunResult ChangedRecomputeDiff "" True+ return $ RunResult ChangedRecomputeDiff "" True (return ())+++data CondRule = CondRule+ deriving (Eq, Generic, Hashable, NFData, Show)+type instance RuleResult CondRule = Bool+++ruleCond :: C.MVar Bool -> Rules ()+ruleCond mv = addRule $ \CondRule _old _mode -> do+ r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x)+ return $ RunResult ChangedRecomputeDiff "" r (return ())++data BranchedRule = BranchedRule+ deriving (Eq, Generic, Hashable, NFData, Show)+type instance RuleResult BranchedRule = Int++ruleWithCond :: Rules ()+ruleWithCond = addRule $ \BranchedRule _old _mode -> do+ r <- apply1 CondRule+ if r then do+ _ <- apply1 SubBranchRule+ return $ RunResult ChangedRecomputeDiff "" (1 :: Int) (return ())+ else+ return $ RunResult ChangedRecomputeDiff "" (2 :: Int) (return ())++data SubBranchRule = SubBranchRule+ deriving (Eq, Generic, Hashable, NFData, Show)+type instance RuleResult SubBranchRule = Int++ruleSubBranch :: C.MVar Int -> Rules ()+ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do+ r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x)+ return $ RunResult ChangedRecomputeDiff "" r (return ())++data CountRule = CountRule+ deriving (Eq, Generic, Hashable, NFData, Show)+type instance RuleResult CountRule = Int