diff --git a/hls-graph.cabal b/hls-graph.cabal --- a/hls-graph.cabal +++ b/hls-graph.cabal @@ -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 @@ -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 diff --git a/src/Control/Concurrent/STM/Stats.hs b/src/Control/Concurrent/STM/Stats.hs --- a/src/Control/Concurrent/STM/Stats.hs +++ b/src/Control/Concurrent/STM/Stats.hs @@ -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) = diff --git a/src/Development/IDE/Graph.hs b/src/Development/IDE/Graph.hs --- a/src/Development/IDE/Graph.hs +++ b/src/Development/IDE/Graph.hs @@ -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 diff --git a/src/Development/IDE/Graph/Database.hs b/src/Development/IDE/Graph/Database.hs --- a/src/Development/IDE/Graph/Database.hs +++ b/src/Development/IDE/Graph/Database.hs @@ -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 diff --git a/src/Development/IDE/Graph/Internal/Action.hs b/src/Development/IDE/Graph/Internal/Action.hs --- a/src/Development/IDE/Graph/Internal/Action.hs +++ b/src/Development/IDE/Graph/Internal/Action.hs @@ -1,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. diff --git a/src/Development/IDE/Graph/Internal/Database.hs b/src/Development/IDE/Graph/Internal/Database.hs --- a/src/Development/IDE/Graph/Internal/Database.hs +++ b/src/Development/IDE/Graph/Internal/Database.hs @@ -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 () diff --git a/src/Development/IDE/Graph/Internal/Key.hs b/src/Development/IDE/Graph/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Graph/Internal/Key.hs @@ -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) diff --git a/src/Development/IDE/Graph/Internal/Profile.hs b/src/Development/IDE/Graph/Internal/Profile.hs --- a/src/Development/IDE/Graph/Internal/Profile.hs +++ b/src/Development/IDE/Graph/Internal/Profile.hs @@ -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) diff --git a/src/Development/IDE/Graph/Internal/Rules.hs b/src/Development/IDE/Graph/Internal/Rules.hs --- a/src/Development/IDE/Graph/Internal/Rules.hs +++ b/src/Development/IDE/Graph/Internal/Rules.hs @@ -1,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@. diff --git a/src/Development/IDE/Graph/Internal/Types.hs b/src/Development/IDE/Graph/Internal/Types.hs --- a/src/Development/IDE/Graph/Internal/Types.hs +++ b/src/Development/IDE/Graph/Internal/Types.hs @@ -1,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 diff --git a/src/Development/IDE/Graph/KeyMap.hs b/src/Development/IDE/Graph/KeyMap.hs --- a/src/Development/IDE/Graph/KeyMap.hs +++ b/src/Development/IDE/Graph/KeyMap.hs @@ -12,4 +12,4 @@ restrictKeysKeyMap, ) where -import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Internal.Key diff --git a/src/Development/IDE/Graph/KeySet.hs b/src/Development/IDE/Graph/KeySet.hs --- a/src/Development/IDE/Graph/KeySet.hs +++ b/src/Development/IDE/Graph/KeySet.hs @@ -13,4 +13,4 @@ lengthKeySet, ) where -import Development.IDE.Graph.Internal.Types +import Development.IDE.Graph.Internal.Key diff --git a/test/ActionSpec.hs b/test/ActionSpec.hs --- a/test/ActionSpec.hs +++ b/test/ActionSpec.hs @@ -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 diff --git a/test/DatabaseSpec.hs b/test/DatabaseSpec.hs --- a/test/DatabaseSpec.hs +++ b/test/DatabaseSpec.hs @@ -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 diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -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